LAPACK examples¶
ex1_lapack_gebrd.F90¶
program ex1_lapack_gebrd ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutines GEBRD and ORGBR ! in LAPACK software for computing a bidiagonal decomposition of a real matrix. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : gebrd, orgbr ! use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, & unit_matrix, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, m AND n ARE THE DIMENSIONS OF THE GENERATED MATRIX. ! integer, parameter :: prtunit = 6, m=3000, n=3000, k=min(m,n) ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 1 of gebrd' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err1, err2, err3, err, eps, elapsed_time real(stnd) :: work2(1) real(stnd), allocatable, dimension(:) :: d, e, tauq, taup, work, resid2 real(stnd), allocatable, dimension(:,:) :: a, a2, resid, bd, pt, q ! integer :: info_bd, info_q, info_pt, lwork, lwork_bd, lwork_q, lwork_pt, & iok, istart, iend, irate, imax, itime integer(i4b) :: l ! logical(lgl) :: do_test ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : BIDIAGONAL REDUCTION OF A REAL MATRIX. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! if ( m>=n ) then allocate( a(m,n), d(k), e(k-1_i4b), tauq(k), taup(k), pt(k,k), stat=iok ) else allocate( a(m,n), d(k), e(k-1_i4b), tauq(k), taup(k), q(k,k), stat=iok ) end if ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A m-by-n REAL RANDOM DATA MATRIX. ! call random_number( a ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(m,n), bd(k,k), resid(k,n), resid2(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SAVE THE DATA MATRIX. ! a2(:m,:n) = a(:m,:n) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR gebrd AND orgbr SUBROUTINES. ! lwork = -1 ! call gebrd( m, n, a, m, d, e, tauq, taup, work2, lwork, info=info_bd ) ! lwork_bd = int(work2(1)) ! if ( m>=n ) then ! call orgbr( 'Q', m, n, n, a, m, tauq, work2, lwork, info=info_q ) ! lwork_q = int(work2(1)) ! call orgbr( 'P', n, n, m, pt, n, taup, work2, lwork, info=info_pt ) ! lwork_pt = int(work2(1)) ! else ! call orgbr( 'Q', m, m, n, q, m, tauq, work2, lwork, info=info_q ) ! lwork_q = int(work2(1)) ! call orgbr( 'P', m, n, m, a, m, taup, work2, lwork, info=info_pt ) ! lwork_pt = int(work2(1)) ! end if ! if ( min(info_bd,info_q,info_pt)==0 ) then ! lwork = max( lwork_bd, lwork_q, lwork_pt ) ! ! ALLOCATE OPTIMAL WORK VARIABLE NEEDED BY gebrd AND orgbr SUBROUTINES. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! COMPUTE BIDIAGONAL REDUCTION OF RANDOM DATA MATRIX ! ! a = Q*BD*P**(t) . ! ! WHERE Q AND P ARE ORTHOGONAL MATRICES AND BD IS A REAL BIDIAGONAL MATRIX. ! call gebrd( m, n, a, m, d, e, tauq, taup, work(:lwork_bd), lwork_bd, info=info_bd ) ! ! ON EXIT OF gebrd : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! ! d AND e ARE THE DIAGONAL AND OFF-DIAGONAL ELEMENTS OF THE BIDAGONAL MATRIX BD, RESPECTIVELY. ! a CONTAINS THE ELEMENTARY REFLECTORS WHICH DEFINE Q AND P. ! taup AND tauq ARE THE SCALAR FACTORS OF THE ELEMENTARY REFLECTORS WHICH DEFINE Q AND P, RESPECTIVELY. ! if ( m>=n ) then ! pt(:n,:n) = a(:n,:n) ! call orgbr( 'Q', m, n, n, a, m, tauq, work(:lwork_q), lwork_q, info=info_q ) ! call orgbr( 'P', n, n, m, pt, n, taup, work(:lwork_pt), lwork_pt, info=info_pt ) ! ! ON EXIT OF THESE orgbr CALLS: ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! ! IF m>=n, a IS OVERWRITTEN WITH THE FIRST min(m,n) ! COLUMNS OF Q; ! pt CONTAINS THE n-BY-n ORTHOGONAL MATRIX P**(t). ! else ! q(:m,:m) = a(:m,:m) ! call orgbr( 'Q', m, m, n, q, m, tauq, work(:lwork_q), lwork_q, info=info_q ) ! call orgbr( 'P', m, n, m, a, m, taup, work(:lwork_pt), lwork_pt, info=info_pt ) ! ! ON EXIT OF orgbr CALLS: ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! ! IF m<n, a IS OVERWRITTEN WITH THE FIRST min(m,n) ! ROWS OF P**(t); ! q CONTAINS THE m-BY-m ORTHOGONAL MATRIX Q. ! end if ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart ! if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( min(info_bd,info_q,info_pt)/=0 ) then ! ! ANORMAL EXIT FROM gebrd OR orgbr SUBROUTINES, PRINT A WARNING. ! write (prtunit,*) 'Error in the calls to GEBRD or ORGBR subroutines, Info=', min(info_bd,info_q,info_pt) ! else if ( do_test ) then ! bd(:k,:k) = zero ! if ( m>=n ) then ! ! BD IS UPPER BIDIAGONAL. ! do l = 1_i4b, n-1_i4b bd(l,l) = d(l) bd(l,l+1_i4b) = e(l) end do ! bd(n,n) = d(n) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION Q**(t)*a - BD*P**(t). ! resid(:n,:n) = matmul( transpose(a(:m,:n)), a2(:m,:n) ) & - matmul( bd(:n,:n), pt(:n,:n) ) ! resid2(:n) = norm( resid(:n,:n), dim=2_i4b ) err1 = norm( resid2(:n) )/(norm( a2 )*real(n,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - Q**(t)*Q. ! call unit_matrix( a2(:n,:n) ) ! resid(:n,:n) = abs( a2(:n,:n) - matmul( transpose(a(:m,:n)), a(:m,:n) ) ) err2 = maxval( resid(:n,:n) )/real(m,stnd) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - P**(t)*P. ! resid(:n,:n) = abs( a2(:n,:n) - matmul( pt(:n,:n), transpose(pt(:n,:n)) ) ) err3 = maxval( resid(:n,:n) )/real(n,stnd) ! else ! ! BD IS LOWER BIDIAGONAL. ! do l = 1_i4b, m-1_i4b bd(l,l) = d(l) bd(l+1_i4b,l) = e(l) end do ! bd(m,m) = d(m) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION Q**(t)*a - BD*P**(t), ! resid(:m,:n) = matmul( transpose(q(:m,:m)), a2(:m,:n) ) & - matmul( bd(:m,:m), a(:m,:n) ) ! resid2(:n) = norm( resid(:m,:n), dim=2_i4b ) err1 = maxval( resid2(:n) )/(norm( a2 )*real(m,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - Q**(t)*Q. ! call unit_matrix( a2(:m,:m) ) ! resid(:m,:m) = abs( a2(:m,:m) - matmul( transpose(q(:m,:m )), q(:m,:m ) ) ) err2 = maxval( resid(:m,:m) )/real(m,stnd) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - P**(t)*P. ! resid(:m,:m) = abs( a2(:m,:m) - matmul( a(:m,:n), transpose(a(:m,:n)) ) ) err3 = maxval( resid(:m,:m) )/real(n,stnd) ! endif ! err = max( err1, err2, err3 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( m>=n ) then deallocate( a, pt, d, e, tauq, taup ) else deallocate( a, q, d, e, tauq, taup ) end if ! if ( do_test ) then deallocate( a2, bd, resid, resid2 ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. min(info_bd,info_q,info_pt)==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from gebrd() ) = ', info_bd write (prtunit,*) ' INFO ( from orgbr() ) = ', info_q write (prtunit,*) ' INFO ( from orgbr() ) = ', info_pt ! if ( do_test .and. min(info_bd,info_q,info_pt)==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed bidiagonal decomposition a = Q*BD*P**(t) = ', err1 write (prtunit,*) 'Orthogonality of the computed Q orthogonal matrix = ', err2 write (prtunit,*) 'Orthogonality of the computed P orthogonal matrix = ', err3 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing the bidiagonal reduction of a ', & m, ' by ', n,' real matrix is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex1_lapack_gebrd ! =============================== ! end program ex1_lapack_gebrd
ex1_lapack_gels.F90¶
program ex1_lapack_gels ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutine GELS in LAPACK software ! for computing solution of a full rank linear least squares real problem using a QR/QL ! decomposition of the coefficient matrix. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : gels ! use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, m AND n ARE THE DIMENSIONS OF THE GENERATED MATRIX, ! nrhs IS THE NUMBER OF RIGHT HAND SIDES OF THE LINEAR LEAST SQUARE PROBLEM. ! integer, parameter :: prtunit = 6, m=2000, n=1000, p=min(m,n), k=max(m,n), nrhs=400 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 1 of gels' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, eps, elapsed_time, work2(1) real(stnd), allocatable :: work(:), a(:,:), a2(:,:), b(:,:), b2(:,:), res(:,:) ! integer :: info, lwork, iok, istart, iend, irate, imax, itime, mrhs ! logical(lgl) :: do_test ! character :: trans ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : FULL RANK REAL LINEAR LEAST SQUARES PROBLEM AND SEVERAL RIGHT HAND-SIDES ! USING THE QR OR QL DECOMPOSITION OF THE COEFFICENT MATRIX. IT IS ! ASSUMED THAT THE COEFFICENT MATRIX IS OF FULL RANK. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! If trans='N' THE LINEAR SYSTEM INVOLVES a AND If trans='T' THE LINEAR ! SYSTEM INVOLVES a**(t). IN BOTH CASES, THE RANK OF a IS ASSUMED TO BE ! min(m,n) . ! trans = 'N' ! mrhs = merge( m, n, trans=='N' ) ! ! ALLOCATE WORK ARRAYS. ! allocate( a(m,n), b(k,nrhs), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A m-by-n REAL RANDOM COEFFICIENT MATRIX a . ! call random_number( a(:m,:n) ) ! ! GENERATE A m-by-nrhs (trans='N') OR n-by-nrhs (trans='T') ! REAL RANDOM RIGHT HAND-SIDE MATRIX b . ! call random_number( b(:mrhs,:nrhs) ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(m,n), b2(mrhs,nrhs), res(mrhs,nrhs), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SAVE DATA MATRIX. ! a2(:m,:n) = a(:m,:n) ! ! SAVE RIGHT HAND SIDE MATRIX. ! b2(:mrhs,:nrhs) = b(:mrhs,:nrhs) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR gels SUBROUTINE. ! lwork = -1 ! call gels( trans, m, n, nrhs, a, m, b, k, work2, lwork, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) ! ! ALLOCATE WORK VARIABLE NEEDED BY gels SUBROUTINE. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! COMPUTE MINIMAL NORM SOLUTION TO THE LINEAR LEAST SQUARES PROBLEM . ! call gels( trans, m, n, nrhs, a, m, b, k, work, lwork, info ) ! ! THE ROUTINE RETURNS THE MINIMUM NORM SOLUTION OF THE LINEAR ! LEAST SQUARE PROBLEM. HOWEVER, THE COEFFICIENT MATRIX a IS ! ASSUMED OF FULL RANK. ! ! ON EXIT OF gels : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT the iTH ARGUMENT HAS AN ILLEGAL VALUE ! info=i > 0 : INDICATES THAT the iTH DIAGONAL ELEMENT OF THE TRIANGULAR ! FACTOR OF a IS ZERO AND a DOES NOT HAVE FULL RANK. ! ! ON EXIT OF gels : ! ! a IS OVERWRITTEN BY DETAILS OF ITS QR (m>=n) OR LQ (m<n) FACTORIZATIONS. ! ! b IS OVERWRITTEN BY THE n-by-nrhs (trans='N') OR ! m-by-nrhs (trans='T') SOLUTION. ! ! If m >= n AND trans='N', THE RESIDUAL SUM-OF-SQUARES ! FOR THE SOLUTION IN THE i-th COLUMN IS GIVEN BY THE ! SUM OF SQUARES OF ELEMENTS n+1:m IN THAT COLUMN. ! ! If m < n AND trans='T', THE RESIDUAL SUM-OF-SQUARES ! FOR THE SOLUTION IN THE i-th COLUMN IS GIVEN BY THE ! SUM OF SQUARES OF ELEMENTS m+1:n IN THAT COLUMN. ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM gels SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to GELS subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test ) then ! ! CHECK THAT THE RESIDUALS ARE ORTHOGONAL TO THE COLUMN (trans='N') ! OR ROW (trans='T') VECTORS OF a . ! if ( trans=='N' ) then res = b2 - matmul( a2, b(:n,:nrhs) ) err = maxval( sum(abs(matmul(transpose(a2),res)), dim=1) )/ sum( abs(a2) ) else res = b2 - matmul( transpose(a2), b(:m,:nrhs) ) err = maxval( sum(abs(matmul(a2,res)), dim=1) )/ sum( abs(a2) ) end if ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, b, a2, b2, res ) else deallocate( a, b ) end if ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from gels() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) & 'Orthogonality of the residuals against the columns/rows of the coefficient matrix = ', err end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing the solution of a linear least squares real problem of size ', & m, ' by ', n, ' with ', nrhs,' right hand sides is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex1_lapack_gels ! ============================== ! end program ex1_lapack_gels
ex1_lapack_gelsd.F90¶
program ex1_lapack_gelsd ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutine GELSD in LAPACK software ! for computing solution of a linear least squares real problem using a SVD decomposition ! of the coefficient matrix. The SVD is computed with the divide and conquer method. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : gelsd ! use Statpack, only : lgl, stnd, true, false, zero, c50, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, m AND n ARE THE DIMENSIONS OF THE GENERATED MATRIX, ! nrhs IS THE NUMBER OF RIGHT HAND SIDES OF THE LINEAR LEAST SQUARE PROBLEM. ! integer, parameter :: prtunit = 6, m=4000, n=2000, p=min(m,n), k=max(m,n), nrhs=400 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 1 of gelsd' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, eps, rcond, elapsed_time, work2(1) real(stnd) :: s(p) real(stnd), allocatable :: work(:), a(:,:), a2(:,:), b(:,:), b2(:,:), res(:,:) ! integer :: info, lwork, liwork, rank, iok, iwork2(1), & istart, iend, irate, imax, itime integer, allocatable :: iwork(:) ! logical(lgl) :: do_test ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : MINIMUM-NORM SOLUTION OF A REAL LINEAR LEAST SQUARES PROBLEM ! WITH SEVERAL RIGHT HAND-SIDES USING A SVD DECOMPOSITION OF THE ! COEFFICIENT MATRIX. THE SVD IS COMPUTED WITH THE DIVIDE AND CONQUER ! METHOD. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! THE EFFECTIVE RANK OF THE COEFFICIENT MATRIX OF THE LINEAR LEAST SQUARE PROBLEM, rank, ! IS DETERMINED BY TREATING AS ZERO THOSE SINGULAR VALUES WHICH ARE LESS THAN rcond TIMES ! THE LARGEST SINGULAR VALUE. ! rcond = 0.0000001_stnd ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a(m,n), b(k,nrhs), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A m-by-n REAL RANDOM COEFFICIENT MATRIX a . ! call random_number( a(:m,:n) ) ! ! GENERATE A m-by-nrhs REAL RANDOM RIGHT HAND-SIDE MATRIX b . ! call random_number( b(:m,:nrhs) ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(m,n), b2(m,nrhs), res(m,nrhs), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SAVE DATA MATRIX . ! a2(:m,:n) = a(:m,:n) ! ! SAVE RIGHT HAND SIDE MATRIX . ! b2(:m,:nrhs) = b(:m,:nrhs) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR gelsd SUBROUTINE. ! lwork = -1 ! call gelsd( m, n, nrhs, a, m, b, k, s, rcond, rank, work2, lwork, iwork2, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) + 10 liwork = iwork2(1) ! ! ALLOCATE WORK VARIABLES NEEDED BY gelsd SUBROUTINE. ! allocate( work(lwork), iwork(liwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! COMPUTE MINIMAL NORM SOLUTION TO THE LINEAR LEAST SQUARES PROBLEM . ! call gelsd( m, n, nrhs, a, m, b, k, s, rcond, rank, work, lwork, iwork, info ) ! ! THE ROUTINE RETURNS THE SOLUTION AND SINGULAR VALUES OF THE LINEAR ! LEAST SQUARE PROBLEM. ! ! ON EXIT OF gelsd : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT the iTH ARGUMENT HAS AN ILLEGAL VALUE ! info=i > 0 : INDICATES THAT the SVD ALGORITHM FAILED TO CONVERGE. ! AND i SUBDIAGONAL ELEMENTS OF AN INTERMEDIATE ! BIDIAGONAL MATRIX DID NOT CONVERGE TO ZERO. ! ! ON EXIT OF gelsd : ! ! a IS DESTROYED. ! ! b IS OVERWRITTEN BY THE n-by-nrhs SOLUTION. ! If m >= n AND rank = n, THE RESIDUAL SUM-OF-SQUARES ! FOR THE SOLUTION IN THE i-th COLUMN IS GIVEN BY THE ! SUM OF SQUARES OF ELEMENTS n+1:m IN THAT COLUMN. ! ! s IS OVERWRITTEN WITH THE SINGULAR VALUES OF a ! IN DECREASING ORDER. ! ! rank IS OVERWRITTEN BY THE EFFECTIVE RANK OF a, i.e. ! THE NUMBER OF SINGULAR VALUES WHICH ARE GREATER ! THAN rcond*s(1) . ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( work, iwork ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM gelsd SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to GELSD subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test ) then ! ! CHECK THAT THE RESIDUALS ARE ORTHOGONAL TO THE COLUMN VECTORS OF a . ! res = b2 - matmul( a2, b(:n,:nrhs) ) err = maxval( sum(abs(matmul(transpose(a2),res)), dim=1) )/ sum( abs(a2) ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, b, a2, b2, res ) else deallocate( a, b ) end if ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from gelsd() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) & 'Orthogonality of the residuals against the columns of the coefficient matrix = ', err end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing the solution of a linear least squares real problem of size ', & m, ' by ', n, ' with ', nrhs,' right hand sides is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex1_lapack_gelsd ! =============================== ! end program ex1_lapack_gelsd
ex1_lapack_gelss.F90¶
program ex1_lapack_gelss ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutine GELSS in LAPACK software ! for computing solution of a linear least squares real problem using a SVD decomposition ! of the coefficient matrix. The SVD is computed with the Golub and Reinsch bidiagonal QR method. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : gelss ! use Statpack, only : lgl, stnd, true, false, zero, c50, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, m AND n ARE THE DIMENSIONS OF THE GENERATED MATRIX, ! nrhs IS THE NUMBER OF RIGHT HAND SIDES OF THE LINEAR LEAST SQUARE PROBLEM. ! integer, parameter :: prtunit = 6, m=4000, n=2000, p=min(m,n), k=max(m,n), nrhs=400 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 1 of gelss' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, eps, rcond, elapsed_time, work2(1) real(stnd) :: s(p) real(stnd), allocatable :: work(:), a(:,:), a2(:,:), b(:,:), b2(:,:), res(:,:) ! integer :: info, lwork, rank, iok, istart, iend, irate, imax, itime ! logical(lgl) :: do_test ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : MINIMUM-NORM SOLUTION OF A REAL LINEAR LEAST SQUARES PROBLEM ! WITH SEVERAL RIGHT HAND-SIDES USING A SVD DECOMPOSITION OF THE ! COEFFICIENT MATRIX. THE SVD IS COMPUTED WITH THE GOLUB-REINSCH ! METHOD. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! THE EFFECTIVE RANK OF THE COEFFICIENT MATRIX OF THE LINEAR LEAST SQUARE PROBLEM, rank, ! IS DETERMINED BY TREATING AS ZERO THOSE SINGULAR VALUES WHICH ARE LESS THAN rcond TIMES ! THE LARGEST SINGULAR VALUE. ! rcond = 0.0000001_stnd ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a(m,n), b(k,nrhs), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A m-by-n REAL RANDOM COEFFICIENT MATRIX a . ! call random_number( a(:m,:n) ) ! ! GENERATE A m-by-nrhs REAL RANDOM RIGHT HAND-SIDE MATRIX b . ! call random_number( b(:m,:nrhs) ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(m,n), b2(m,nrhs), res(m,nrhs), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SAVE DATA MATRIX . ! a2(:m,:n) = a(:m,:n) ! ! SAVE RIGHT HAND SIDE MATRIX . ! b2(:m,:nrhs) = b(:m,:nrhs) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR gelss SUBROUTINE. ! lwork = -1 ! call gelss( m, n, nrhs, a, m, b, k, s, rcond, rank, work2, lwork, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) + 10 ! ! ALLOCATE WORK VARIABLE NEEDED BY gelss SUBROUTINE. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! COMPUTE MINIMAL NORM SOLUTION TO THE LINEAR LEAST SQUARES PROBLEM . ! call gelss( m, n, nrhs, a, m, b, k, s, rcond, rank, work, lwork, info ) ! ! THE ROUTINE RETURNS THE SOLUTIONS AND SINGULAR VALUES OF THE LINEAR ! LEAST SQUARE PROBLEM. ! ! ON EXIT OF gelss : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT the iTH ARGUMENT HAS AN ILLEGAL VALUE ! info=i > 0 : INDICATES THAT the SVD ALGORITHM FAILED TO CONVERGE ! AND i SUBDIAGONAL ELEMENTS OF AN INTERMEDIATE ! BIDIAGONAL MATRIX DID NOT CONVERGE TO ZERO. ! ! ON EXIT OF gelss : ! ! a IS OVERWRITTEN BY THE FIRST min(n,m) RIGHT SINGULAR ! VECTORS OF a STORED ROW-WISE (e.g. IN THE FIRST min(n,m) ! ROWS OF a). ! ! b IS OVERWRITTEN BY THE n-by-nrhs SOLUTION. ! If m >= n AND rank = n, THE RESIDUAL SUM-OF-SQUARES ! FOR THE SOLUTION IN THE i-th COLUMN IS GIVEN BY THE ! SUM OF SQUARES OF ELEMENTS n+1:m IN THAT COLUMN. ! ! s IS OVERWRITTEN WITH THE SINGULAR VALUES OF a ! IN DECREASING ORDER. ! ! rank IS OVERWRITTEN BY THE EFFECTIVE RANK OF a, i.e. ! THE NUMBER OF SINGULAR VALUES WHICH ARE GREATER ! THAN rcond*s(1) . ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM gelss SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to GELSS subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test ) then ! ! CHECK THAT THE RESIDUALS ARE ORTHOGONAL TO THE COLUMN VECTORS OF a . ! res = b2 - matmul( a2, b(:n,:nrhs) ) err = maxval( sum(abs(matmul(transpose(a2),res)), dim=1) )/ sum( abs(a2) ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, b, a2, b2, res ) else deallocate( a, b ) end if ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from gelss() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) & 'Orthogonality of the residuals against the columns of the coefficient matrix = ', err end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing the solution of a linear least squares real problem of size ', & m, ' by ', n, ' with ', nrhs,' right hand sides is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex1_lapack_gelss ! =============================== ! end program ex1_lapack_gelss
ex1_lapack_gelsy.F90¶
program ex1_lapack_gelsy ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutine GELSY in LAPACK software ! for computing solution of a linear least squares real problem using a complete orthogonal ! factorization of the coefficient matrix. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : gelsy ! use Statpack, only : lgl, stnd, true, false, zero, c50, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, m AND n ARE THE DIMENSIONS OF THE GENERATED MATRIX, ! nrhs IS THE NUMBER OF RIGHT HAND SIDES OF THE LINEAR LEAST SQUARES PROBLEM. ! integer, parameter :: prtunit = 6, m=10000, n=4000, p=min(m,n), k=max(m,n), nrhs=1 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 1 of gelsy' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, eps, rcond, elapsed_time, work2(1) real(stnd), allocatable :: work(:), a(:,:), a2(:,:), b(:,:), b2(:,:), res(:,:) ! integer, allocatable :: jpvt(:) integer :: info, lwork, rank, iok, istart, iend, irate, imax, itime ! logical(lgl) :: do_test ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : MINIMUM-NORM SOLUTION OF A REAL LINEAR LEAST SQUARES PROBLEM ! WITH SEVERAL RIGHT HAND-SIDES USING A COMPLETE ORTHOGONAL ! FACTORIZATION OF THE COEFFICIENT MATRIX. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! rcond IS USED TO DETERMINE THE EFFECTIVE RANK OF THE COEFFICIENT MATRIX, ! WHICH IS DEFINED AS THE ORDER OF THE LARGEST LEADING TRIANGULAR SUBMATRIX ! R11 IN THE QR FACTORIZATION WITH PIVOTING OF THE COEFFICIENT MATRIX, WHOSE ! ESTIMATED CONDITION NUMBER IS LESS THAN 1/rcond . ! rcond = 0.0000001_stnd ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a(m,n), b(k,nrhs), jpvt(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A m-by-n REAL RANDOM COEFFICIENT MATRIX a . ! call random_number( a(:m,:n) ) ! ! GENERATE A m-by-nrhs REAL RANDOM RIGHT HAND-SIDE MATRIX b . ! call random_number( b(:m,:nrhs) ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(m,n), b2(m,nrhs), res(m,nrhs), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SAVE DATA MATRIX . ! a2(:m,:n) = a(:m,:n) ! ! SAVE RIGHT HAND SIDE MATRIX . ! b2(:m,:nrhs) = b(:m,:nrhs) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! INITIALIZE PERMUTATION VECTOR FOR COMPLETE PIVOTING OF THE ! COLUMNS OF a . ! jpvt(:n) = 0 ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR gelsy SUBROUTINE. ! lwork = -1 ! call gelsy( m, n, nrhs, a, m, b, k, jpvt, rcond, rank, work2, lwork, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) ! ! ALLOCATE WORK VARIABLE NEEDED BY gelsy SUBROUTINE. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! COMPUTE MINIMUM-NORM SOLUTION TO THE LINEAR LEAST SQUARES PROBLEM . ! call gelsy( m, n, nrhs, a, m, b, k, jpvt, rcond, rank, work, lwork, info ) ! ! THE ROUTINE RETURNS THE SOLUTION OF THE LINEAR ! LEAST SQUARE PROBLEM. ! ! ON EXIT OF gelsy : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT the iTH ARGUMENT HAS AN ILLEGAL VALUE ! ! ON EXIT OF gelsy IF info = 0 : ! ! a IS OVERWRITTEN BY DETAILS OF ITS COMPLETE ORTHOGONAL ! FACTORIZATION. ! ! b IS OVERWRITTEN BY THE n-by-nrhs MINIMUM-NORM SOLUTION. ! ! rank IS OVERWRITTEN BY THE EFFECTIVE RANK OF a. ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM gelsy SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to GELSY subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test ) then ! ! CHECK THAT THE RESIDUALS ARE ORTHOGONAL TO THE COLUMN VECTORS OF a . ! res = b2 - matmul( a2, b(:n,:nrhs) ) err = maxval( sum(abs(matmul(transpose(a2),res)), dim=1) )/ sum( abs(a2) ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, b, jpvt, a2, b2, res ) else deallocate( a, b, jpvt ) end if ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from gelsy() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) & 'Orthogonality of the residuals against the columns of the coefficient matrix = ', err end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing the solution of a linear least squares real problem of size ', & m, ' by ', n, ' with ', nrhs,' right hand sides is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex1_lapack_gelsy ! =============================== ! end program ex1_lapack_gelsy
ex1_lapack_gesdd.F90¶
program ex1_lapack_gesdd ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of the driver subroutine GESDD ! in LAPACK software for computing a full SVD decomposition of a real matrix by ! the divide and conquer method. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : gesdd ! use Statpack, only : lgl, i4b, stnd, true, false, zero, zero, one, seven, c30, c50, c1_e6, & norm, unit_matrix, random_seed_, random_number_, gen_random_mat, & singval_sort, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! #ifdef _F2003 use ieee_arithmetic, only : ieee_support_datatype, ieee_is_normal #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, m AND n ARE THE DIMENSIONS OF THE GENERATED MATRIX, ! nsvd0 IS THE NUMERICAL RANK OF THE GENERATED MATRIX (WHICH MUST BE LESS OR EQUAL TO k) ! FOR CASES GREATER THAN 0. ! integer(i4b), parameter :: prtunit = 6, m=3000, n=3000, k=min(m,n), nsvd0=3000 ! ! conda IS THE CONDITION NUMBER OF THE GENERATED MATRIX IN CASES 5, 6 and 7, ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50, conda=c1_e6 ! character(len=*), parameter :: name_proc='Example 1 of gesdd' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, err1, err2, err3, eps, tmp, tmp2, & abs_err, rel_err, anorm, elapsed_time real(stnd) :: work2(1) real(stnd), allocatable, dimension(:) :: s, s0, work real(stnd), allocatable, dimension(:,:) :: a, a2, c, resid ! integer :: info, lwork, iok, istart, iend, irate, imax, itime integer, allocatable, dimension(:) :: iwork integer(i4b) :: i, mat_type ! logical(lgl) :: do_test ! character :: jobz ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : FULL SVD OF A REAL MATRIX USING THE DIVIDE AND CONQUER METHOD. ! ! SPECIFY THE TYPE OF INPUT MATRIX: ! ! mat_type < 1 -> RANDOM MATRIX FROM THE UNIFORM DISTRIBUTION ! mat_type = 1 -> SLOW DECAY OF SINGULAR VALUES ! mat_type = 2 -> FAST DECAY OF SINGULAR VALUES ! mat_type = 3 -> S-SHAPED DECAY OF SINGULAR VALUES ! mat_type = 4 -> VERY SLOW DECAY OF SINGULAR VALUES ! mat_type = 5 -> STRONGLY CLUSTERED SINGULAR VALUES AT 1 WITH CONDITION NUMBER conda ! SPECTRUM WITH FEW DEFLATIONS FOR LAPACK GESDD ROUTINE ! mat_type = 6 -> GEOMETRIC DISTRIBUTION OF SINGULAR VALUES WITH CONDITION NUMBER conda ! SPECTRUM WITH MODERATE DEFLATION FOR LAPACK GESDD ROUTINE ! mat_type = 7 -> ARITHMETIC DISTRIBUTION OF SINGULAR VALUES WITH CONDITION NUMBER conda ! SPECTRUM WITH COMPLETE DEFLATION FOR LAPACK GESDD ROUTINE ! mat_type > 7 -> UNIFORM DISTRIBUTION OF SINGULAR VALUES ! mat_type = 0_i4b ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! SELECT THE UNIFORM RANDOM GENERATOR TO BE USED. ! call random_seed_( alg=3 ) ! ! RESET THE SEEDS USED BY THE UNIFORM RANDOM GENERATOR. ! call random_seed_() ! ! ALLOCATE WORK ARRAYS. ! allocate( a(m,n), c(k,k), s(k), iwork(8*k), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A RANDOM UNIFORM MATRIX OR SINGULAR VALUES. ! select case( mat_type ) ! case( :0_i4b ) ! ! RANDOM UNIFORM MATRIX. ! call random_number_( a ) ! ! COMPUTE THE FROBENIUS NORM OF THE RANDOM MATRIX. ! anorm = norm( a ) ! case( 1_i4b ) ! ! SLOW DECAY OF SINGULAR VALUES. ! do i = 1_i4b, nsvd0 ! tmp = real( i, stnd ) ! s(i) = one/( tmp*tmp ) ! end do ! case( 2_i4b ) ! ! FAST DECAY OF SINGULAR VALUES. ! do i = 1_i4b, nsvd0 ! tmp = real( i, stnd ) ! s(i) = exp( -tmp/seven ) ! end do ! case( 3_i4b ) ! ! S-SHAPED DECAY OF SINGULAR VALUES. ! do i = 1_i4b, nsvd0 ! tmp = real( i, stnd ) ! s(i) = 0.0001_stnd + one/( one + exp( tmp - c30 ) ) ! end do ! case( 4_i4b ) ! ! VERY SLOW DECAY OF SINGULAR VALUES. ! tmp = real( nsvd0 - 1_i4b, stnd ) ! do i = 1_i4b, nsvd0 ! tmp2 = real( i - 1_i4b, stnd ) ! s(i) = exp( -tmp2/tmp ) ! end do ! case( 5_i4b ) ! ! STRONGLY CLUSTERED SINGULAR VALUES AT 1 WITH CONDITION NUMBER conda. ! THIS IS A SPECTRUM WITH FEW DEFLATIONS FOR LAPACK GESDD ROUTINE. ! s(:nsvd0-1_i4b) = one s(nsvd0) = one/conda ! case( 6_i4b ) ! ! GEOMETRIC DISTRIBUTION OF SINGULAR VALUES WITH CONDITION NUMBER conda. ! THIS IS A SPECTRUM WITH MODERATE DEFLATION FOR LAPACK GESDD ROUTINE. ! tmp = real( nsvd0 - 1_i4b, stnd ) ! do i = 1_i4b, nsvd0 ! tmp2 = real( i - 1_i4b, stnd ) ! s(i) = conda**( -tmp2/tmp ) ! end do ! case( 7_i4b ) ! ! ARITHMETIC DISTRIBUTION OF SINGULAR VALUES WITH CONDITION NUMBER conda. ! THIS IS A SPECTRUM WITH COMPLETE DEFLATION FOR LAPACK GESDD ROUTINE. ! tmp = real( nsvd0 - 1_i4b, stnd ) tmp2 = one - one/conda ! do i = 1_i4b, nsvd0 ! s(i) = one - (real( i - 1_i4b, stnd )/tmp)*tmp2 ! end do ! case default ! ! UNIFORM DISTRIBUTION OF SINGULAR VALUES. ! call random_number_( s(:nsvd0) ) ! end select ! if ( mat_type>0_i4b ) then ! #ifdef _F2003 if ( ieee_support_datatype( s ) ) then ! if ( .not.all( ieee_is_normal( s(:nsvd0) ) ) ) then ! call merror( name_proc//' : Exceptions occurred when generating the input matrix !' ) ! end if ! end if #endif ! ! SORT THE SINGULAR VALUES BY DECREASING MAGNITUDE. ! call singval_sort( 'D', s(:nsvd0) ) ! ! GENERATE A m-BY-n RANDOM REAL MATRIX a WITH A SPECIFIED DISTRIBUTION ! OF SINGULAR VALUES AND A RANK EQUAL TO nsvd0. ! call gen_random_mat( s(:nsvd0), a ) ! ! COMPUTE THE FROBENIUS NORM OF THE MATRIX. ! anorm = norm( s(:nsvd0) ) ! end if ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(m,n), resid(m,k), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! MAKE A COPY OF THE RANDOM DATA MATRIX . ! a2(:m,:n) = a(:m,:n) ! if ( mat_type>0_i4b ) then ! ! ALLOCATE WORK ARRAY. ! allocate( s0(k), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SAVE THE TRUE SINGULAR VALUES. ! s0(:nsvd0) = s(:nsvd0) s0(nsvd0+1_i4b:k) = zero ! end if ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! DETERMINE THE WORK TO DO AND HOW THE SINGULAR VECTORS WILL BE STORED. ! WITH THE ARGUMENTS BELOW, THE SINGULAR VECTORS ARE COMPUTED AND ! STORED AS IN SUBROUTINE svd_cmp2 IN STATPACK. ! jobz = 'O' ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR gesdd SUBROUTINE. ! lwork = -1 ! call gesdd( jobz, m, n, a, m, s, c, k, c, k, work2, lwork, iwork, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) + 10 ! ! ALLOCATE WORK VARIABLE NEEDED BY gesdd SUBROUTINE. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! gesdd COMPUTES THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL ! m-BY-n MATRIX a. THE SVD IS WRITTEN ! ! a = U * S * V**(t) ! ! WHERE S IS AN m-BY-n MATRIX WHICH IS ZERO EXCEPT FOR ITS ! min(m,n) DIAGONAL ELEMENTS, U IS AN m-BY-m ORTHOGONAL MATRIX, AND ! V IS AN n-BY-n ORTHOGONAL MATRIX. THE DIAGONAL ELEMENTS OF S ! ARE THE SINGULAR VALUES OF a; THEY ARE REAL AND NON-NEGATIVE. ! THE COLUMNS OF U AND V ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a. ! call gesdd( jobz, m, n, a, m, s, c, k, c, k, work, lwork, iwork, info ) ! ! THE ROUTINE RETURNS THE SINGULAR VALUES, THE LEFT AND RIGHT ! SINGULAR VECTORS. THE RIGHT SINGULAR VECTORS ARE RETURNED ROWWISE. ! ! ON EXIT OF gesdd : ! ! info= 0 : INDICATES SUCCESSFUL EXIT. ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE. ! info=i > 0 : INDICATES THAT THE ALGORITHM FAILED TO CONVERGE. ! ! ON EXIT OF gesdd IF JOBZ='O': ! ! IF m>=n, a IS OVERWRITTEN WITH THE FIRST min(m,n) ! COLUMNS OF U (THE LEFT SINGULAR VECTORS, ! STORED COLUMNWISE); ! c CONTAINS THE n-BY-n ORTHOGONAL MATRIX V**(t). ! ! IF m<n, a IS OVERWRITTEN WITH THE FIRST min(m,n) ! ROWS OF V**(t) (THE RIGHT SINGULAR VECTORS, ! STORED ROWWISE); ! c CONTAINS THE m-BY-m ORTHOGONAL MATRIX U. ! ! s IS OVERWRITTEN WITH THE SINGULAR VALUES OF a IN DECREASING ORDER. ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM gesdd SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to GESDD subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test ) then ! if ( mat_type>0_i4b ) then ! ! COMPUTE ERRORS FOR SINGULAR VALUES. ! where( s0(:k)/=zero ) resid(:k,1_i4b) = s0(:k) elsewhere resid(:k,1_i4b) = one end where ! ! ABSOLUTE ERRORS OF SINGULAR VALUES. ! abs_err = maxval( abs( s(:k) - s0(:k) ) ) ! ! RELATIVE ERRORS OF SINGULAR VALUES. ! rel_err = maxval( abs( (s(:k) - s0(:k))/resid(:k,1_i4b) ) ) ! end if ! if ( m>=n ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a(:m,:n)*V(:n,:k) - U(:m,:k)*S(:k,:k). ! resid(:m,:k) = matmul(a2(:m,:k),transpose(c(:k,:k))) - a(:m,:k)*spread(s,dim=1,ncopies=m) a2(:k,1_i4b) = norm( resid(:m,:k), dim=2_i4b ) err1 = maxval( a2(:k,1_i4b) )/( anorm*real(m,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U. ! call unit_matrix( a2(:n,:n) ) ! resid(:n,:n) = abs( a2(:n,:n) - matmul( transpose(a(:m,:n)), a(:m,:n) ) ) err2 = maxval( resid(:n,:n) )/real(m,stnd) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - V**(t)*V. ! resid(:n,:n) = abs( a2(:n,:n) - matmul( c(:n,:n), transpose(c(:n,:n)) ) ) err3 = maxval( resid(:n,:n) )/real(n,stnd) ! else ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a(:m,:n)*V(:n,:k) - U(:m,:k)*S(:k,:k). ! resid(:m,:k) = matmul(a2(:m,:n),transpose(a(:k,:n))) - c(:k,:k)*spread(s,dim=1,ncopies=k) a2(:k,1_i4b) = norm( resid(:m,:k), dim=2_i4b ) err1 = maxval( a2(:k,1_i4b) )/( anorm*real(m,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U. ! call unit_matrix( a2(:m,:m) ) ! resid(:m,:m) = abs( a2(:m,:m) - matmul( transpose(c(:m,:m )), c(:m,:m ) ) ) err2 = maxval( resid(:m,:m) )/real(m,stnd) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - V**(t)*V. ! resid(:m,:m) = abs( a2(:m,:m) - matmul( a(:m,:n), transpose(a(:m,:n)) ) ) err3 = maxval( resid(:m,:m) )/real(n,stnd) ! end if ! err = max( err1, err2, err3 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then ! if ( mat_type>0_i4b ) then deallocate( a, c, s, s0, iwork, a2, resid ) else deallocate( a, c, s, iwork, a2, resid ) end if ! else ! deallocate( a, c, s, iwork ) ! end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' Matrix type = ', mat_type ! write (prtunit,*) write (prtunit,*) ' Matrix_type < 1 -> random matrix from the uniform distribution' write (prtunit,*) ' Matrix type = 1 -> slow decay of singular values' write (prtunit,*) ' Matrix type = 2 -> fast decay of singular values' write (prtunit,*) ' Matrix type = 3 -> s-shaped decay of singular values' write (prtunit,*) ' Matrix type = 4 -> very slow decay of singular values' write (prtunit,*) ' Matrix type = 5 -> strongly clustered singular values at 1' write (prtunit,*) ' spectrum with few deflations (for LAPACK GESDD routine)' write (prtunit,*) ' Matrix type = 6 -> geometric distribution of singular values' write (prtunit,*) ' spectrum with moderate deflation (for LAPACK GESDD routine)' write (prtunit,*) ' Matrix type = 7 -> arithmetic distribution of singular values' write (prtunit,*) ' spectrum with complete deflation (for LAPACK GESDD routine)' write (prtunit,*) ' Matrix type > 7 -> uniform distribution of singular values' ! write (prtunit,*) write (prtunit,*) ' INFO ( from gesdd() ) = ', info ! if ( do_test .and. info==0 ) then ! write (prtunit,*) ! if ( mat_type>0_i4b ) then ! write (prtunit,*) 'Absolute accuracy of the computed singular values = ', abs_err write (prtunit,*) 'Relative accuracy of the computed singular values = ', rel_err ! end if ! write (prtunit,*) 'Accuracy of the computed singular triplets = ', err1 write (prtunit,*) 'Orthogonality of the computed left singular vectors = ', err2 write (prtunit,*) 'Orthogonality of the computed right singular vectors = ', err3 ! end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing all singular values and vectors of a ', & m, ' by ', n,' real matrix is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex1_lapack_gesdd ! =============================== ! end program ex1_lapack_gesdd
ex1_lapack_gesv.F90¶
program ex1_lapack_gesv ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of the driver subroutine GESV ! in LAPACK software for solving a real linear system with the help of a LU decomposition ! with partial pivoting. ! ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : gesv ! use Statpack, only : lgl, i4b, stnd, true, false, zero, c100, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, n IS THE DIMENSION OF THE LINEAR SYSTEM, ! nrhs IS THE NUMBER OF RIGHT HAND SIDES OF THE LINEAR PROBLEM TO BE SOLVED. ! integer, parameter :: prtunit = 6, n=5000, nrhs=300 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c100 ! character(len=*), parameter :: name_proc='Example 1 of gesv' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, eps, elapsed_time real(stnd), dimension(:,:), allocatable :: a, b, x, res ! integer(i4b), dimension(:), allocatable :: ipiv integer :: info, iok, istart, iend, irate, imax, itime ! logical(lgl) :: do_test ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : SOLUTION OF A LINEAR SYSTEM WITH A REAL COEFFICIENT ! MATRIX AND SEVERAL RIGHT HAND-SIDES BY A LU DECOMPOSITION ! WITH PARTIAL PIVOTING. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*real( n, stnd )*epsilon( err ) ! eps = sqrt( epsilon( err ) ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a(n,n), b(n,nrhs), x(n,nrhs), ipiv(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A n-by-n RANDOM DATA MATRIX a . ! call random_number( a ) ! ! GENERATE A n-by-nrhs RANDOM SOLUTION MATRIX x . ! call random_number( x ) ! ! COMPUTE THE MATRIX-MATRIX PRODUCT b = a*x . ! b = matmul( a, x ) ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! COMPUTE THE SOLUTION MATRIX FOR REAL LINEAR SYSTEM ! ! a*x = b . ! ! WHERE a IS A n-BY-n MATRIX AND b IS A n-BY-nrhs MATRIX. ! ! THE LU DECOMPOSITION WITH PARTIAL PIVOTING AND ROW INTERCHANGES ! IS USED TO FACTOR a AS ! ! a = P*L*U ! ! WHERE P IS PERMUTATION MATRIX, L IS UNIT LOWER TRIANGULAR, AND U IS ! UPPER TRIANGULAR. THE FACTORED FORM OF a IS THEN USED TO SOLVE THE ! SYSTEM OF EQUATIONS. ! call gesv( n, nrhs, a, n, ipiv, b, n, info ) ! ! ON EXIT OF gesv : ! ! info = 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT the iTH ARGUMENT HAS AN ILLEGAL VALUE ! info=i > 0 : INDICATES THAT THE SOLUTION CAN NOT BE COMPUTED BECAUSE ! THE MATRIX IS SINGULAR ! ! ON EXIT OF gesv IF info = 0: ! ! a IS OVERWRITTEN BY THE FACTORS L AND U OF ITS FACTORIZATION. ! THE UNIT DIAGONAL ELEMENTS OF L ARE NOT STORED. ! ! ipiv STORES THE PIVOT INDICES THAT DEFINE THE PERMUTATION MATRIX P. ! ROW i OF THE MATRIX WAS INTERCHANGED WITH ROW ipiv(i). ! ! b IS OVERWRITTEN WITH THE SOLUTION MATRIX x. ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM gesv SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to GESV subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test ) then ! ! ALLOCATE WORK ARRAY. ! allocate( res(n,nrhs), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! res(:n,:nrhs) = b(:n,:nrhs) - x(:n,:nrhs) err = maxval( sum( abs(res), dim=1 ) / & sum(abs(x), dim=1 ) ) ! ! DEALLOCATE WORK ARRAY. ! deallocate( res ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! deallocate( a, b, x, ipiv ) ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from gesv() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed solutions = ', err end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing the solutions of a linear real system of size ', & n, ' with ', nrhs,' right hand sides is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex1_lapack_gesv ! ============================== ! end program ex1_lapack_gesv
ex1_lapack_gesvd.F90¶
program ex1_lapack_gesvd ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of the driver subroutine GESVD ! in LAPACK software for computing a full SVD decomposition of a real matrix by ! the Golub and Reinsch bidiagonal QR method. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : gesvd ! use Statpack, only : lgl, i4b, stnd, true, false, zero, zero, one, seven, c30, c50, c1_e6, & norm, unit_matrix, random_seed_, random_number_, gen_random_mat, & singval_sort, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! #ifdef _F2003 use ieee_arithmetic, only : ieee_support_datatype, ieee_is_normal #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, m AND n ARE THE DIMENSIONS OF THE GENERATED MATRIX, ! nsvd0 IS THE NUMERICAL RANK OF THE GENERATED MATRIX (WHICH MUST BE LESS OR EQUAL TO k) ! FOR CASES GREATER THAN 0. ! integer(i4b), parameter :: prtunit = 6, m=3000, n=3000, k=min(m,n), nsvd0=3000 ! ! conda IS THE CONDITION NUMBER OF THE GENERATED MATRIX IN CASES 5, 6 and 7, ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50, conda=c1_e6 ! character(len=*), parameter :: name_proc='Example 1 of gesvd' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, err1, err2, err3, eps, tmp, tmp2, & abs_err, rel_err, anorm, elapsed_time real(stnd) :: work2(1) real(stnd), allocatable, dimension(:) :: s, s0, work real(stnd), allocatable, dimension(:,:) :: a, a2, c, resid ! integer :: info, lwork, iok, istart, iend, irate, imax, itime integer(i4b) :: i, mat_type ! logical(lgl) :: do_test ! character :: jobu, jobvt ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : FULL SVD OF A REAL MATRIX USING THE QR IMPLICIT METHOD. ! ! SPECIFY THE TYPE OF INPUT MATRIX: ! ! mat_type < 1 -> RANDOM MATRIX FROM THE UNIFORM DISTRIBUTION ! mat_type = 1 -> SLOW DECAY OF SINGULAR VALUES ! mat_type = 2 -> FAST DECAY OF SINGULAR VALUES ! mat_type = 3 -> S-SHAPED DECAY OF SINGULAR VALUES ! mat_type = 4 -> VERY SLOW DECAY OF SINGULAR VALUES ! mat_type = 5 -> STRONGLY CLUSTERED SINGULAR VALUES AT 1 WITH CONDITION NUMBER conda ! SPECTRUM WITH FEW DEFLATIONS FOR LAPACK GESDD ROUTINE ! mat_type = 6 -> GEOMETRIC DISTRIBUTION OF SINGULAR VALUES WITH CONDITION NUMBER conda ! SPECTRUM WITH MODERATE DEFLATION FOR LAPACK GESDD ROUTINE ! mat_type = 7 -> ARITHMETIC DISTRIBUTION OF SINGULAR VALUES WITH CONDITION NUMBER conda ! SPECTRUM WITH COMPLETE DEFLATION FOR LAPACK GESDD ROUTINE ! mat_type > 7 -> UNIFORM DISTRIBUTION OF SINGULAR VALUES ! mat_type = 0_i4b ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! SELECT THE UNIFORM RANDOM GENERATOR TO BE USED. ! call random_seed_( alg=3 ) ! ! RESET THE SEEDS USED BY THE UNIFORM RANDOM GENERATOR. ! call random_seed_() ! ! ALLOCATE WORK ARRAYS. ! allocate( a(m,n), c(k,k), s(k), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A RANDOM UNIFORM MATRIX OR SINGULAR VALUES. ! select case( mat_type ) ! case( :0_i4b ) ! ! RANDOM UNIFORM MATRIX. ! call random_number_( a ) ! ! COMPUTE THE FROBENIUS NORM OF THE RANDOM MATRIX. ! anorm = norm( a ) ! case( 1_i4b ) ! ! SLOW DECAY OF SINGULAR VALUES. ! do i = 1_i4b, nsvd0 ! tmp = real( i, stnd ) ! s(i) = one/( tmp*tmp ) ! end do ! case( 2_i4b ) ! ! FAST DECAY OF SINGULAR VALUES. ! do i = 1_i4b, nsvd0 ! tmp = real( i, stnd ) ! s(i) = exp( -tmp/seven ) ! end do ! case( 3_i4b ) ! ! S-SHAPED DECAY OF SINGULAR VALUES. ! do i = 1_i4b, nsvd0 ! tmp = real( i, stnd ) ! s(i) = 0.0001_stnd + one/( one + exp( tmp - c30 ) ) ! end do ! case( 4_i4b ) ! ! VERY SLOW DECAY OF SINGULAR VALUES. ! tmp = real( nsvd0 - 1_i4b, stnd ) ! do i = 1_i4b, nsvd0 ! tmp2 = real( i - 1_i4b, stnd ) ! s(i) = exp( -tmp2/tmp ) ! end do ! case( 5_i4b ) ! ! STRONGLY CLUSTERED SINGULAR VALUES AT 1 WITH CONDITION NUMBER conda. ! THIS IS A SPECTRUM WITH FEW DEFLATIONS FOR LAPACK GESDD ROUTINE. ! s(:nsvd0-1_i4b) = one s(nsvd0) = one/conda ! case( 6_i4b ) ! ! GEOMETRIC DISTRIBUTION OF SINGULAR VALUES WITH CONDITION NUMBER conda. ! THIS IS A SPECTRUM WITH MODERATE DEFLATION FOR LAPACK GESDD ROUTINE. ! tmp = real( nsvd0 - 1_i4b, stnd ) ! do i = 1_i4b, nsvd0 ! tmp2 = real( i - 1_i4b, stnd ) ! s(i) = conda**( -tmp2/tmp ) ! end do ! case( 7_i4b ) ! ! ARITHMETIC DISTRIBUTION OF SINGULAR VALUES WITH CONDITION NUMBER conda. ! THIS IS A SPECTRUM WITH COMPLETE DEFLATION FOR LAPACK GESDD ROUTINE. ! tmp = real( nsvd0 - 1_i4b, stnd ) tmp2 = one - one/conda ! do i = 1_i4b, nsvd0 ! s(i) = one - (real( i - 1_i4b, stnd )/tmp)*tmp2 ! end do ! case default ! ! UNIFORM DISTRIBUTION OF SINGULAR VALUES. ! call random_number_( s(:nsvd0) ) ! end select ! if ( mat_type>0_i4b ) then ! #ifdef _F2003 if ( ieee_support_datatype( s ) ) then ! if ( .not.all( ieee_is_normal( s(:nsvd0) ) ) ) then ! call merror( name_proc//' : Exceptions occurred when generating the input matrix !' ) ! end if ! end if #endif ! ! SORT THE SINGULAR VALUES BY DECREASING MAGNITUDE. ! call singval_sort( 'D', s(:nsvd0) ) ! ! GENERATE A m-BY-n RANDOM REAL MATRIX a WITH A SPECIFIED DISTRIBUTION ! OF SINGULAR VALUES AND A RANK EQUAL TO nsvd0. ! call gen_random_mat( s(:nsvd0), a ) ! ! COMPUTE THE FROBENIUS NORM OF THE MATRIX. ! anorm = norm( s(:nsvd0) ) ! end if ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(m,n), resid(m,k), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! MAKE A COPY OF THE RANDOM DATA MATRIX . ! a2(:m,:n) = a(:m,:n) ! if ( mat_type>0_i4b ) then ! ! ALLOCATE WORK ARRAY. ! allocate( s0(k), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SAVE THE TRUE SINGULAR VALUES. ! s0(:nsvd0) = s(:nsvd0) s0(nsvd0+1_i4b:k) = zero ! end if ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! DETERMINE THE WORK TO DO AND HOW THE SINGULAR VECTORS WILL BE STORED. ! WITH THE ARGUMENTS BELOW, THE SINGULAR VECTORS ARE COMPUTED AND ! STORED AS IN SUBROUTINE svd_cmp2 IN STATPACK. ! if ( m>=n ) then ! jobu = 'O' jobvt = 'S' ! else ! jobu = 'S' jobvt = 'O' ! end if ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR gesvd SUBROUTINE. ! lwork = -1 ! call gesvd( jobu, jobvt, m, n, a, m, s, c, k, c, k, work2, lwork, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) ! ! ALLOCATE OPTIMAL WORK VARIABLE NEEDED BY gesvd SUBROUTINE. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! gesvd COMPUTES THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL ! m-BY-n MATRIX a. THE SVD IS WRITTEN ! ! a = U * S * V**(t) ! ! WHERE S IS AN m-BY-n MATRIX WHICH IS ZERO EXCEPT FOR ITS ! min(m,n) DIAGONAL ELEMENTS, U IS AN m-BY-m ORTHOGONAL MATRIX, AND ! V IS AN n-BY-n ORTHOGONAL MATRIX. THE DIAGONAL ELEMENTS OF S ! ARE THE SINGULAR VALUES OF a; THEY ARE REAL AND NON-NEGATIVE. ! THE COLUMNS OF U AND V ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a. ! call gesvd( jobu, jobvt, m, n, a, m, s, c, k, c, k, work, lwork, info ) ! ! THE ROUTINE RETURNS THE SINGULAR VALUES, THE LEFT AND RIGHT ! SINGULAR VECTORS. THE RIGHT SINGULAR VECTORS ARE RETURNED ROWWISE. ! ! ON EXIT OF gesvd : ! ! info= 0 : INDICATES SUCCESSFUL EXIT. ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE. ! info=i > 0 : INDICATES THAT THE ALGORITHM FAILED TO CONVERGE ! AND i OFF-DIAGONAL ELEMENTS OF AN INTERMEDIATE ! BIDIAGONAL FORM OF a DID NOT CONVERGE TO ZERO. ! ! ON EXIT OF gesvd WITH THE VALUES SPECIFIED FOR jobu AND jobvt: ! ! IF m>=n, a IS OVERWRITTEN WITH THE FIRST min(m,n) ! COLUMNS OF U (THE LEFT SINGULAR VECTORS, ! STORED COLUMNWISE); ! c CONTAINS THE n-BY-n ORTHOGONAL MATRIX V**(t). ! ! IF m<n, a IS OVERWRITTEN WITH THE FIRST min(m,n) ! ROWS OF V**(t) (THE RIGHT SINGULAR VECTORS, ! STORED ROWWISE); ! c CONTAINS THE m-BY-m ORTHOGONAL MATRIX U. ! ! s IS OVERWRITTEN WITH THE SINGULAR VALUES OF a IN DECREASING ORDER. ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM gesvd SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to GESVD subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test ) then ! if ( mat_type>0_i4b ) then ! ! COMPUTE ERRORS FOR SINGULAR VALUES. ! where( s0(:k)/=zero ) resid(:k,1_i4b) = s0(:k) elsewhere resid(:k,1_i4b) = one end where ! ! ABSOLUTE ERRORS OF SINGULAR VALUES. ! abs_err = maxval( abs( s(:k) - s0(:k) ) ) ! ! RELATIVE ERRORS OF SINGULAR VALUES. ! rel_err = maxval( abs( (s(:k) - s0(:k))/resid(:k,1_i4b) ) ) ! end if ! if ( m>=n ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a(:m,:n)*V(:n,:k) - U(:m,:k)*S(:k,:k). ! resid(:m,:k) = matmul(a2(:m,:k),transpose(c(:k,:k))) - a(:m,:k)*spread(s,dim=1,ncopies=m) a2(:k,1_i4b) = norm( resid(:m,:k), dim=2_i4b ) err1 = maxval( a2(:k,1_i4b) )/( anorm*real(m,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U. ! call unit_matrix( a2(:n,:n) ) ! resid(:n,:n) = abs( a2(:n,:n) - matmul( transpose(a(:m,:n)), a(:m,:n) ) ) err2 = maxval( resid(:n,:n) )/real(m,stnd) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - V**(t)*V. ! resid(:n,:n) = abs( a2(:n,:n) - matmul( c(:n,:n), transpose(c(:n,:n)) ) ) err3 = maxval( resid(:n,:n) )/real(n,stnd) ! else ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a(:m,:n)*V(:n,:k) - U(:m,:k)*S(:k,:k). ! resid(:m,:k) = matmul(a2(:m,:n),transpose(a(:k,:n))) - c(:k,:k)*spread(s,dim=1,ncopies=k) a2(:k,1_i4b) = norm( resid(:m,:k), dim=2_i4b ) err1 = maxval( a2(:k,1_i4b) )/( anorm*real(m,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U. ! call unit_matrix( a2(:m,:m) ) ! resid(:m,:m) = abs( a2(:m,:m) - matmul( transpose(c(:m,:m )), c(:m,:m ) ) ) err2 = maxval( resid(:m,:m) )/real(m,stnd) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - V**(t)*V. ! resid(:m,:m) = abs( a2(:m,:m) - matmul( a(:m,:n), transpose(a(:m,:n)) ) ) err3 = maxval( resid(:m,:m) )/real(n,stnd) ! end if ! err = max( err1, err2, err3 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then ! if ( mat_type>0_i4b ) then deallocate( a, c, s, s0, a2, resid ) else deallocate( a, c, s, a2, resid ) end if ! else ! deallocate( a, c, s ) ! end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' Matrix type = ', mat_type ! write (prtunit,*) write (prtunit,*) ' Matrix_type < 1 -> random matrix from the uniform distribution' write (prtunit,*) ' Matrix type = 1 -> slow decay of singular values' write (prtunit,*) ' Matrix type = 2 -> fast decay of singular values' write (prtunit,*) ' Matrix type = 3 -> s-shaped decay of singular values' write (prtunit,*) ' Matrix type = 4 -> very slow decay of singular values' write (prtunit,*) ' Matrix type = 5 -> strongly clustered singular values at 1' write (prtunit,*) ' spectrum with few deflations (for LAPACK GESDD routine)' write (prtunit,*) ' Matrix type = 6 -> geometric distribution of singular values' write (prtunit,*) ' spectrum with moderate deflation (for LAPACK GESDD routine)' write (prtunit,*) ' Matrix type = 7 -> arithmetic distribution of singular values' write (prtunit,*) ' spectrum with complete deflation (for LAPACK GESDD routine)' write (prtunit,*) ' Matrix type > 7 -> uniform distribution of singular values' ! write (prtunit,*) write (prtunit,*) ' INFO ( from gesvd() ) = ', info ! if ( do_test .and. info==0 ) then ! write (prtunit,*) ! if ( mat_type>0_i4b ) then ! write (prtunit,*) 'Absolute accuracy of the computed singular values = ', abs_err write (prtunit,*) 'Relative accuracy of the computed singular values = ', rel_err ! end if ! write (prtunit,*) 'Accuracy of the computed singular triplets = ', err1 write (prtunit,*) 'Orthogonality of the computed left singular vectors = ', err2 write (prtunit,*) 'Orthogonality of the computed right singular vectors = ', err3 ! end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing all singular values and vectors of a ', & m, ' by ', n,' real matrix is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex1_lapack_gesvd ! =============================== ! end program ex1_lapack_gesvd
ex1_lapack_gesvdx.F90¶
program ex1_lapack_gesvdx ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of the driver subroutine GESVDX ! in LAPACK software for computing all or selected singular triplets of a real matrix. ! The singular triplets are computed by the bisection and inverse iteration methods ! applied to an associated eigenvalue problem. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : gesvdx ! use Statpack, only : lgl, i4b, stnd, true, false, zero, zero, one, seven, c30, c50, c1_e6, & norm, unit_matrix, random_seed_, random_number_, gen_random_mat, & singval_sort, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! #ifdef _F2003 use ieee_arithmetic, only : ieee_support_datatype, ieee_is_normal #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, m AND n ARE THE DIMENSIONS OF THE GENERATED MATRIX, ! nsvd0 IS THE NUMERICAL RANK OF THE GENERATED MATRIX (WHICH MUST BE LESS OR EQUAL TO k) FOR CASES GREATER THAN 0, ! nsing IS THE TARGET RANK OF THE APPROXIMATE PARTIAL SVD, WHICH IS SOUGHT. ! integer(i4b), parameter :: prtunit = 6, m=3000, n=3000, k=min(m,n), nsvd0=3000, nsing=3000 ! ! conda IS THE CONDITION NUMBER OF THE GENERATED MATRIX IN CASES 5, 6 and 7, ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50, conda=c1_e6 ! character(len=*), parameter :: name_proc='Example 1 of gesvdx' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, err1, err2, err3, eps, tmp, tmp2, anorm, & abs_err, rel_err, elapsed_time, vl, vu real(stnd) :: work2(1) real(stnd), allocatable, dimension(:) :: s, s0, work real(stnd), allocatable, dimension(:,:) :: a, a2, u, vt ! integer :: info, lwork, il, iu, ns, iok, & istart, iend, irate, imax, itime integer, allocatable, dimension(:) :: iwork integer(i4b) :: i, mat_type ! logical(lgl) :: do_test ! character :: jobu, jobvt, range ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : FULL OR PARTIAL SVD OF A REAL MATRIX USING AN ASSOCIATED EIGENVALUE PROBLEM ! AND THE BISECTION AND INVERSE ITERATION METHODS. ! ! SPECIFY THE TYPE OF INPUT MATRIX: ! ! mat_type < 1 -> RANDOM MATRIX FROM THE UNIFORM DISTRIBUTION ! mat_type = 1 -> SLOW DECAY OF SINGULAR VALUES ! mat_type = 2 -> FAST DECAY OF SINGULAR VALUES ! mat_type = 3 -> S-SHAPED DECAY OF SINGULAR VALUES ! mat_type = 4 -> VERY SLOW DECAY OF SINGULAR VALUES ! mat_type = 5 -> STRONGLY CLUSTERED SINGULAR VALUES AT 1 WITH CONDITION NUMBER conda ! SPECTRUM WITH FEW DEFLATIONS FOR LAPACK GESDD ROUTINE ! mat_type = 6 -> GEOMETRIC DISTRIBUTION OF SINGULAR VALUES WITH CONDITION NUMBER conda ! SPECTRUM WITH MODERATE DEFLATION FOR LAPACK GESDD ROUTINE ! mat_type = 7 -> ARITHMETIC DISTRIBUTION OF SINGULAR VALUES WITH CONDITION NUMBER conda ! SPECTRUM WITH COMPLETE DEFLATION FOR LAPACK GESDD ROUTINE ! mat_type > 7 -> UNIFORM DISTRIBUTION OF SINGULAR VALUES ! mat_type = 0_i4b ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! SELECT THE UNIFORM RANDOM GENERATOR TO BE USED. ! call random_seed_( alg=3 ) ! ! RESET THE SEEDS USED BY THE UNIFORM RANDOM GENERATOR. ! call random_seed_() ! ! ALLOCATE WORK ARRAYS. ! allocate( a(m,n), u(m,k), vt(k,n), s(k), iwork(12*k), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A RANDOM UNIFORM MATRIX OR SINGULAR VALUES. ! select case( mat_type ) ! case( :0_i4b ) ! ! RANDOM UNIFORM MATRIX. ! call random_number_( a ) ! ! COMPUTE THE FROBENIUS NORM OF THE RANDOM MATRIX. ! anorm = norm( a ) ! case( 1_i4b ) ! ! SLOW DECAY OF SINGULAR VALUES. ! do i = 1_i4b, nsvd0 ! tmp = real( i, stnd ) ! s(i) = one/( tmp*tmp ) ! end do ! case( 2_i4b ) ! ! FAST DECAY OF SINGULAR VALUES. ! do i = 1_i4b, nsvd0 ! tmp = real( i, stnd ) ! s(i) = exp( -tmp/seven ) ! end do ! case( 3_i4b ) ! ! S-SHAPED DECAY OF SINGULAR VALUES. ! do i = 1_i4b, nsvd0 ! tmp = real( i, stnd ) ! s(i) = 0.0001_stnd + one/( one + exp( tmp - c30 ) ) ! end do ! case( 4_i4b ) ! ! VERY SLOW DECAY OF SINGULAR VALUES. ! tmp = real( nsvd0 - 1_i4b, stnd ) ! do i = 1_i4b, nsvd0 ! tmp2 = real( i - 1_i4b, stnd ) ! s(i) = exp( -tmp2/tmp ) ! end do ! case( 5_i4b ) ! ! STRONGLY CLUSTERED SINGULAR VALUES AT 1 WITH CONDITION NUMBER conda. ! THIS IS A SPECTRUM WITH FEW DEFLATIONS FOR LAPACK GESDD ROUTINE. ! s(:nsvd0-1_i4b) = one s(nsvd0) = one/conda ! case( 6_i4b ) ! ! GEOMETRIC DISTRIBUTION OF SINGULAR VALUES WITH CONDITION NUMBER conda. ! THIS IS A SPECTRUM WITH MODERATE DEFLATION FOR LAPACK GESDD ROUTINE. ! tmp = real( nsvd0 - 1_i4b, stnd ) ! do i = 1_i4b, nsvd0 ! tmp2 = real( i - 1_i4b, stnd ) ! s(i) = conda**( -tmp2/tmp ) ! end do ! case( 7_i4b ) ! ! ARITHMETIC DISTRIBUTION OF SINGULAR VALUES WITH CONDITION NUMBER conda. ! THIS IS A SPECTRUM WITH COMPLETE DEFLATION FOR LAPACK GESDD ROUTINE. ! tmp = real( nsvd0 - 1_i4b, stnd ) tmp2 = one - one/conda ! do i = 1_i4b, nsvd0 ! s(i) = one - (real( i - 1_i4b, stnd )/tmp)*tmp2 ! end do ! case default ! ! UNIFORM DISTRIBUTION OF SINGULAR VALUES. ! call random_number_( s(:nsvd0) ) ! end select ! if ( mat_type>0_i4b ) then ! #ifdef _F2003 if ( ieee_support_datatype( s ) ) then ! if ( .not.all( ieee_is_normal( s(:nsvd0) ) ) ) then ! call merror( name_proc//' : Exceptions occurred when generating the input matrix !' ) ! end if ! end if #endif ! ! SORT THE SINGULAR VALUES BY DECREASING MAGNITUDE. ! call singval_sort( 'D', s(:nsvd0) ) ! ! GENERATE A m-BY-n RANDOM REAL MATRIX a WITH A SPECIFIED DISTRIBUTION ! OF SINGULAR VALUES AND A RANK EQUAL TO nsvd0. ! call gen_random_mat( s(:nsvd0), a ) ! ! COMPUTE THE FROBENIUS NORM OF THE MATRIX. ! anorm = norm( s(:nsvd0) ) ! end if ! if ( do_test ) then ! ! ALLOCATE WORK ARRAY. ! allocate( a2(m,n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! MAKE A COPY OF THE RANDOM DATA MATRIX . ! a2(:m,:n) = a(:m,:n) ! if ( mat_type>0_i4b ) then ! ! ALLOCATE WORK ARRAY. ! allocate( s0(k), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SAVE THE TRUE SINGULAR VALUES. ! s0(:nsvd0) = s(:nsvd0) s0(nsvd0+1_i4b:k) = zero ! end if ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! DETERMINE THE WORK TO DO AND HOW MANY SINGULAR TRIPLETS ! WILL BE COMPUTED AND STORED. ! ! IF jobu = 'V', LEFT SINGULAR VECTORS WILL BE COMPUTED. ! IF jobu = 'N', LEFT SINGULAR VECTORS WILL NOT BE COMPUTED. ! IF jobvt = 'V', RIGHT SINGULAR VECTORS WILL BE COMPUTED. ! IF jobvt = 'N', RIGHT SINGULAR VECTORS WILL NOT BE COMPUTED. ! jobu = 'V' jobvt = 'V' ! ! range DETERMINED HOW MANY SINGULAR VALUES AND VECTORS WILL BE COMPUTED. ! ! IF range='A' ALL SINGULAR VALUES WILL BE FOUND, ! IF range='V' ALL SINGULAR VALUES IN THE HALF OPEN INTERVAL (vl,vu] WILL BE FOUND, ! IF range='I' THE il-TH THROUGH iu-TH SINGULAR VALUES IN DESCENDING ORDER WILL BE FOUND. ! ! IN EACH CASE, THE ASSOCIATED SINGULAR VECTORS WILL BE ALSO COMPUTED. ! ! range = 'A' range = 'I' ! vl = zero vu = zero ! ! FOR FINDING THE nsing LARGEST SINGULAR VALUES USE THE NEXT TWO LINES. ! il = 1 iu = nsing ! ! FOR FINDING THE nsing SMALLEST SINGULAR VALUES USE THE NEXT TWO LINES. ! ! il = k - nsing + 1 ! iu = k ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR gesvdx SUBROUTINE. ! lwork = -1 ! call gesvdx( jobu, jobvt, range, m, n, a, m, vl, vu, il, iu, ns, & s, u, m, vt, k, work2, lwork, iwork, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) ! ! ALLOCATE OPTIMAL WORK VARIABLE NEEDED BY gesvdx SUBROUTINE. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! gesvdx COMPUTES THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL ! m-BY-n MATRIX a BY SOLVING AN ASSOCIATE EIGENVALUE PROBLEM. THE SVD ! IS WRITTEN ! ! a = U * S * V**(t) ! ! WHERE S IS AN m-BY-n MATRIX WHICH IS ZERO EXCEPT FOR ITS ! min(m,n) DIAGONAL ELEMENTS, U IS AN m-BY-m ORTHOGONAL MATRIX, AND ! V IS AN n-BY-n ORTHOGONAL MATRIX. THE DIAGONAL ELEMENTS OF S ! ARE THE SINGULAR VALUES OF a; THEY ARE REAL AND NON-NEGATIVE. ! THE COLUMNS OF U AND V ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a. ! ! THE ADVANTAGE OF gesvdx SUBROUTINE COMPARED TO OTHER SVD SUBROUTINES ! AVAILABLE IN LAPACK (E.G. gesvd OR gesdd) IS THAT gesvdx IS ABLE TO COMPUTE ! A PARTIAL SVD DECOMPOSITION OR SELECTED SINGULAR TRIPLETS OF THE INPUT ! REAL MATRIX WHILE THE OTHER SUBROUTINES DO NOT OFFER THIS POSSIBILITY. ! HOWEVER, BEWARE THAT THE gesvdx SUBROUTINE IS AVAILABLE ONLY IN LAPACK 3.6.0 ! AND ABOVE. ! call gesvdx( jobu, jobvt, range, m, n, a, m, vl, vu, il, iu, ns, & s, u, m, vt, k, work, lwork, iwork, info ) ! ! THE ROUTINE RETURNS THE SINGULAR VALUES, THE LEFT AND RIGHT ! SINGULAR VECTORS. THE RIGHT SINGULAR VECTORS ARE RETURNED ROWWISE. ! ! ON EXIT OF gesvdx : ! ! info= 0 : INDICATES SUCCESSFUL EXIT. ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE. ! info=i > 0 : INDICATES THAT i EIVENVECTORS FAILED TO CONVERGE. ! info=n*2+1 : INDICATES THAT AN INTERNAL ERROR OCCURRED. ! ! ON EXIT OF gesvdx WITH THE VALUES SPECIFIED ABOVE FOR jobu ('V'), ! jobvt ('V') AND range ('A'): ! ! u IS OVERWRITTEN WITH THE FIRST min(m,n) ! COLUMNS OF U (THE LEFT SINGULAR VECTORS, ! STORED COLUMNWISE); ! ! vt IS OVERWRITTEN WITH THE FIRST min(m,n) ! ROWS OF V**(t) (THE RIGHT SINGULAR VECTORS, ! STORED ROWWISE); ! ! s IS OVERWRITTEN WITH THE SINGULAR VALUES OF a IN DECREASING ORDER. ! ! FOR range='I' OR range='V', ns IS THE NUMBER OF SINGULAR TRIPLETS ! COMPUTED AND STORED BY THE SUBROUTINE IN ARGUMENTS u, vt AND s. ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart ! if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM gesvdx SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to GESVDX subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test ) then ! if ( mat_type>0_i4b ) then ! ! COMPUTE ERRORS FOR SINGULAR VALUES. ! where( s0(:ns)/=zero ) a(:ns,1_i4b) = s0(:ns) elsewhere a(:ns,1_i4b) = one end where ! ! ABSOLUTE ERRORS OF SINGULAR VALUES. ! abs_err = maxval( abs( s(:ns) - s0(:ns) ) ) ! ! RELATIVE ERRORS OF SINGULAR VALUES. ! rel_err = maxval( abs( (s(:ns) - s0(:ns))/a(:ns,1_i4b) ) ) ! end if ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a(:m,:n)*V(:n,:ns) - U(:m,:ns)*S(:ns,:ns). ! a(:m,:ns) = matmul(a2(:m,:n),transpose(vt(:ns,:n))) - u(:m,:ns)*spread(s(:ns),dim=1,ncopies=m) a2(:ns,1_i4b) = norm( a(:m,:ns), dim=2_i4b ) ! err1 = maxval( a2(:ns,1_i4b) )/( anorm*real(m,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U. ! call unit_matrix( a2(:ns,:ns) ) ! a(:ns,:ns) = abs( a2(:ns,:ns) - matmul( transpose(u(:m,:ns)), u(:m,:ns) ) ) ! err2 = maxval( a(:ns,:ns) )/real(m,stnd) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - V**(t)*V. ! a(:ns,:ns) = abs( a2(:ns,:ns) - matmul( vt(:ns,:n), transpose(vt(:ns,:n)) ) ) ! err3 = maxval( a(:ns,:ns) )/real(n,stnd) ! err = max( err1, err2, err3 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then ! if ( mat_type>0_i4b ) then deallocate( a, s, s0, u, vt, iwork, a2 ) else deallocate( a, s, u, vt, iwork, a2 ) end if ! else ! deallocate( a, s, u, vt, iwork ) ! end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' Matrix type = ', mat_type ! write (prtunit,*) write (prtunit,*) ' Matrix_type < 1 -> random matrix from the uniform distribution' write (prtunit,*) ' Matrix type = 1 -> slow decay of singular values' write (prtunit,*) ' Matrix type = 2 -> fast decay of singular values' write (prtunit,*) ' Matrix type = 3 -> s-shaped decay of singular values' write (prtunit,*) ' Matrix type = 4 -> very slow decay of singular values' write (prtunit,*) ' Matrix type = 5 -> strongly clustered singular values at 1' write (prtunit,*) ' spectrum with few deflations (for LAPACK GESDD routine)' write (prtunit,*) ' Matrix type = 6 -> geometric distribution of singular values' write (prtunit,*) ' spectrum with moderate deflation (for LAPACK GESDD routine)' write (prtunit,*) ' Matrix type = 7 -> arithmetic distribution of singular values' write (prtunit,*) ' spectrum with complete deflation (for LAPACK GESDD routine)' write (prtunit,*) ' Matrix type > 7 -> uniform distribution of singular values' ! write (prtunit,*) write (prtunit,*) ' INFO ( from gesvdx() ) = ', info ! if ( do_test .and. info==0 ) then ! write (prtunit,*) ! if ( mat_type>0_i4b ) then ! write (prtunit,*) 'Absolute accuracy of the computed singular values = ', abs_err write (prtunit,*) 'Relative accuracy of the computed singular values = ', rel_err ! end if ! write (prtunit,*) 'Accuracy of the computed singular triplets = ', err1 write (prtunit,*) 'Orthogonality of the computed left singular vectors = ', err2 write (prtunit,*) 'Orthogonality of the computed right singular vectors = ', err3 ! end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing ', ns,' singular values and vectors of a ', & m, ' by ', n,' real matrix is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex1_lapack_gesvdx ! ================================ ! end program ex1_lapack_gesvdx
ex1_lapack_orgbr.F90¶
program ex1_lapack_orgbr ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutines GEBRD and ORGBR ! in LAPACK software for computing a bidiagonal factorization and the full SVD decomposition ! of a real matrix. ! ! ! Further Details ! =============== ! ! The program also shows the use of subroutine BD_SVD2 in module SVD_Procedures. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : gebrd, orgbr ! use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, & unit_matrix, bd_svd2, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, m AND n ARE THE DIMENSIONS OF THE GENERATED MATRIX. ! integer, parameter :: prtunit = 6, m=3000, n=3000, k=min(m,n) ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 1 of orgbr' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err1, err2, err3, err, eps, elapsed_time real(stnd) :: work2(1) real(stnd), allocatable, dimension(:) :: d, e, tauq, taup, work, resid2 real(stnd), allocatable, dimension(:,:) :: a, a2, resid, pt, q ! integer :: info_bd, info_q, info_pt, lwork, lwork_bd, lwork_q, lwork_pt, & iok, istart, iend, irate, imax, itime integer(i4b) :: l ! logical(lgl) :: bd_is_upper, failure, do_test ! character :: sort='d' ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : BIDIAGONAL REDUCTION AND SVD DECOMPOSITION OF A REAL MATRIX USING LAPACK ! BIDIAGONAL DRIVER AND A STATPACK BIDIAGONAL SVD DRIVER. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = false ! bd_is_upper = m>=n ! ! ALLOCATE WORK ARRAYS. ! if ( bd_is_upper ) then allocate( a(m,n), d(k), e(k), tauq(k), taup(k), pt(k,k), stat=iok ) else allocate( a(m,n), d(k), e(k), tauq(k), taup(k), q(k,k), stat=iok ) end if ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A m-by-n REAL RANDOM DATA MATRIX . ! call random_number( a ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(m,n), resid(m,k), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SAVE THE DATA MATRIX. ! a2(:m,:n) = a(:m,:n) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR gebrd AND orgbr SUBROUTINES. ! lwork = -1 ! call gebrd( m, n, a, m, d, e(2_i4b:k), tauq, taup, work2, lwork, info=info_bd ) ! lwork_bd = int(work2(1)) ! if ( bd_is_upper ) then ! call orgbr( 'Q', m, n, n, a, m, tauq, work2, lwork, info=info_q ) ! lwork_q = int(work2(1)) ! call orgbr( 'P', n, n, m, pt, n, taup, work2, lwork, info=info_pt ) ! lwork_pt = int(work2(1)) ! else ! call orgbr( 'Q', m, m, n, q, m, tauq, work2, lwork, info=info_q ) ! lwork_q = int(work2(1)) ! call orgbr( 'P', m, n, m, a, m, taup, work2, lwork, info=info_pt ) ! lwork_pt = int(work2(1)) ! end if ! if ( min(info_bd,info_q,info_pt)==0 ) then ! lwork = max( lwork_bd, lwork_q, lwork_pt ) ! ! ALLOCATE OPTIMAL WORK VARIABLE NEEDED BY gebrd AND orgbr SUBROUTINES. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! COMPUTE BIDIAGONAL REDUCTION OF RANDOM DATA MATRIX ! ! a = Q*BD*P**(t) . ! ! WHERE Q AND P ARE ORTHOGONAL MATRICES AND BD IS A REAL BIDIAGONAL MATRIX. ! call gebrd( m, n, a, m, d, e(2_i4b:k), tauq, taup, work(:lwork_bd), lwork_bd, info=info_bd ) ! ! ON EXIT OF gebrd : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! ! d AND e ARE THE DIAGONAL AND OFF-DIAGONAL ELEMENTS OF THE BIDAGONAL MATRIX BD, RESPECTIVELY. BD IS UPPER ! BIDIAGONAL IF m>=n AND LOWER-BIDIAGONAL IF m<n . ! a CONTAINS THE ELEMENTARY REFLECTORS WHICH DEFINE Q AND P. ! taup AND tauq ARE THE SCALAR FACTORS OF THE ELEMENTARY REFLECTORS WHICH DEFINE Q AND P, RESPECTIVELY. ! ! NOW COMPUTE THE SINGULAR VALUE DECOMPOSITION (SVD) OF THE REAL ! m-BY-n MATRIX a. THE SVD IS WRITTEN ! ! a = U * S * V**(t) ! ! WHERE S IS AN m-BY-n MATRIX WHICH IS ZERO EXCEPT FOR ITS ! min(m,n) DIAGONAL ELEMENTS, U IS AN m-BY-m ORTHOGONAL MATRIX, AND ! V IS AN n-BY-n ORTHOGONAL MATRIX. THE DIAGONAL ELEMENTS OF S ! ARE THE SINGULAR VALUES OF a; THEY ARE REAL AND NON-NEGATIVE. ! THE COLUMNS OF U AND V ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a. ! if ( bd_is_upper ) then ! pt(:n,:n) = a(:n,:n) ! call orgbr( 'Q', m, n, n, a, m, tauq, work(:lwork_q), lwork_q, info=info_q ) ! call orgbr( 'P', n, n, m, pt, n, taup, work(:lwork_pt), lwork_pt, info=info_pt ) ! ! ON EXIT OF THESE orgbr CALLS: ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! ! IF m>=n, a IS OVERWRITTEN WITH THE FIRST min(m,n) ! COLUMNS OF Q; ! pt CONTAINS THE n-BY-n ORTHOGONAL MATRIX P**(t). ! ! COMPUTE ALL SINGULAR VALUES AND VECTORS OF THE REAL MATRIX a. THE SINGULAR ! VALUES ARE ALSO THE SINGULAR VALUES OF THE UPPER BIDIAGONAL MATRIX BD. ! call bd_svd2( bd_is_upper, d, e, failure, a, pt, sort=sort ) ! ! THE ROUTINE RETURNS THE SINGULAR VALUES, THE LEFT AND RIGHT ! SINGULAR VECTORS. THE RIGHT SINGULAR VECTORS ARE RETURNED ROWWISE: ! ! IF m>=n, a IS OVERWRITTEN WITH THE FIRST min(m,n) ! COLUMNS OF U (THE LEFT SINGULAR VECTORS, ! STORED COLUMNWISE); ! pt CONTAINS THE n-BY-n ORTHOGONAL MATRIX V**(t). ! ! d IS OVERWRITTEN WITH THE SINGULAR VALUES OF a IN DECREASING ORDER. ! else ! q(:m,:m) = a(:m,:m) ! call orgbr( 'Q', m, m, n, q, m, tauq, work(:lwork_q), lwork_q, info=info_q ) ! call orgbr( 'P', m, n, m, a, m, taup, work(:lwork_pt), lwork_pt, info=info_pt ) ! ! ON EXIT OF orgbr CALLS: ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! ! IF m<n, a IS OVERWRITTEN WITH THE FIRST min(m,n) ! ROWS OF P**(t); ! q CONTAINS THE m-BY-m ORTHOGONAL MATRIX Q. ! ! COMPUTE ALL SINGULAR VALUES AND VECTORS OF THE REAL LOWER BIDIAGONAL MATRIX BD, ! WHICH ARE ALSO THE SINGULAR VALUES AND VECTORS OF a . ! call bd_svd2( bd_is_upper, d, e, failure, q, a, sort=sort ) ! ! THE ROUTINE RETURNS THE SINGULAR VALUES, THE LEFT AND RIGHT ! SINGULAR VECTORS. THE RIGHT SINGULAR VECTORS ARE RETURNED ROWWISE: ! ! IF m<n, a IS OVERWRITTEN WITH THE FIRST min(m,n) ! ROWS OF V**(t) (THE RIGHT SINGULAR VECTORS, ! STORED ROWWISE); ! q CONTAINS THE m-BY-m ORTHOGONAL MATRIX U. ! ! d IS OVERWRITTEN WITH THE SINGULAR VALUES OF a IN DECREASING ORDER. ! end if ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( min(info_bd,info_q,info_pt)/=0 ) then ! ! ANORMAL EXIT FROM gebrd OR orgbr SUBROUTINES, PRINT A WARNING. ! write (prtunit,*) 'Error in the calls to GEBRD or ORGBR subroutines, Info=', min(info_bd,info_q,info_pt) ! else if ( do_test ) then ! if ( bd_is_upper ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a(:m,:n)*V(:n,:k) - U(:m,:k)*S(:k,:k). ! resid(:m,:k) = matmul(a2(:m,:k),transpose(pt(:k,:k))) - a(:m,:k)*spread(d,dim=1,ncopies=m) a2(:k,1_i4b) = norm( resid(:m,:k), dim=2_i4b ) err1 = maxval( a2(:k,1_i4b) )/( sum( abs(d) )*real(m,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U. ! call unit_matrix( a2(:n,:n) ) ! resid(:n,:n) = abs( a2(:n,:n) - matmul( transpose(a(:m,:n)), a(:m,:n) ) ) err2 = maxval( resid(:n,:n) )/real(m,stnd) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - V**(t)*V. ! resid(:n,:n) = abs( a2(:n,:n) - matmul( pt(:n,:n), transpose(pt(:n,:n)) ) ) err3 = maxval( resid(:n,:n) )/real(n,stnd) ! else ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a(:m,:n)*V(:n,:k) - U(:m,:k)*S(:k,:k). ! resid(:m,:k) = matmul(a2(:m,:n),transpose(a(:k,:n))) - q(:k,:k)*spread(d,dim=1,ncopies=k) a2(:k,1_i4b) = norm( resid(:m,:k), dim=2_i4b ) err1 = maxval( a2(:k,1_i4b) )/( sum( abs(d) )*real(m,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U. ! call unit_matrix( a2(:m,:m) ) ! resid(:m,:m) = abs( a2(:m,:m) - matmul( transpose(q(:m,:m )), q(:m,:m ) ) ) err2 = maxval( resid(:m,:m) )/real(m,stnd) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - V**(t)*V. ! resid(:m,:m) = abs( a2(:m,:m) - matmul( a(:m,:n), transpose(a(:m,:n)) ) ) err3 = maxval( resid(:m,:m) )/real(n,stnd) ! endif ! err = max( err1, err2, err3 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( m>=n ) then deallocate( a, pt, d, e, tauq, taup ) else deallocate( a, q, d, e, tauq, taup ) end if ! if ( do_test ) then deallocate( a2, resid ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. min(info_bd,info_q,info_pt)==0 .and. .not.failure ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from gebrd() ) = ', info_bd write (prtunit,*) ' INFO ( from orgbr() ) = ', info_q write (prtunit,*) ' INFO ( from orgbr() ) = ', info_pt write (prtunit,*) ' FAILURE ( from bd_svd2() ) = ', failure ! if ( do_test .and. min(info_bd,info_q,info_pt)==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed singular triplets = ', err1 write (prtunit,*) 'Orthogonality of the computed left singular vectors = ', err2 write (prtunit,*) 'Orthogonality of the computed right singular vectors = ', err3 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing all singular values and vectors of a ', & m, ' by ', n,' real matrix is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex1_lapack_orgbr ! =============================== ! end program ex1_lapack_orgbr
ex1_lapack_orgtr.F90¶
program ex1_lapack_orgtr ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutines SYTRD and ORGTR ! in LAPACK software for computing a tridiagonal decomposition and all eigenvalues ! and eigenvectors of a real symmetric matrix. ! ! ! Further Details ! =============== ! ! The program also shows the use of subroutine SYMTRID_QRI2 in module EIG_Procedures. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : sytrd, orgtr ! use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, & unit_matrix, symtrid_qri2, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, n IS THE DIMENSION OF THE GENERATED SYMMETRIC MATRIX. ! integer, parameter :: prtunit = 6, n=3000 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 1 of orgtr' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err1, err2, err, eps, elapsed_time real(stnd) :: work2(1) real(stnd), allocatable, dimension(:) :: d, e, tau, work, resid2 real(stnd), allocatable, dimension(:,:) :: a, a2, resid ! integer :: info_trd, info_q, lwork, lwork_trd, lwork_q, & iok, istart, iend, irate, imax, itime integer(i4b) :: l ! logical(lgl) :: failure, do_test ! character :: uplo, sort='d' ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : EIGENVALUES AND EIGENVECTORS OF A REAL SYMMETRIC ! MATRIX USING THE QR METHOD BY COMBINING LAPACK AND ! STATPACK SUBROUTINES. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a(n,n), d(n), e(n), tau(n-1_i4b), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A n-by-n RANDOM DATA MATRIX AND ! FROM IT A SELF-ADJOINT MATRIX a . ! call random_number( a ) ! a = a + transpose( a ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(n,n), resid(n,n), resid2(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SAVE THE SYMMETRIC MATRIX. ! a2(:n,:n) = a(:n,:n) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! COMPUTE EIGENVALUES AND EIGENVECTORS OF THE SELF-ADJOINT MATRIX a ! WITH SUBROUTINES sytrd AND orgtr FROM LAPACK AND symtrid_qri2 FROM ! STATPACK. ! ! THE EIGENVALUE DECOMPOSITION OF A REAL n-BY-n SYMMETRIC MATRIX a ! IS WRITTEN ! ! a = U * D * U**(t) ! ! WHERE D IS AN n-BY-n DIAGONAL MATRIX AND U IS AN n-BY-n ORTHOGONAL MATRIX. ! THE DIAGONAL ELEMENTS OF D ARE THE EIGENVALUES OF a; THEY ARE REAL. ! THE COLUMNS OF U ARE THE EIGENVECTORS OF a. ! ! FIRST REDUCE THE SYMMETRIC MATRX a TO TRIDIAGONAL FORM WITH ! SUBROUTINES sytrd AND orgtr FROM LAPACK. ! ! IF uplo='U' UPPER TRIANGLE OF a IS STORED, ! IF uplo='L' LOWER TRIANGLE OF a IS STORED. ! uplo = 'U' ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR sytrd AND orgtr SUBROUTINES. ! lwork = -1 ! call sytrd( uplo, n, a, n, d, e(:n-1_i4b), tau, work2, lwork, info=info_trd ) ! lwork_trd = int(work2(1)) ! call orgtr( uplo, n, a, n, tau, work2, lwork, info=info_q ) ! lwork_q = int(work2(1)) ! if ( min(info_trd,info_q)==0 ) then ! lwork = max( lwork_trd, lwork_q ) ! ! ALLOCATE OPTIMAL WORK VARIABLE NEEDED BY sytrd AND orgtr SUBROUTINES. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! CALL sytrd AND orgtr TO REDUCE THE MATRIX a TO TRIDIAGONAL FORM ! ! a = Q*TRID*Q**(t) ! ! WHERE Q IS ORTHOGONAL AND TRID IS A SYMMETRIC TRIDIAGONAL MATRIX. ! call sytrd( uplo, n, a, n, d, e(:n-1_i4b), tau, work(:lwork_trd), lwork_trd, info=info_trd ) ! ! ON EXIT OF sytrd : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! ! d AND e ARE THE DIAGONAL AND OFF-DIAGONAL ELEMENTS OF THE SYMMETRIC TRIDIAGONAL MATRIX, RESPECTIVELY. ! a CONTAINS THE ELEMENTARY REFLECTORS WHICH DEFINE Q IN ITS UPPER TRIANGLE IF uplo='U'. ! tau CONTAINS THE SCALAR FACTORS OF THE ELEMENTARY REFLECTORS WHICH DEFINE Q. ! call orgtr( uplo, n, a, n, tau, work(:lwork_q), lwork_q, info=info_q ) ! ! ON EXIT OF THIS orgtr CALL: ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! ! a IS OVERWRITTEN WITH THE n-BY-n ORTHOGONAL MATRIX Q. ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! ! NEXT COMPUTE ALL EIGENVALUES AND EIGENVECTORS OF THE REAL SYMMETRIC MATRIX a WITH ! SUBROUTINE symtrid_qri2 FROM STATPACK, USING TRID AND Q COMPUTED FROM LAPACK SUBROUTINES. ! THE EIGENVALUES OF a ARE ALSO THE EIGENVALUES OR THE TRIDIAGONAL MATRIX TRID. ! call symtrid_qri2( d(:n), e(:n), failure, a(:n,:n), sort=sort ) ! ! THE ROUTINE RETURNS THE EIGENVALUES AND THE EIGENVECTORS OF a. ! ! ON EXIT OF symtrid_qri2: ! ! failure= false : INDICATES SUCCESSFUL EXIT. ! failure= true : INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND ! THAT FULL ACCURACY WAS NOT ATTAINED IN THE EIGENDECOMPOSITION ! OF THE INTERMEDIATE TRIDIAGONAL FORM TRID OF a. ! ! a IS OVERWRITTEN WITH THE EIGENVECTORS, STORED COLUMNWISE; ! ! d IS OVERWRITTEN WITH THE EIGENVALUES OF a. ! ! IF SORT = 'a' OR 'A', THE EIGENVALUES ARE SORTED INTO ASCENDING ORDER. ! IF SORT = 'd' OR 'D', THE EIGENVALUES ARE SORTED INTO DESCENDING ORDER. ! THE EIGENVECTORS ARE REARRANGED ACCORDINGLY. ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( min(info_trd,info_q)/=0 ) then ! ! ANORMAL EXIT FROM sytrd AND orgtr SUBROUTINES, PRINT A WARNING. ! write (prtunit,*) 'Error in the calls to SYTRD or ORGTR subroutines, Info=', min(info_trd,info_q) ! else if ( do_test ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*U - U*D ! resid(:n,:n) = matmul(a2(:n,:n),a(:n,:n)) - a(:n,:n)*spread(d,1,n) resid2(:n) = norm( resid(:n,:n), dim=2_i4b ) err1 = maxval( resid2(:n) )/( norm( a2 )*real(n,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U. ! call unit_matrix( a2(:n,:n) ) ! resid(:n,:n) = abs( a2(:n,:n) - matmul( transpose(a(:n,:n )), a(:n,:n) ) ) err2 = maxval( resid(:n,:n) )/real(n,stnd) ! err = max( err1, err2 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, a2, resid, resid2, d, e, tau ) else deallocate( a, d, e, tau ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. min(info_trd,info_q)==0 .and. .not.failure ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from sytrd() ) = ', info_trd write (prtunit,*) ' INFO ( from orgtr() ) = ', info_q write (prtunit,*) ' FAILURE ( from symtrid_qri2() ) = ', failure ! if ( do_test .and. min(info_trd,info_q)==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed eigenvalues and eigenvectors = ', err1 write (prtunit,*) 'Orthogonality of the computed eigenvectors = ', err2 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing ', n, ' eigenvalues and eigenvectors of a ', & n, ' by ', n,' real symmetric matrix is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex1_lapack_orgtr ! =============================== ! end program ex1_lapack_orgtr
ex1_lapack_ormbr.F90¶
program ex1_lapack_ormbr ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutines GEBRD and ORMBR ! in LAPACK software for computing a bidiagonal factorization and a partial SVD ! decomposition of a real matrix. ! ! ! Further Details ! =============== ! ! The program also shows the use of subroutines BD_SVD and BD_INVITER ! in module SVD_Procedures. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : gebrd, ormbr ! use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, unit_matrix, & bd_svd, bd_inviter, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, m AND n ARE THE DIMENSIONS OF THE GENERATED MATRIX, ! nvec IS THE NUMBER OF SINGULAR VECTORS, WHICH WILL BE COMPUTED BY INVERSE ITERATIONS. ! integer, parameter :: prtunit = 6, m=3000, n=3000, nvec=3000, k=min(m,n) ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 1 of ormbr' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err1, err2, err3, err, eps, elapsed_time real(stnd) :: work2(1) real(stnd), allocatable, dimension(:) :: d, e, singval, e2, tauq, taup, work real(stnd), allocatable, dimension(:,:) :: a, a2, leftvec, rightvec ! integer :: info_bd, info_q, info_p, lwork, lwork_bd, lwork_q, lwork_p, & iok, istart, iend, irate, imax, itime integer(i4b) :: maxiter=4, l ! logical(lgl) :: failure, bd_is_upper, do_test ! character :: sort='d' ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : BIDIAGONAL REDUCTION AND PARTIAL SVD DECOMPOSITION OF A REAL ! MATRIX USING AN INVERSE ITERATION METHOD BY COMBINING LAPACK AND ! STATPACK SUBROUTINES. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! bd_is_upper = m>=n ! ! ALLOCATE WORK ARRAYS. ! allocate( a(m,n), leftvec(m,nvec), rightvec(n,nvec), d(k), e(k), & tauq(k), taup(k), singval(k), e2(k), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A m-by-n REAL RANDOM DATA MATRIX . ! call random_number( a ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAY. ! allocate( a2(m,n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SAVE THE DATA MATRIX. ! a2(:m,:n) = a(:m,:n) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR gebrd AND orgbr SUBROUTINES. ! lwork = -1 ! call gebrd( m, n, a, m, d(:k), e(2_i4b:k), tauq, taup, work2, lwork, info=info_bd ) ! lwork_bd = int(work2(1)) ! call ormbr( 'Q', 'L', 'N', m, nvec, n, a, m, tauq, leftvec, m, work2, lwork, info=info_q ) ! lwork_q = int(work2(1)) ! call ormbr( 'P', 'L', 'N', n, nvec, m, a, m, taup, rightvec, n, work2, lwork, info=info_p ) ! lwork_p = int(work2(1)) ! if ( min(info_bd,info_q,info_p)==0 ) then ! lwork = max( lwork_bd, lwork_q, lwork_p ) ! ! ALLOCATE OPTIMAL WORK VARIABLE NEEDED BY gebrd AND ormbr SUBROUTINES. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! COMPUTE BIDIAGONAL REDUCTION OF RANDOM DATA MATRIX a = Q*BD*P**(t) ! WHERE Q AND P ARE ORTHOGONAL MATRICES AND BD IS A REAL BIDIAGONAL MATRIX. ! call gebrd( m, n, a, m, d(:k), e(2_i4b:k), tauq, taup, work(:lwork_bd), lwork_bd, info=info_bd ) ! ! ON EXIT OF gebrd : ! ! info= 0 : INDICATES SUCCESSFUL EXIT. ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE. ! ! d AND e ARE THE DIAGONAL AND OFF-DIAGONAL ELEMENTS OF THE BIDAGONAL MATRIX BD, RESPECTIVELY. ! a CONTAINS THE ELEMENTARY REFLECTORS WHICH DEFINE Q AND P. ! taup AND tauq ARE THE SCALAR FACTORS OF THE ELEMENTARY REFLECTORS WHICH DEFINE Q AND P, RESPECTIVELY. ! ! MAKE A COPY OF THE BIDIAGONAL MATRIX. ! singval(:k) = d(:k) e2(:k) = e(:k) ! ! COMPUTE ALL SINGULAR VALUES OF THE REAL BIDIAGONAL MATRIX BD. ! call bd_svd( bd_is_upper, singval(:k), e2(:k), failure, sort=sort ) ! if ( .not. failure ) then ! ! COMPUTE THE FIRST nvec SINGULAR VECTORS OF THE BIDIAGONAL MATRIX BY maxiter INVERSE ITERATIONS. ! call bd_inviter( bd_is_upper, d(:k), e(:k), singval(:nvec), leftvec(:k,:nvec), & rightvec(:k,:nvec), failure, maxiter=maxiter ) ! ! NOW COMPUTE THE FIRST nvec SINGULAR VECTORS OF THE FULL m-BY-n MATRIX a BY BACK-TRANSFORMATION WITH ! LAPACK SUBROUTINE ormbr. ! if ( bd_is_upper ) then leftvec(k+1_i4b:m,:nvec) = zero else rightvec(k+1_i4b:n,:nvec) = zero end if ! call ormbr( 'Q', 'L', 'N', m, nvec, n, a, m, tauq, leftvec, m, work(:lwork_q), lwork_q, info=info_q ) ! call ormbr( 'P', 'L', 'N', n, nvec, m, a, m, taup, rightvec, n, work(:lwork_p), lwork_p, info=info_p ) ! ! ON EXIT OF THESE ormbr CALLS: ! ! info= 0 : INDICATES SUCCESSFUL EXIT. ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE. ! ! leftvec IS OVERWRITTEN WITH THE FIRST nvec LEFT SINGULAR VECTORS of a STORED COLUMNWISE. ! rightvec IS OVERWRITTEN WITH THE FIRST nvec RIGHT SINGULAR VECTORS of a STORED COLUMNWISE. ! end if ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( min(info_bd,info_q,info_p)/=0 ) then ! ! ANORMAL EXIT FROM gebrd OR ormbr SUBROUTINES, PRINT A WARNING. ! write (prtunit,*) 'Error in the calls to GEBRD or ORMBR subroutines, Info=', min(info_bd,info_q,info_p) ! else if ( do_test .and. .not.failure ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*rightvec - leftvec*diag(singval(:nvec)), ! WHERE leftvec AND rightvec ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a. ! a(:m,:nvec) = matmul(a2,rightvec) - leftvec*spread( singval(:nvec),dim=1,ncopies=m ) ! a2(:nvec,1_i4b) = norm( a(:m,:nvec), dim=2_i4b ) err1 = maxval( a2(:nvec,1_i4b) )/( sum( abs(singval(:k)) )*real(m,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - leftvec**(t)*leftvec. ! call unit_matrix( a2(:nvec,:nvec) ) ! a(:nvec,:nvec) = abs( a2(:nvec,:nvec) - matmul( transpose(leftvec(:m,:nvec)), leftvec(:m,:nvec) ) ) err2 = maxval( a(:nvec,:nvec) )/real(m,stnd) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - rightvec**(t)*rightvec. ! a(:nvec,:nvec) = abs( a2(:nvec,:nvec) - matmul( transpose(rightvec(:n,:nvec)), rightvec(:n,:nvec) ) ) err3 = maxval( a(:nvec,:nvec) )/real(n,stnd) ! err = max( err1, err2, err3 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, a2, leftvec, rightvec, d, e, tauq, taup, singval, e2 ) else deallocate( a, leftvec, rightvec, d, e, tauq, taup, singval, e2 ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. min(info_bd,info_q,info_p)==0 .and. .not.failure ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from gebrd() ) = ', info_bd write (prtunit,*) ' INFO ( from ormbr() ) = ', info_q write (prtunit,*) ' INFO ( from ormbr() ) = ', info_p write (prtunit,*) ' FAILURE ( from bd_inviter() ) = ', failure ! if ( do_test .and. min(info_bd,info_q,info_p)==0 .and. .not.failure ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed singular triplets = ', err1 write (prtunit,*) 'Orthogonality of the computed left singular vectors = ', err2 write (prtunit,*) 'Orthogonality of the computed right singular vectors = ', err3 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing all singular values and ', nvec, ' singular vectors of a ', & m, ' by ', n,' real matrix is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex1_lapack_ormbr ! =============================== ! end program ex1_lapack_ormbr
ex1_lapack_ormtr.F90¶
program ex1_lapack_ormtr ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutines (x)SYTRD and (x)ORMTR ! in LAPACK software for computing a tridiagonal decomposition and all or selected eigenvalues ! and eigenvectors of a real symmetric matrix. ! ! ! Further Details ! =============== ! ! The program also shows the use of subroutines SYMTRID_QRI and TRID_INVITER ! in module EIG_Procedures. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : sytrd, ormtr ! use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, unit_matrix, & symtrid_qri, trid_inviter, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, n IS THE DIMENSION OF THE GENERATED SYMMETRIC MATRIX ! AND nvec IS THE NUMBER OF EIGENVECTORS, WHICH WILL BE COMPUTED BY INVERSE ITERATIONS. ! integer, parameter :: prtunit = 6, n=3000, nvec=3000 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 1 of ormtr' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err1, err2, err, eps, elapsed_time real(stnd) :: work2(1) real(stnd), allocatable, dimension(:) :: d, e, tau, eigval, e2, work, resid real(stnd), allocatable, dimension(:,:) :: a, eigvec, a2 ! integer :: info_trd, info_q, lwork, lwork_trd, lwork_q, iok, & istart, iend, irate, imax, itime integer(i4b) :: l, maxiter=2 ! logical(lgl) :: failure, failure2, do_test ! character :: uplo, sort='d' ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : TRIDIAGONAL REDUCTION OF A REAL SYMMETRIC MATRIX AND ! EIGENVALUES AND, OPTIONALLY, EIGENVECTORS OF A REAL ! SYMMETRIC MATRIX USING THE INVERSE ITERATION METHOD ! BY COMBINING LAPACK AND STATPACK DRIVERS. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a(n,n), eigvec(n,nvec), d(n), e(n), tau(n-1_i4b), & eigval(n), e2(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A n-by-n RANDOM DATA MATRIX AND ! FROM IT A SELF-ADJOINT MATRIX a . ! call random_number( a ) ! a = a + transpose( a ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(n,n), resid(nvec), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SAVE THE SYMMETRIC MATRIX. ! a2(:n,:n) = a(:n,:n) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! IF uplo='U' UPPER TRIANGLE OF a IS STORED, ! IF uplo='L' LOWER TRIANGLE OF a IS STORED. ! uplo = 'U' ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR sytrd AND ormtr SUBROUTINES. ! lwork = -1 ! call sytrd( uplo, n, a, n, d, e, tau, work2, lwork, info=info_trd ) ! lwork_trd = int(work2(1)) ! call ormtr( 'L', uplo, 'N', n, nvec, a, n, tau, eigvec, n, work2, lwork, info=info_q ) ! lwork_q = int(work2(1)) ! if ( info_trd==0 .and. info_q==0 ) then ! lwork = max( lwork_trd, lwork_q ) ! ! ALLOCATE OPTIMAL WORK VARIABLE NEEDED BY sytrd AND ormtr SUBROUTINES. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! CALL sytrd TO REDUCE THE MATRIX a TO TRIDIAGONAL FORM ! ! a = Q*TRID*Q**(t) ! ! WHERE Q IS ORTHOGONAL AND TRID IS A SYMMETRIC TRIDIAGONAL MATRIX. ! call sytrd( uplo, n, a, n, d, e, tau, work(:lwork_trd), lwork_trd, info=info_trd ) ! ! ON EXIT OF sytrd : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! ! d AND e ARE THE DIAGONAL AND OFF-DIAGONAL ELEMENTS OF THE SYMMETRIC TRIDIAGONAL MATRIX, RESPECTIVELY. ! a CONTAINS THE ELEMENTARY REFLECTORS WHICH DEFINE Q IN ITS UPPER TRIANGLE IF uplo='U'. ! tau CONTAINS THE SCALAR FACTORS OF THE ELEMENTARY REFLECTORS WHICH DEFINE Q. ! ! MAKE A COPY OF THE TRIDIAGONAL MATRIX. ! eigval(:n) = d(:n) e2(:n) = e(:n) ! ! COMPUTE ALL THE EIGENVALUES OF THE SYMMETRIC TRIDIAGONAL MATRIX WITH SUBROUTINE symtrid_qri. ! call symtrid_qri( eigval, e2, failure, sort=sort ) ! if ( .not.failure ) then ! ! COMPUTE THE FIRST nvec EIGENVECTORS OF THE SELF-ADJOINT MATRIX a BY ! maxiter INVERSE ITERATIONS ON THE INTERMEDIATE TRIDIAGONAL MATRIX ! AND BACK-TRANSFORMATION WITH LAPACK SUBROUTINE ormtr. ! call trid_inviter( d(:n), e(:n), eigval(:nvec), eigvec(:n,:nvec), failure, maxiter=maxiter ) ! call ormtr( 'L', uplo, 'N', n, nvec, a, n, tau, eigvec, n, work(:lwork_q), lwork_q, info=info_q ) ! ! ON EXIT OF THIS ormtr CALL: ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! ! eigvec IS OVERWRITTEN WITH THE FIRST nvec EIGENVECTORS OF a STORED COLUMNWISE. ! end if ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! failure2 = info_trd/=0 .or. info_q/=0 ! if ( failure2 ) then ! ! ANORMAL EXIT FROM sytrd OR ormtr SUBROUTINES, PRINT A WARNING. ! write (prtunit,*) 'Errors in the calls to SYTRD or ORMTR subroutines, Info=', & info_trd, info_q ! if ( info_trd<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value in SYTRD'')') - info_trd ! end if ! if ( info_q<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value in ORMTR'')') - info_q ! end if ! else if ( do_test .and. .not.failure ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*eigvec - eigvec*diag(eigval(:nvec)) ! WHERE eigval ARE THE EIGENVALUES AND eigvec THE EIGENVECTORS OF a. ! a(:n,:nvec) = matmul( a2, eigvec ) - eigvec*spread( eigval(:nvec), dim=1, ncopies=n ) ! resid(:nvec) = norm( a(:n,:nvec), dim=2_i4b ) err1 = maxval( resid(:nvec) )/( norm(a2)*real(n,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - eigvec**(t)*eigvec ! WHERE eigvec are THE EIGENVECTORS OF THE MATRIX a. ! call unit_matrix( a(:nvec,:nvec) ) ! a2(:nvec,:nvec) = abs( a(:nvec,:nvec) - matmul( transpose( eigvec ), eigvec ) ) err2 = maxval( a2(:nvec,:nvec) )/real(n,stnd) ! err = max( err1, err2 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, a2, eigvec, d, e, tau, eigval, e2, resid ) else deallocate( a, eigvec, d, e, tau, eigval, e2 ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. .not.failure .and. .not.failure2 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from sytrd() ) = ', info_trd write (prtunit,*) ' INFO ( from ormtr() ) = ', info_q write (prtunit,*) ' FAILURE ( from trid_inviter() ) = ', failure ! if ( do_test .and. .not.failure .and. .not.failure2 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed eigenvalues and eigenvectors = ', err1 write (prtunit,*) 'Orthogonality of the computed eigenvectors = ', err2 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing all eigenvalues and', nvec, ' eigenvectors of a', & n, ' by', n,' real symmetric matrix is', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex1_lapack_ormtr ! =============================== ! end program ex1_lapack_ormtr
ex1_lapack_posv.F90¶
program ex1_lapack_posv ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutine POSV ! in LAPACK software for solving a real linear system with a positive definite ! symmetric coefficient matrix and a Cholesky factorization of this coefficient ! matrix. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : posv ! use Statpack, only : lgl, i4b, stnd, true, false, zero, c100, norm, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, n IS THE DIMENSION OF THE GENERATED SYMMETRIC POSITIVE MATRIX, ! nrhs IS THE NUMBER OF RIGHT HANDE-SIDE VECTORS OF THE LINEAR SYSTEM TO BE SOLVED. ! integer, parameter :: prtunit = 6, n=4000, m=n+10, nrhs=200 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c100 ! character(len=*), parameter :: name_proc='Example 1 of posv' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, eps, elapsed_time real(stnd), dimension(:,:), allocatable :: a, b, c, x, res ! integer :: info, iok, istart, iend, irate, imax, itime ! logical(lgl) :: do_test ! character :: uplo ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : SOLUTION OF A LINEAR SYSTEM WITH A REAL SYMMETRIC DEFINITE POSITIVE COEFFICIENT ! MATRIX AND SEVERAL RIGHT HAND-SIDES USING A CHOLESKY DECOMPOSITION OF THE ! COEFFICIENT MATRIX. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*real( n, stnd )*epsilon( err ) ! eps = sqrt( epsilon( err ) ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( c(m,n), a(n,n), b(n,nrhs), x(n,nrhs), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A n-by-n RANDOM REAL SYMMETRIC POSITIVE DEFINITE MATRIX a . ! call random_number( c ) ! a = matmul( transpose(c), c ) ! ! GENERATE A n-by-nrhs RANDOM SOLUTION MATRIX x . ! call random_number( x ) ! ! COMPUTE THE MATRIX-MATRIX PRODUCT b = a*x . ! b = matmul( a, x ) ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! COMPUTE THE SOLUTION MATRIX FOR SYMMETRIC POSITIVE DEFINITE SYSTEM ! ! a*x = b . ! ! FIRST SPECIFY IF UPPER OR LOWER TRIANGLE OF a IS STORED . ! uplo = 'U' ! call posv( uplo, n, nrhs, a, n, b, n, info ) ! ! ON EXIT OF posv : ! ! info = 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT the iTH ARGUMENT HAS AN ILLEGAL VALUE ! info=i > 0 : INDICATES THAT THE SOLUTION CAN NOT BE COMPUTED BECAUSE ! THE MATRIX IS SINGULAR ! ! THE ROUTINE RETURNS THE SOLUTION VECTORS IN b. ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! ! CHECK THAT THE LAPACK ROUTINE HAS BEEN SUCCESSFUL. ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM posv SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to POSV subroutine, Info=', info write (prtunit,*) ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! else if (info>0) then ! write (prtunit,'(''Zero diagonal value detected in upper ''// & ''triangular factor at position '',i7)') info ! end if ! else if ( do_test ) then ! ! ALLOCATE WORK ARRAY. ! allocate( res(n,nrhs), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! res(:n,:nrhs) = b(:n,:nrhs) - x(:n,:nrhs) err = maxval( norm(res, dim=2_i4b ) / & norm(x, dim=2_i4b ) )/real(n,stnd) ! ! DEALLOCATE WORK ARRAY. ! deallocate( res ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! deallocate( a, b, c, x ) ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from posv() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed solutions = ', err end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for solving a positive definite symmetric linear system of size ', & n, ' with', nrhs, ' right hand side vectors is', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex1_lapack_posv ! ============================== ! end program ex1_lapack_posv
ex1_lapack_spev.F90¶
program ex1_lapack_spev ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutine SPEV ! in LAPACK software for computing all eigenvalues and, optionally, ! eigenvectors of a symmetric matrix stored in packed format. The eigenvalues ! and eigenvectors are computed by the tridiagonal QR implicit method. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : spev ! use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, & triangle, merror, allocate_error, unit_matrix ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, n IS THE DIMENSION OF THE GENERATED SYMMETRIC MATRIX. ! integer(i4b), parameter :: prtunit = 6, n=3000, p=(n*(n+1))/2 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 1 of spev' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, err1, err2, eps, elapsed_time real(stnd), dimension(:), allocatable :: a_packed, w, work, resid2 real(stnd), dimension(:,:), allocatable :: a, eigvec, resid ! integer(i4b) :: info, iok, i, istart, iend, irate, imax, itime ! logical(lgl) :: do_test ! character :: jobz, uplo ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : EIGENVALUES AND, OPTIONALLY, EIGENVECTORS OF A REAL SYMMETRIC ! MATRIX IN PACKED STORAGE USING THE QR IMPLICIT METHOD. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a_packed(p), eigvec(n,n), w(n), work(3*n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A RANDOM SELF-ADJOINT MATRIX a IN PACKED FORM. ! call random_number( a_packed(:p) ) ! ! MAKE a POSITIVE DEFINITE ASSUMING THAT THE UPPER TRIANGLE OF ! THE SELF-ADJOINT MATRIX IS STORED IN PACKED FORM. ! do i = 1_i4b, n a_packed(i+((i-1_i4b)*i/2_i4b)) = real( n, stnd ) end do ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a(n,n), resid(n,n), resid2(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! UNPACKED AND SAVE RANDOM SELF-ADJOINT MATRIX a ! ASSUMING THAT THE UPPER TRIANGLE OF THE SELF-ADJOINT ! MATRIX IS STORED IN PACKED FORM. ! a(:n,:n) = unpack( a_packed(:p), mask=triangle( true, n, n, extra=1_i4b), field=zero ) ! do i = 1_i4b, n a(i+1_i4b:n,i) = a(i,i+1_i4b:n) end do ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! IF jobz='N' COMPUTE EIGENVALUES ONLY, ! IF jobz='V' COMPUTE EIGENVALUES AND EIGENVECTORS. ! jobz = 'V' ! ! IF uplo='U' UPPER TRIANGLE OF a IS STORED, ! IF uplo='L' LOWER TRIANGLE OF a IS STORED. ! uplo = 'U' ! ! COMPUTE EIGENVALUES AND EIGENVECTORS OF THE SELF-ADJOINT MATRIX a ! IN PACKED STORAGE WITH SUBROUTINE spev FROM LAPACK. ! THE EIGENVALUE DECOMPOSITION OF A REAL n-BY-n SYMMETRIC MATRIX a ! IS WRITTEN ! ! a = U * D * U**(t) ! ! WHERE D IS AN n-BY-n DIAGONAL MATRIX AND U IS AN n-BY-n ORTHOGONAL MATRIX. ! THE DIAGONAL ELEMENTS OF D ARE THE EIGENVALUES OF a; THEY ARE REAL. ! THE COLUMNS OF U ARE THE EIGENVECTORS OF a. ! call spev( jobz, uplo, n, a_packed, w, eigvec, n, work, info ) ! ! ON EXIT OF spev : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! info=i > 0 : INDICATES THAT THE ALGORITHM FAILED TO CONVERGE ! AND i OFF-DIAGONAL ELEMENTS OF AN INTERMEDIATE ! TRIDIAGONAL FORM OF a DID NOT CONVERGE TO ZERO. ! ! ON EXIT OF spev : ! ! eigvec IS OVERWRITTEN WITH THE EIGENVECTORS OF a IF ! jobz='V' (THE EIGENVECTORS ARE STORED COLUMNWISE). ! ! w IS OVERWRITTEN WITH THE EIGENVALUES OF a IN ASCENDING ORDER. ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM spev SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to SPEV subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*U - U*D ! resid(:n,:n) = matmul(a(:n,:n),eigvec(:n,:n)) - eigvec(:n,:n)*spread(w,1,n) resid2(:n) = norm( resid(:n,:n), dim=2_i4b ) err1 = maxval( resid2(:n) )/( norm( a )*real(n,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U. ! call unit_matrix( a(:n,:n) ) ! resid(:n,:n) = abs( a(:n,:n) - matmul( transpose(eigvec(:n,:n)), eigvec(:n,:n) ) ) err2 = maxval( resid(:n,:n) )/real( n, stnd) ! err = max( err1, err2 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a_packed, eigvec, w, work, a, resid, resid2 ) else deallocate( a_packed, eigvec, w, work ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from spev() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed eigenvalues and eigenvectors = ', err1 write (prtunit,*) 'Orthogonality of the computed eigenvectors = ', err2 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing ', n, ' eigenvalues and eigenvectors of a ', & n, ' by ', n,' real symmetric matrix in packed storage is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex1_lapack_spev ! ============================== ! end program ex1_lapack_spev
ex1_lapack_spevd.F90¶
program ex1_lapack_spevd ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutine SPEVD ! in LAPACK software for computing all eigenvalues and, optionally, ! eigenvectors of a real symmetric matrix stored in packed format. ! The eigenvalues and eigenvectors are computed by the divide and conquer method. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : spevd ! use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, & triangle, merror, allocate_error, unit_matrix ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, n IS THE DIMENSION OF THE GENERATED SYMMETRIC MATRIX. ! integer(i4b), parameter :: prtunit = 6, n=3000, p=(n*(n+1))/2 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 1 of spevd' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, err1, err2, eps, elapsed_time real(stnd) :: work2(1) real(stnd), dimension(:), allocatable :: a_packed, w, work, resid2 real(stnd), dimension(:,:), allocatable :: a, eigvec, resid ! integer(i4b) :: info, lwork, liwork, iok, i, istart, & iend, irate, imax, itime integer(i4b) :: iwork2(1) integer(i4b), dimension(:), allocatable :: iwork ! logical(lgl) :: do_test ! character :: jobz, uplo ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : EIGENVALUES AND, OPTIONALLY, EIGENVECTORS OF A REAL SYMMETRIC ! MATRIX IN PACKED STORAGE USING THE DIVIDE AND CONQUER METHOD. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS . ! allocate( a_packed(p), eigvec(n,n), w(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A RANDOM SELF-ADJOINT MATRIX a IN PACKED FORM. ! call random_number( a_packed(:p) ) ! ! MAKE a POSITIVE DEFINITE ASSUMING THAT THE UPPER TRIANGLE OF ! THE SELF-ADJOINT MATRIX IS STORED IN PACKED FORM. ! do i = 1_i4b, n a_packed(i+((i-1_i4b)*i/2_i4b)) = real( n, stnd ) end do ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a(n,n), resid(n,n), resid2(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! UNPACKED AND SAVE RANDOM SELF-ADJOINT MATRIX a ! ASSUMING THAT THE UPPER TRIANGLE OF THE SELF-ADJOINT ! MATRIX IS STORED IN PACKED FORM. ! a(:n,:n) = unpack( a_packed(:p), mask=triangle( true, n, n, extra=1_i4b), field=zero ) ! do i = 1_i4b, n a(i+1_i4b:n,i) = a(i,i+1_i4b:n) end do ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! IF jobz='N' COMPUTE EIGENVALUES ONLY, ! IF jobz='V' COMPUTE EIGENVALUES AND EIGENVECTORS. ! jobz = 'V' ! ! IF uplo='U' UPPER TRIANGLE OF a IS STORED, ! IF uplo='L' LOWER TRIANGLE OF a IS STORED. ! uplo = 'U' ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR spevd SUBROUTINE. ! lwork = -1 liwork = -1 ! call spevd( jobz, uplo, n, a_packed, w, eigvec, n, work2, lwork, iwork2, liwork, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) + 10 liwork = iwork2(1) ! ! ALLOCATE WORK VARIABLES NEEDED BY syevd SUBROUTINE. ! allocate( work(lwork), iwork(liwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! COMPUTE EIGENVALUES AND EIGENVECTORS OF THE SELF-ADJOINT MATRIX a ! IN PACKED STORAGE WITH SUBROUTINE spevd FROM LAPACK. ! THE EIGENVALUE DECOMPOSITION OF A REAL n-BY-n SYMMETRIC MATRIX a ! IS WRITTEN ! ! a = U * D * U**(t) ! ! WHERE D IS AN n-BY-n DIAGONAL MATRIX AND U IS AN n-BY-n ORTHOGONAL MATRIX. ! THE DIAGONAL ELEMENTS OF D ARE THE EIGENVALUES OF a; THEY ARE REAL. ! THE COLUMNS OF U ARE THE EIGENVECTORS OF a. ! call spevd( jobz, uplo, n, a_packed, w, eigvec, n, work, lwork, iwork, liwork, info ) ! ! ON EXIT OF spevd : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! info=i > 0 : INDICATES THAT THE ALGORITHM FAILED TO CONVERGE. ! ! ON EXIT OF spevd : ! ! eigvec IS OVERWRITTEN WITH THE EIGENVECTORS OF a IF ! jobz='V' (THE EIGENVECTORS ARE STORED COLUMNWISE). ! ! w IS OVERWRITTEN WITH THE EIGENVALUES OF a IN ASCENDING ORDER. ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( work, iwork ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM spevd SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to SPEVD subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*U - U*D ! resid(:n,:n) = matmul(a(:n,:n),eigvec(:n,:n)) - eigvec(:n,:n)*spread(w,1,n) resid2(:n) = norm( resid(:n,:n), dim=2_i4b ) err1 = maxval( resid2(:n) )/( norm( a )*real(n,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U. ! call unit_matrix( a(:n,:n) ) ! resid(:n,:n) = abs( a(:n,:n) - matmul( transpose(eigvec(:n,:n)), eigvec(:n,:n) ) ) err2 = maxval( resid(:n,:n) )/real( n, stnd) ! err = max( err1, err2 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a_packed, eigvec, w, a, resid, resid2 ) else deallocate( a_packed, eigvec, w ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from spevd() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed eigenvalues and eigenvectors = ', err1 write (prtunit,*) 'Orthogonality of the computed eigenvectors = ', err2 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing ', n, ' eigenvalues and eigenvectors of a ', & n, ' by ', n,' real symmetric matrix in packed storage is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex1_lapack_spevd ! =============================== ! end program ex1_lapack_spevd
ex1_lapack_spevx.F90¶
program ex1_lapack_spevx ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutine SPEVX ! in LAPACK software for computing all or selected eigenvalues and, optionally, ! eigenvectors of a symmetric matrix stored in packed format. The eigenvalues ! and eigenvectors are computed by the bisection and inverse iteration methods. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : spevx ! use Statpack, only : lgl, i4b, stnd, true, false, zero, two, c50, norm, & safmin, merror, allocate_error, unit_matrix, triangle ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, n IS THE DIMENSION OF THE GENERATED SYMMETRIC MATRIX. ! integer(i4b), parameter :: prtunit = 6, n=3000, p=(n*(n+1))/2 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 1 of spevx' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, err1, err2, eps, abstol, vl, vu, elapsed_time real(stnd), dimension(:), allocatable :: a_packed, w, work, resid2 real(stnd), dimension(:,:), allocatable :: a, z, resid ! integer(i4b) :: info, i, il, iu, m, iok, istart, iend, irate, imax, itime integer(i4b), dimension(:), allocatable :: iwork, ifail ! logical(lgl) :: do_test ! character :: jobz, uplo, range ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : EIGENVALUES AND, OPTIONALLY, EIGENVECTORS OF A REAL SYMMETRIC ! MATRIX IN PACKED STORAGE USING THE BISECTION AND INVERSE ITERATION METHODS. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! abstol = two*safmin eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a_packed(p), z(n,n), w(n), work(8*n), iwork(5*n), ifail(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A RANDOM SELF-ADJOINT MATRIX a IN PACKED FORM. ! call random_number( a_packed(:p) ) ! ! MAKE a POSITIVE DEFINITE ASSUMING THAT THE UPPER TRIANGLE OF ! THE SELF-ADJOINT MATRIX IS STORED IN PACKED FORM. ! do i = 1_i4b, n a_packed(i+((i-1_i4b)*i/2_i4b)) = real( n, stnd ) end do ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a(n,n), resid(n,n), resid2(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! UNPACKED AND SAVE RANDOM SELF-ADJOINT MATRIX a ! ASSUMING THAT THE UPPER TRIANGLE OF THE SELF-ADJOINT ! MATRIX IS STORED IN PACKED FORM. ! a(:n,:n) = unpack( a_packed(:p), mask=triangle( true, n, n, extra=1_i4b), field=zero ) ! do i = 1_i4b, n a(i+1_i4b:n,i) = a(i,i+1_i4b:n) end do ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! FIRST DETERMINE THE WORK TO DO. ! ! IF jobz='N' COMPUTE EIGENVALUES ONLY, ! IF jobz='V' COMPUTE EIGENVALUES AND EIGENVECTORS. ! jobz = 'V' ! ! IF range='A' ALL EIGENVALUES WILL BE FOUND, ! IF range='V' ALL EIGENVALUES IN THE HALF OPEN INTERVAL (vl,vu] WILL BE FOUND, ! IF range='I' THE il-TH THROUGH iu-TH EIGENVALUES IN ASCENDING ORDER WILL BE FOUND. ! range = 'A' ! ! IF uplo='U' UPPER TRIANGLE OF a IS STORED, ! IF uplo='L' LOWER TRIANGLE OF a IS STORED. ! uplo = 'U' ! vl = zero vu = zero ! il = 1 iu = n ! ! COMPUTE EIGENVALUES AND EIGENVECTORS OF THE SELF-ADJOINT MATRIX a ! IN PACKED STORAGE WITH SUBROUTINE spevx FROM LAPACK. ! THE EIGENVALUE DECOMPOSITION OF A REAL n-BY-n SYMMETRIC MATRIX a ! IS WRITTEN ! ! a = U * D * U**(t) ! ! WHERE D IS AN n-BY-n DIAGONAL MATRIX AND U IS AN n-BY-n ORTHOGONAL MATRIX. ! THE DIAGONAL ELEMENTS OF D ARE THE EIGENVALUES OF a; THEY ARE REAL. ! THE COLUMNS OF U ARE THE EIGENVECTORS OF a. ! call spevx( jobz, range, uplo, n, a_packed, vl, vu, il, iu, abstol, & m, w, z, n, work, iwork, ifail, info ) ! ! ON EXIT OF spevx : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! info=i > 0 : INDICATES THAT i EIGENVECTORS FAILED TO CONVERGE AND ! THEIR INDICES ARE STORED IN ARRAY ifail. ! ! ON EXIT OF spevx : ! ! a_packed IS OVERWITTEN BY DETAILS OF ITS TRIDIAGONAL FACTORIZATION. ! ! m GIVES THE TOTAL NUMBER OF EIGENVALUES/EIGENVECTORS FOUND. ! ! z IS OVERWRITTEN WITH THE EIGENVECTORS ! OF a (THE EIGENVECTORS ARE STORED COLUMNWISE). ! ! w IS OVERWRITTEN WITH THE EIGENVALUES OF a IN ASCENDING ORDER, ! CORRESPONDING TO THE EIGENVECTORS IN z . ! ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM spevx SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to SPEVX subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*U - U*D ! resid(:n,:n) = matmul(a(:n,:n),z(:n,:n)) - z(:n,:n)*spread(w,1,n) resid2(:n) = norm( resid(:n,:n), dim=2_i4b ) err1 = maxval( resid2(:n) )/( norm( a )*real(n,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U. ! call unit_matrix( a(:n,:n) ) ! resid(:n,:n) = abs( a(:n,:n) - matmul( transpose(z(:n,:n)), z(:n,:n) ) ) err2 = maxval( resid(:n,:n) )/real( n, stnd) ! err = max( err1, err2 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a_packed, z, w, work, iwork, ifail, a, resid, resid2 ) else deallocate( a_packed, z, w, work, iwork, ifail ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from spevx() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed eigenvalues and eigenvectors = ', err1 write (prtunit,*) 'Orthogonality of the computed eigenvectors = ', err2 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing ', n, ' eigenvalues and eigenvectors of a ', & n, ' by ', n,' real symmetric matrix in packed storage is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex1_lapack_spevx ! =============================== ! end program ex1_lapack_spevx
ex1_lapack_stemr.F90¶
program ex1_lapack_stemr ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutines (x)SYTRD, (x)STEMR ! and (x)ORMTR in LAPACK software for computing all or selected eigenvalues and ! eigenvectors of a real symmetric matrix. The eigenvalues and eigenvectors ! are computed by the MRRR method. ! ! ! Further Details ! =============== ! ! The (x)STEMR subroutines will work properly only with IEEE arithmetic. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : sytrd, ormtr, stemr ! use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, unit_matrix, & merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, n IS THE DIMENSION OF THE GENERATED SYMMETRIC MATRIX ! neig IS THE NUMBER OF EIGENVECTORS, WHICH WILL BE COMPUTED WITH THE MRRR ALGORITHM. ! integer, parameter :: prtunit = 6, n=3000, neig=1000 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 1 of stemr' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err1, err2, err, eps, vl, vu, elapsed_time real(stnd) :: work2(1) real(stnd), allocatable, dimension(:) :: d, e, tau, w, work, resid real(stnd), allocatable, dimension(:,:) :: a, z, a2 ! integer :: info_trd, info_q, info_mrrr, lwork, liwork, lwork_trd, lwork_mrrr, lwork_q, & iok, istart, iend, irate, imax, itime, il, iu, m, nzc integer :: iwork2(1) integer, dimension(:), allocatable :: isuppz, iwork ! logical :: tryrac logical(lgl) :: do_test, failure ! character :: uplo, jobz, range ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : TRIDIAGONAL REDUCTION OF A REAL SYMMETRIC MATRIX AND, ! OPTIONALLY, neig EIGENVALUES AND EIGENVECTORS OF A REAL ! SYMMETRIC MATRIX USING THE MRRR METHOD. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a(n,n), z(n,neig), d(n), e(n), w(n), & isuppz(2*n), tau(n-1_i4b), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A n-by-n RANDOM DATA MATRIX AND ! FROM IT A SELF-ADJOINT MATRIX a . ! call random_number( a ) ! a = a + transpose( a ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(n,n), resid(neig), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SAVE THE SYMMETRIC MATRIX. ! a2(:n,:n) = a(:n,:n) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! IF uplo='U' UPPER TRIANGLE OF a IS STORED, ! IF uplo='L' LOWER TRIANGLE OF a IS STORED. ! uplo = 'U' ! ! FIRST DETERMINE THE WORK TO DO FOR stemr SUBROUTINE. ! ! IF jobz='N' COMPUTE EIGENVALUES ONLY, ! IF jobz='V' COMPUTE EIGENVALUES AND EIGENVECTORS. ! jobz = 'V' ! ! IF range='A' ALL EIGENVALUES WILL BE FOUND, ! IF range='V' ALL EIGENVALUES IN THE HALF OPEN INTERVAL (vl,vu) WILL BE FOUND, ! IF range='I' THE il-TH THROUGH iu-TH EIGENVALUES IN ASCENDING ORDER WILL BE FOUND. ! range = 'I' ! vl = zero vu = zero ! il = n - neig + 1 iu = n ! ! tryrac = .true. INDICATES THAT THE CODE WILL TRY TO COMPUTE THE EIGENVALUES OF THE TRIDIAGONAL MATRIX ! TO HIGH RELATIVE ACCURACY IF POSSIBLE. IF tryrac IS SET TO .false. THE CODE IS NOT REQUIRED ! TO GARANTEE RELATIVELY ACCURATE EIGENVALUES AND CAN USE A FASTEST METHOD. ! tryrac = .true. ! ! nzc IS AN UPPER BOUND FOR THE NUMBER OF EIGENVECTORS TO BE FOUND. nzc DEPENDS ON THE VALUE OF RANGE, IF: ! ! range='A' THEN nzc>=n; ! range='V' THEN nzc>=THE NUMBER OF EIGENVALUES IN (VL,VU], ! range='I' THEN nzc>=iu-il+1 . ! ! IF nzc=-1, THEN THE stemr SUBROUTINE WILL RETURN THE ESTIMATE OF nzc IN z(1,1) WITHOUT DOING ANY COMPUTATION. ! nzc = neig ! ! NOW COMPUTE OPTIMAL WORKSPACE FOR sytrd, stemr AND ormtr SUBROUTINES. ! lwork = -1 ! call sytrd( uplo, n, a, n, d, e, tau, work2, lwork, info=info_trd ) ! lwork_trd = int(work2(1)) ! call ormtr( 'L', uplo, 'N', n, neig, a, n, tau, z, n, work2, lwork, info=info_q ) ! lwork_q = int(work2(1)) ! liwork = -1 ! call stemr( jobz, range, n, d, e, vl, vu, il, iu, m, w, z, n, nzc, & isuppz, tryrac, work2, lwork, iwork2, liwork, info=info_mrrr ) ! lwork_mrrr = int(work2(1)) ! if ( info_trd==0 .and. info_q==0 .and. info_mrrr==0 ) then ! lwork = max( lwork_trd, lwork_q, lwork_mrrr ) liwork = iwork2(1) ! ! ALLOCATE OPTIMAL WORK VARIABLES NEEDED BY sytrd, stemr AND ormtr SUBROUTINES. ! allocate( work(lwork), iwork(liwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! CALL sytrd TO REDUCE THE MATRIX a TO TRIDIAGONAL FORM ! ! a = Q*TRID*Q**(t) ! ! WHERE Q IS ORTHOGONAL AND TRID IS A SYMMETRIC TRIDIAGONAL MATRIX. ! call sytrd( uplo, n, a, n, d, e, tau, work(:lwork_trd), lwork_trd, info=info_trd ) ! ! ON EXIT OF sytrd : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! ! d AND e ARE THE DIAGONAL AND OFF-DIAGONAL ELEMENTS OF THE SYMMETRIC TRIDIAGONAL MATRIX, RESPECTIVELY. ! a CONTAINS THE ELEMENTARY REFLECTORS WHICH DEFINE Q IN ITS UPPER TRIANGLE IF uplo='U'. ! tau CONTAINS THE SCALAR FACTORS OF THE ELEMENTARY REFLECTORS WHICH DEFINE Q. ! ! ! COMPUTE neig EIGENVALUES AND EIGENVECTORS OF THE SYMMETRIC TRIDIAGONAL MATRIX WITH SUBROUTINE stemr. ! THE EIGENVALUE DECOMPOSITION OF A REAL n-BY-n SYMMETRIC TRIDIAGONAL MATRIX TRID ! IS WRITTEN ! ! TRID = U * D * U**(t) ! ! WHERE D IS AN n-BY-n DIAGONAL MATRIX AND U IS AN n-BY-n ORTHOGONAL MATRIX. ! THE DIAGONAL ELEMENTS OF D ARE THE EIGENVALUES OF TRID; THEY ARE REAL. ! THE COLUMNS OF U ARE THE EIGENVECTORS OF TRID. ! call stemr( jobz, range, n, d, e, vl, vu, il, iu, m, w, z, n, nzc, isuppz, tryrac, & work(:lwork_mrrr), lwork_mrrr, iwork, liwork, info=info_mrrr ) ! ! ON EXIT OF stemr : ! ! info= 0 : INDICATES SUCCESSFUL EXIT. ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE. ! info=i > 0 : INDICATES THAT THE ALGORITHM FAILED TO CONVERGE. ! ! ON EXIT OF stemr : ! ! m GIVES THE TOTAL NUMBER OF EIGENVALUES/EIGENVECTORS FOUND. ! ! z IS OVERWRITTEN WITH THE FIRST m EIGENVECTORS ! OF THE TRIDIAGONAL MATRIX (THE EIGENVECTORS ARE STORED COLUMNWISE). ! ! w IS OVERWRITTEN WITH THE EIGENVALUES OF THE TRIDIAGONAL MATRIX IN ASCENDING ORDER, ! CORRESPONDING TO THE EIGENVECTORS IN z . ! ! COMPUTE THE FIRST m EIGENVECTORS OF THE SELF-ADJOINT MATRIX a BY ! BACK-TRANSFORMATION WITH LAPACK SUBROUTINE ormtr. ! call ormtr( 'L', uplo, 'N', n, m, a, n, tau, z, n, work(:lwork_q), lwork_q, info=info_q ) ! ! ON EXIT OF THIS ormtr CALL: ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! ! z IS OVERWRITTEN WITH THE FIRST m EIGENVECTORS OF a STORED COLUMNWISE. ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( work, iwork ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! failure = info_trd/=0 .or. info_q/=0 .or. info_mrrr/=0 ! if ( failure ) then ! ! ANORMAL EXIT FROM sytrd, stemr OR ormtr SUBROUTINES, PRINT A WARNING. ! write (prtunit,*) 'Errors in the calls to SYTRD, STEMR or ORMTR subroutines, Info=', & info_trd, info_mrrr, info_q ! if ( info_trd<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value in SYTRD'')') - info_trd ! end if ! if ( info_mrrr<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value in STEMR'')') - info_mrrr ! end if ! if ( info_q<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value in ORMTR'')') - info_q ! end if ! else if ( do_test ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*eigvec - eigvec*diag(eigval(:m)) ! WHERE eigval ARE THE EIGENVALUES AND eigvec THE EIGENVECTORS OF a. ! a(:n,:m) = matmul( a2, z(:n,:m) ) - z(:n,:m)*spread( w(:m), dim=1, ncopies=n ) ! resid(:m) = norm( a(:n,:m), dim=2_i4b ) err1 = maxval( resid(:m) )/( norm(a2)*real(n,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - eigvec**(t)*eigvec ! WHERE eigvec are THE EIGENVECTORS OF THE MATRIX a. ! call unit_matrix( a(:m,:m) ) ! a2(:m,:m) = abs( a(:m,:m) - matmul( transpose( z(:n,:m) ), z(:n,:m) ) ) err2 = maxval( a2(:m,:m) )/real(n,stnd) ! err = max( err1, err2 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, z, d, e, tau, w, isuppz, a2, resid ) else deallocate( a, z, d, e, tau, w, isuppz ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. .not.failure ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from sytrd() ) = ', info_trd write (prtunit,*) ' INFO ( from stemr() ) = ', info_mrrr write (prtunit,*) ' INFO ( from ormtr() ) = ', info_q ! if ( do_test .and. .not.failure ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed eigenvalues and eigenvectors = ', err1 write (prtunit,*) 'Orthogonality of the computed eigenvectors = ', err2 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing ', m,' eigenvalues and eigenvectors of a', & n, ' by', n,' real symmetric matrix is', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex1_lapack_stemr ! =============================== ! end program ex1_lapack_stemr
ex1_lapack_syev.F90¶
program ex1_lapack_syev ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutine SYEV ! in LAPACK software for computing all eigenvalues and, optionally, ! eigenvectors of a symmetric matrix. The eigenvalues and ! eigenvectors are computed by the tridiagonal QR implicit method. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : syev ! use Statpack, only : lgl, i4b, stnd, true, false, zero, one, seven, c30, c50, c1_e6, & norm, unit_matrix, random_seed_, random_number_, gen_random_sym_mat, & merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! #ifdef _F2003 use ieee_arithmetic, only : ieee_support_datatype, ieee_is_normal #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, n IS THE DIMENSION OF THE GENERATED SYMMETRIC MATRIX, ! neig0 IS THE NUMERICAL RANK OF THE GENERATED SYMMETRIC MATRIX (WHICH MUST BE LESS OR EQUAL TO n) ! FOR CASES GREATER THAN 0. ! integer(i4b), parameter :: prtunit=6, n=3000, neig0=3000 ! ! conda IS THE CONDITION NUMBER OF THE GENERATED MATRIX IN CASES 5, 6 and 7, ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50, conda=c1_e6 ! character(len=*), parameter :: name_proc='Example 1 of syev' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, err1, err2, eps, tmp, tmp2, ulp, & anorm, elapsed_time real(stnd) :: work2(1) real(stnd), dimension(:), allocatable :: w, work, resid2 real(stnd), dimension(:,:), allocatable :: a, a2, resid ! integer :: info, lwork, iok, istart, iend, irate, imax, itime integer(i4b) :: i, mat_type ! logical(lgl) :: do_test ! character :: jobz, uplo ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : EIGENVALUES AND, OPTIONALLY, EIGENVECTORS OF A REAL SYMMETRIC ! MATRIX USING THE TRIDIAGONAL QR IMPLICIT METHOD. ! ! SPECIFY THE TYPE OF INPUT SYMMETRIC MATRIX: ! ! mat_type < 1 -> RANDOM SYMMETRIC MATRIX FROM THE UNIFORM DISTRIBUTION ! mat_type = 1 -> SLOW DECAY OF EIGENVALUES ! mat_type = 2 -> FAST DECAY OF EIGENVALUES ! mat_type = 3 -> S-SHAPED DECAY OF EIGENVALUES ! mat_type = 4 -> VERY SLOW DECAY OF EIGENVALUES ! mat_type = 5 -> STRONGLY CLUSTERED EIGENVALUES AT 1 WITH CONDITION NUMBER conda ! SPECTRUM WITH FEW DEFLATIONS FOR LAPACK SYESVD ROUTINE ! mat_type = 6 -> GEOMETRIC DISTRIBUTION OF EIGENVALUES WITH CONDITION NUMBER conda ! SPECTRUM WITH MODERATE DEFLATION FOR LAPACK SYESVD ROUTINE ! mat_type = 7 -> ARITHMETIC DISTRIBUTION OF EIGENVALUES WITH CONDITION NUMBER conda ! SPECTRUM WITH COMPLETE DEFLATION FOR LAPACK SYESVD ROUTINE ! mat_type > 7 -> UNIFORM DISTRIBUTION OF EIGENVALUES ! mat_type = 2_i4b ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! ulp = epsilon( err ) eps = fudge*ulp err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a(n,n), w(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SELECT THE UNIFORM RANDOM GENERATOR TO BE USED. ! call random_seed_( alg=3 ) ! ! RESET THE SEEDS USED BY THE UNIFORM RANDOM GENERATOR. ! call random_seed_() ! ! GENERATE A RANDOM UNIFORM SYMMETRIC MATRIX OR EIGENVALUES. ! select case( mat_type ) ! case( :0_i4b ) ! ! RANDOM UNIFORM SYMMETRIC MATRIX. ! call random_number_( a ) ! a = a + transpose( a ) ! ! COMPUTE THE FROBENIUS NORM OF THE RANDOM SYMMETRIC MATRIX. ! anorm = norm( a ) ! case( 1_i4b ) ! ! SLOW DECAY OF EIGENVALUES. ! do i = 1_i4b, neig0 ! tmp = real( i, stnd ) ! w(i) = one/( tmp*tmp ) ! end do ! case( 2_i4b ) ! ! FAST DECAY OF EIGENVALUES. ! do i = 1_i4b, neig0 ! tmp = real( i, stnd ) ! w(i) = exp( -tmp/seven ) ! end do ! case( 3_i4b ) ! ! S-SHAPED DECAY OF EIGENVALUES. ! do i = 1_i4b, neig0 ! tmp = real( i, stnd ) ! w(i) = 0.0001_stnd + one/( one + exp( tmp - c30 ) ) ! end do ! case( 4_i4b ) ! ! VERY SLOW DECAY OF EIGENVALUES. ! tmp = real( neig0 - 1_i4b, stnd ) ! do i = 1_i4b, neig0 ! tmp2 = real( i - 1_i4b, stnd ) ! w(i) = exp( -tmp2/tmp ) ! end do ! case( 5_i4b ) ! ! STRONGLY CLUSTERED EIGENVALUES AT 1 WITH CONDITION NUMBER conda. ! THIS IS A SPECTRUM WITH FEW DEFLATIONS FOR LAPACK SYESVD ROUTINE. ! w(:neig0-1_i4b) = one w(neig0) = one/conda ! case( 6_i4b ) ! ! GEOMETRIC DISTRIBUTION OF EIGENVALUES WITH CONDITION NUMBER conda. ! THIS IS A SPECTRUM WITH MODERATE DEFLATION FOR LAPACK SYESVD ROUTINE. ! tmp = real( neig0 - 1_i4b, stnd ) ! do i = 1_i4b, neig0 ! tmp2 = real( i - 1_i4b, stnd ) ! w(i) = conda**( -tmp2/tmp ) ! end do ! case( 7_i4b ) ! ! ARITHMETIC DISTRIBUTION OF EIGENVALUES WITH CONDITION NUMBER conda. ! THIS IS A SPECTRUM WITH COMPLETE DEFLATION FOR LAPACK SYESVD ROUTINE. ! tmp = real( neig0 - 1_i4b, stnd ) tmp2 = one - one/conda ! do i = 1_i4b, neig0 ! w(i) = one - (real( i - 1_i4b, stnd )/tmp)*tmp2 ! end do ! case default ! ! UNIFORM DISTRIBUTION OF EIGENVALUES. ! call random_number_( w(:neig0) ) ! end select ! if ( mat_type>0_i4b ) then ! #ifdef _F2003 if ( ieee_support_datatype( w ) ) then ! if ( .not.all( ieee_is_normal( w(:neig0) ) ) ) then ! call merror( name_proc//' : Exceptions occurred when generating the input symmetric matrix !' ) ! end if ! end if #endif ! ! GENERATE A n-BY-n RANDOM REAL SYMMETRIC MATRIX a WITH A SPECIFIED DISTRIBUTION ! OF EIGENVALUES AND A RANK EQUAL TO neig0. ! call gen_random_sym_mat( w(:neig0), a ) ! ! COMPUTE THE FROBENIUS NORM OF THE MATRIX. ! anorm = norm( w(:neig0) ) ! end if ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(n,n), resid(n,n), resid2(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! MAKE A COPY OF THE RANDOM SELF-ADJOINT MATRIX a . ! a2(:n,:n) = a(:n,:n) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! IF jobz='N' COMPUTE EIGENVALUES ONLY, ! IF jobz='V' COMPUTE EIGENVALUES AND EIGENVECTORS. ! jobz = 'V' ! ! IF uplo='U' UPPER TRIANGLE OF a IS STORED, ! IF uplo='L' LOWER TRIANGLE OF a IS STORED. ! uplo = 'U' ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR syev SUBROUTINE. ! lwork = -1 ! call syev( jobz, uplo, n, a, n, w, work2, lwork, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) ! ! ALLOCATE WORK VARIABLE NEEDED BY syev SUBROUTINE. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! COMPUTE EIGENVALUES AND EIGENVECTORS OF THE SELF-ADJOINT MATRIX a ! WITH SUBROUTINE syev FROM LAPACK. ! THE EIGENVALUE DECOMPOSITION OF A REAL n-BY-n SYMMETRIC MATRIX a ! IS WRITTEN ! ! a = U * D * U**(t) ! ! WHERE D IS AN n-BY-n DIAGONAL MATRIX AND U IS AN n-BY-n ORTHOGONAL MATRIX. ! THE DIAGONAL ELEMENTS OF D ARE THE EIGENVALUES OF a; THEY ARE REAL. ! THE COLUMNS OF U ARE THE EIGENVECTORS OF a. ! call syev( jobz, uplo, n, a, n, w, work, lwork, info ) ! ! ON EXIT OF syev : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! info=i > 0 : INDICATES THAT THE ALGORITHM FAILED TO CONVERGE ! AND i OFF-DIAGONAL ELEMENTS OF AN INTERMEDIATE ! TRIDIAGONAL FORM OF a DID NOT CONVERGE TO ZERO. ! ! ON EXIT OF syev : ! ! a IS OVERWRITTEN WITH THE EIGENVECTORS OF a IF ! jobz='V' (THE EIGENVECTORS ARE STORED COLUMNWISE). ! ! w IS OVERWRITTEN WITH THE EIGENVALUES OF a IN ASCENDING ORDER. ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM syev SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to SYEV subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*U - U*D ! resid(:n,:n) = matmul(a2(:n,:n),a(:n,:n)) - a(:n,:n)*spread(w,1,n) resid2(:n) = norm( resid(:n,:n), dim=2_i4b ) err1 = maxval( resid2(:n) )/( anorm*real(n,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U. ! call unit_matrix( a2(:n,:n) ) ! resid(:n,:n) = abs( a2(:n,:n) - matmul( transpose(a(:n,:n)), a(:n,:n) ) ) err2 = maxval( resid(:n,:n) )/real(n,stnd) ! err = max( err1, err2 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, w, a2, resid, resid2 ) else deallocate( a, w ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' Matrix type = ', mat_type ! write (prtunit,*) write (prtunit,*) ' Matrix_type < 1 -> random symmetric matrix from the uniform distribution' write (prtunit,*) ' Matrix type = 1 -> slow decay of eigenvalues' write (prtunit,*) ' Matrix type = 2 -> fast decay of eigenvalues' write (prtunit,*) ' Matrix type = 3 -> s-shaped decay of eigenvalues' write (prtunit,*) ' Matrix type = 4 -> very slow decay of eigenvalues' write (prtunit,*) ' Matrix type = 5 -> strongly clustered eigenvalues at 1' write (prtunit,*) ' spectrum with few deflations (for LAPACK SYESVD routine)' write (prtunit,*) ' Matrix type = 6 -> geometric distribution of eigenvalues' write (prtunit,*) ' spectrum with moderate deflation (for LAPACK SYESVD routine)' write (prtunit,*) ' Matrix type = 7 -> arithmetic distribution of eigenvalues' write (prtunit,*) ' spectrum with complete deflation (for LAPACK SYESVD routine)' write (prtunit,*) ' Matrix type > 7 -> uniform distribution of eigenvalues' ! write (prtunit,*) write (prtunit,*) ' INFO ( from syev() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed eigenvalues and eigenvectors = ', err1 write (prtunit,*) 'Orthogonality of the computed eigenvectors = ', err2 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing ', n, ' eigenvalues and eigenvectors of a ', & n, ' by ', n,' real symmetric matrix is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex1_lapack_syev ! ============================== ! end program ex1_lapack_syev
ex1_lapack_syevd.F90¶
program ex1_lapack_syevd ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutine SYEVD ! in LAPACK software for computing all eigenvalues and, optionally, ! eigenvectors of a real symmetric matrix. The eigenvalues and ! eigenvectors are computed by the divide and conquer method. ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : syevd ! use Statpack, only : lgl, i4b, stnd, true, false, zero, one, seven, c30, c50, c1_e6, & norm, unit_matrix, random_seed_, random_number_, gen_random_sym_mat, & merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! #ifdef _F2003 use ieee_arithmetic, only : ieee_support_datatype, ieee_is_normal #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, n IS THE DIMENSION OF THE GENERATED SYMMETRIC MATRIX, ! neig0 IS THE NUMERICAL RANK OF THE GENERATED SYMMETRIC MATRIX (WHICH MUST BE LESS OR EQUAL TO n) ! FOR CASES GREATER THAN 0. ! integer(i4b), parameter :: prtunit=6, n=3000, neig0=3000 ! ! conda IS THE CONDITION NUMBER OF THE GENERATED MATRIX IN CASES 5, 6 and 7, ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50, conda=c1_e6 ! character(len=*), parameter :: name_proc='Example 1 of syevd' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, err1, err2, eps, tmp, tmp2, ulp, & anorm, elapsed_time real(stnd) :: work2(1) real(stnd), dimension(:), allocatable :: w, work, resid2 real(stnd), dimension(:,:), allocatable :: a, a2, resid ! integer :: info, lwork, liwork, iok, istart, iend, irate, imax, itime integer :: iwork2(1) integer, dimension(:), allocatable :: iwork integer(i4b) :: i, mat_type ! logical(lgl) :: do_test ! character :: jobz, uplo ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : EIGENVALUES AND, OPTIONALLY, EIGENVECTORS OF A REAL SYMMETRIC ! MATRIX USING THE DIVIDE AND CONQUER METHOD. ! ! SPECIFY THE TYPE OF INPUT SYMMETRIC MATRIX: ! ! mat_type < 1 -> RANDOM SYMMETRIC MATRIX FROM THE UNIFORM DISTRIBUTION ! mat_type = 1 -> SLOW DECAY OF EIGENVALUES ! mat_type = 2 -> FAST DECAY OF EIGENVALUES ! mat_type = 3 -> S-SHAPED DECAY OF EIGENVALUES ! mat_type = 4 -> VERY SLOW DECAY OF EIGENVALUES ! mat_type = 5 -> STRONGLY CLUSTERED EIGENVALUES AT 1 WITH CONDITION NUMBER conda ! SPECTRUM WITH FEW DEFLATIONS FOR LAPACK SYESVD ROUTINE ! mat_type = 6 -> GEOMETRIC DISTRIBUTION OF EIGENVALUES WITH CONDITION NUMBER conda ! SPECTRUM WITH MODERATE DEFLATION FOR LAPACK SYESVD ROUTINE ! mat_type = 7 -> ARITHMETIC DISTRIBUTION OF EIGENVALUES WITH CONDITION NUMBER conda ! SPECTRUM WITH COMPLETE DEFLATION FOR LAPACK SYESVD ROUTINE ! mat_type > 7 -> UNIFORM DISTRIBUTION OF EIGENVALUES ! mat_type = 2_i4b ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! ulp = epsilon( err ) eps = fudge*ulp err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a(n,n), w(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SELECT THE UNIFORM RANDOM GENERATOR TO BE USED. ! call random_seed_( alg=3 ) ! ! RESET THE SEEDS USED BY THE UNIFORM RANDOM GENERATOR. ! call random_seed_() ! ! GENERATE A RANDOM UNIFORM SYMMETRIC MATRIX OR EIGENVALUES. ! select case( mat_type ) ! case( :0_i4b ) ! ! RANDOM UNIFORM SYMMETRIC MATRIX. ! call random_number_( a ) ! a = a + transpose( a ) ! ! COMPUTE THE FROBENIUS NORM OF THE RANDOM SYMMETRIC MATRIX. ! anorm = norm( a ) ! case( 1_i4b ) ! ! SLOW DECAY OF EIGENVALUES. ! do i = 1_i4b, neig0 ! tmp = real( i, stnd ) ! w(i) = one/( tmp*tmp ) ! end do ! case( 2_i4b ) ! ! FAST DECAY OF EIGENVALUES. ! do i = 1_i4b, neig0 ! tmp = real( i, stnd ) ! w(i) = exp( -tmp/seven ) ! end do ! case( 3_i4b ) ! ! S-SHAPED DECAY OF EIGENVALUES. ! do i = 1_i4b, neig0 ! tmp = real( i, stnd ) ! w(i) = 0.0001_stnd + one/( one + exp( tmp - c30 ) ) ! end do ! case( 4_i4b ) ! ! VERY SLOW DECAY OF EIGENVALUES. ! tmp = real( neig0 - 1_i4b, stnd ) ! do i = 1_i4b, neig0 ! tmp2 = real( i - 1_i4b, stnd ) ! w(i) = exp( -tmp2/tmp ) ! end do ! case( 5_i4b ) ! ! STRONGLY CLUSTERED EIGENVALUES AT 1 WITH CONDITION NUMBER conda. ! THIS IS A SPECTRUM WITH FEW DEFLATIONS FOR LAPACK SYESVD ROUTINE. ! w(:neig0-1_i4b) = one w(neig0) = one/conda ! case( 6_i4b ) ! ! GEOMETRIC DISTRIBUTION OF EIGENVALUES WITH CONDITION NUMBER conda. ! THIS IS A SPECTRUM WITH MODERATE DEFLATION FOR LAPACK SYESVD ROUTINE. ! tmp = real( neig0 - 1_i4b, stnd ) ! do i = 1_i4b, neig0 ! tmp2 = real( i - 1_i4b, stnd ) ! w(i) = conda**( -tmp2/tmp ) ! end do ! case( 7_i4b ) ! ! ARITHMETIC DISTRIBUTION OF EIGENVALUES WITH CONDITION NUMBER conda. ! THIS IS A SPECTRUM WITH COMPLETE DEFLATION FOR LAPACK SYESVD ROUTINE. ! tmp = real( neig0 - 1_i4b, stnd ) tmp2 = one - one/conda ! do i = 1_i4b, neig0 ! w(i) = one - (real( i - 1_i4b, stnd )/tmp)*tmp2 ! end do ! case default ! ! UNIFORM DISTRIBUTION OF EIGENVALUES. ! call random_number_( w(:neig0) ) ! end select ! if ( mat_type>0_i4b ) then ! #ifdef _F2003 if ( ieee_support_datatype( w ) ) then ! if ( .not.all( ieee_is_normal( w(:neig0) ) ) ) then ! call merror( name_proc//' : Exceptions occurred when generating the input symmetric matrix !' ) ! end if ! end if #endif ! ! GENERATE A n-BY-n RANDOM REAL SYMMETRIC MATRIX a WITH A SPECIFIED DISTRIBUTION ! OF EIGENVALUES AND A RANK EQUAL TO neig0. ! call gen_random_sym_mat( w(:neig0), a ) ! ! COMPUTE THE FROBENIUS NORM OF THE MATRIX. ! anorm = norm( w(:neig0) ) ! end if ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(n,n), resid(n,n), resid2(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! MAKE A COPY OF THE RANDOM SELF-ADJOINT MATRIX. ! a2(:n,:n) = a(:n,:n) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! IF jobz='N' COMPUTE EIGENVALUES ONLY, ! IF jobz='V' COMPUTE EIGENVALUES AND EIGENVECTORS. ! jobz = 'V' ! ! IF uplo='U' UPPER TRIANGLE OF a IS STORED, ! IF uplo='L' LOWER TRIANGLE OF a IS STORED. ! uplo = 'U' ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR syevd SUBROUTINE. ! lwork = -1 liwork = -1 ! call syevd( jobz, uplo, n, a, n, w, work2, lwork, iwork2, liwork, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) + 10 liwork = iwork2(1) ! ! ALLOCATE WORK VARIABLES NEEDED BY syevd SUBROUTINE. ! allocate( work(lwork), iwork(liwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! COMPUTE EIGENVALUES AND EIGENVECTORS OF THE SELF-ADJOINT MATRIX a ! WITH SUBROUTINE syevd FROM LAPACK. ! THE EIGENVALUE DECOMPOSITION OF A REAL n-BY-n SYMMETRIC MATRIX a ! IS WRITTEN ! ! a = U * D * U**(t) ! ! WHERE D IS AN n-BY-n DIAGONAL MATRIX AND U IS AN n-BY-n ORTHOGONAL MATRIX. ! THE DIAGONAL ELEMENTS OF D ARE THE EIGENVALUES OF a; THEY ARE REAL. ! THE COLUMNS OF U ARE THE EIGENVECTORS OF a. ! call syevd( jobz, uplo, n, a, n, w, work, lwork, iwork, liwork, info ) ! ! ON EXIT OF syevd : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! info=i > 0 : INDICATES THAT THE ALGORITHM FAILED TO CONVERGE. ! ! ON EXIT OF syevd : ! ! a IS OVERWRITTEN WITH THE EIGENVECTORS OF a IF ! jobz='V' (THE EIGENVECTORS ARE STORED COLUMNWISE). ! ! w IS OVERWRITTEN WITH THE EIGENVALUES OF a IN ASCENDING ORDER. ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( work, iwork ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM syevd SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to SYEVD subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*U - U*D ! resid(:n,:n) = matmul(a2(:n,:n),a(:n,:n)) - a(:n,:n)*spread(w,1,n) resid2(:n) = norm( resid(:n,:n), dim=2_i4b ) err1 = maxval( resid2(:n) )/( anorm*real(n,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U. ! call unit_matrix( a2(:n,:n) ) ! resid(:n,:n) = abs( a2(:n,:n) - matmul( transpose(a(:n,:n)), a(:n,:n) ) ) err2 = maxval( resid(:n,:n) )/real(n,stnd) ! err = max( err1, err2 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, w, a2, resid, resid2 ) else deallocate( a, w ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' Matrix type = ', mat_type ! write (prtunit,*) write (prtunit,*) ' Matrix_type < 1 -> random symmetric matrix from the uniform distribution' write (prtunit,*) ' Matrix type = 1 -> slow decay of eigenvalues' write (prtunit,*) ' Matrix type = 2 -> fast decay of eigenvalues' write (prtunit,*) ' Matrix type = 3 -> s-shaped decay of eigenvalues' write (prtunit,*) ' Matrix type = 4 -> very slow decay of eigenvalues' write (prtunit,*) ' Matrix type = 5 -> strongly clustered eigenvalues at 1' write (prtunit,*) ' spectrum with few deflations (for LAPACK SYESVD routine)' write (prtunit,*) ' Matrix type = 6 -> geometric distribution of eigenvalues' write (prtunit,*) ' spectrum with moderate deflation (for LAPACK SYESVD routine)' write (prtunit,*) ' Matrix type = 7 -> arithmetic distribution of eigenvalues' write (prtunit,*) ' spectrum with complete deflation (for LAPACK SYESVD routine)' write (prtunit,*) ' Matrix type > 7 -> uniform distribution of eigenvalues' ! write (prtunit,*) write (prtunit,*) ' INFO ( from syevd() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed eigenvalues and eigenvectors = ', err1 write (prtunit,*) 'Orthogonality of the computed eigenvectors = ', err2 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing ', n, ' eigenvalues and eigenvectors of a ', & n, ' by ', n,' real symmetric matrix is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex1_lapack_syevd ! =============================== ! end program ex1_lapack_syevd
ex1_lapack_syevr.F90¶
program ex1_lapack_syevr ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutine SYEVR ! in LAPACK software for computing all eigenvalues and, optionally, ! eigenvectors of a real symmetric matrix. The eigenvalues and ! eigenvectors are computed by the MRRR method. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : syevr ! use Statpack, only : lgl, i4b, stnd, true, false, zero, one, two, seven, c30, c50, c1_e6, & safmin, norm, unit_matrix, random_seed_, random_number_, & gen_random_sym_mat, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! #ifdef _F2003 use ieee_arithmetic, only : ieee_support_datatype, ieee_is_normal #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, n IS THE DIMENSION OF THE GENERATED SYMMETRIC MATRIX, ! neig0 IS THE NUMERICAL RANK OF THE GENERATED SYMMETRIC MATRIX (WHICH MUST BE LESS OR EQUAL TO n) ! FOR CASES GREATER THAN 0. ! integer(i4b), parameter :: prtunit=6, n=3000, neig0=3000 ! ! conda IS THE CONDITION NUMBER OF THE GENERATED MATRIX IN CASES 5, 6 and 7, ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50, conda=c1_e6 ! character(len=*), parameter :: name_proc='Example 1 of syevr' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, err1, err2, eps, abstol, vl, vu, tmp, tmp2, & ulp, anorm, elapsed_time real(stnd) :: work2(1) real(stnd), dimension(:), allocatable :: w, work, resid2 real(stnd), dimension(:,:), allocatable :: a, a2, z ! integer :: info, lwork, liwork, iok, il, iu, m, & istart, iend, irate, imax, itime integer :: iwork2(1) integer, dimension(:), allocatable :: isuppz, iwork integer(i4b) :: i, mat_type ! logical(lgl) :: do_test ! character :: jobz, uplo, range ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : EIGENVALUES AND, OPTIONALLY, EIGENVECTORS OF A REAL SYMMETRIC ! MATRIX USING THE MRRR ALGORITHM. ! ! SPECIFY THE TYPE OF INPUT SYMMETRIC MATRIX: ! ! mat_type < 1 -> RANDOM SYMMETRIC MATRIX FROM THE UNIFORM DISTRIBUTION ! mat_type = 1 -> SLOW DECAY OF EIGENVALUES ! mat_type = 2 -> FAST DECAY OF EIGENVALUES ! mat_type = 3 -> S-SHAPED DECAY OF EIGENVALUES ! mat_type = 4 -> VERY SLOW DECAY OF EIGENVALUES ! mat_type = 5 -> STRONGLY CLUSTERED EIGENVALUES AT 1 WITH CONDITION NUMBER conda ! SPECTRUM WITH FEW DEFLATIONS FOR LAPACK SYESVD ROUTINE ! mat_type = 6 -> GEOMETRIC DISTRIBUTION OF EIGENVALUES WITH CONDITION NUMBER conda ! SPECTRUM WITH MODERATE DEFLATION FOR LAPACK SYESVD ROUTINE ! mat_type = 7 -> ARITHMETIC DISTRIBUTION OF EIGENVALUES WITH CONDITION NUMBER conda ! SPECTRUM WITH COMPLETE DEFLATION FOR LAPACK SYESVD ROUTINE ! mat_type > 7 -> UNIFORM DISTRIBUTION OF EIGENVALUES ! mat_type = 6_i4b ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! abstol = two*safmin ulp = epsilon( err ) eps = fudge*ulp err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a(n,n), z(n,n), w(n), isuppz(2*n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SELECT THE UNIFORM RANDOM GENERATOR TO BE USED. ! call random_seed_( alg=3 ) ! ! RESET THE SEEDS USED BY THE UNIFORM RANDOM GENERATOR. ! call random_seed_() ! ! GENERATE A RANDOM UNIFORM SYMMETRIC MATRIX OR EIGENVALUES. ! select case( mat_type ) ! case( :0_i4b ) ! ! RANDOM UNIFORM SYMMETRIC MATRIX. ! call random_number_( z ) ! a = z + transpose( z ) ! ! COMPUTE THE FROBENIUS NORM OF THE RANDOM SYMMETRIC MATRIX. ! anorm = norm( a ) ! case( 1_i4b ) ! ! SLOW DECAY OF EIGENVALUES. ! do i = 1_i4b, neig0 ! tmp = real( i, stnd ) ! w(i) = one/( tmp*tmp ) ! end do ! case( 2_i4b ) ! ! FAST DECAY OF EIGENVALUES. ! do i = 1_i4b, neig0 ! tmp = real( i, stnd ) ! w(i) = exp( -tmp/seven ) ! end do ! case( 3_i4b ) ! ! S-SHAPED DECAY OF EIGENVALUES. ! do i = 1_i4b, neig0 ! tmp = real( i, stnd ) ! w(i) = 0.0001_stnd + one/( one + exp( tmp - c30 ) ) ! end do ! case( 4_i4b ) ! ! VERY SLOW DECAY OF EIGENVALUES. ! tmp = real( neig0 - 1_i4b, stnd ) ! do i = 1_i4b, neig0 ! tmp2 = real( i - 1_i4b, stnd ) ! w(i) = exp( -tmp2/tmp ) ! end do ! case( 5_i4b ) ! ! STRONGLY CLUSTERED EIGENVALUES AT 1 WITH CONDITION NUMBER conda. ! THIS IS A SPECTRUM WITH FEW DEFLATIONS FOR LAPACK SYESVD ROUTINE. ! w(:neig0-1_i4b) = one w(neig0) = one/conda ! case( 6_i4b ) ! ! GEOMETRIC DISTRIBUTION OF EIGENVALUES WITH CONDITION NUMBER conda. ! THIS IS A SPECTRUM WITH MODERATE DEFLATION FOR LAPACK SYESVD ROUTINE. ! tmp = real( neig0 - 1_i4b, stnd ) ! do i = 1_i4b, neig0 ! tmp2 = real( i - 1_i4b, stnd ) ! w(i) = conda**( -tmp2/tmp ) ! end do ! case( 7_i4b ) ! ! ARITHMETIC DISTRIBUTION OF EIGENVALUES WITH CONDITION NUMBER conda. ! THIS IS A SPECTRUM WITH COMPLETE DEFLATION FOR LAPACK SYESVD ROUTINE. ! tmp = real( neig0 - 1_i4b, stnd ) tmp2 = one - one/conda ! do i = 1_i4b, neig0 ! w(i) = one - (real( i - 1_i4b, stnd )/tmp)*tmp2 ! end do ! case default ! ! UNIFORM DISTRIBUTION OF EIGENVALUES. ! call random_number_( w(:neig0) ) ! end select ! if ( mat_type>0_i4b ) then ! #ifdef _F2003 if ( ieee_support_datatype( w ) ) then ! if ( .not.all( ieee_is_normal( w(:neig0) ) ) ) then ! call merror( name_proc//' : Exceptions occurred when generating the input symmetric matrix !' ) ! end if ! end if #endif ! ! GENERATE A n-BY-n RANDOM REAL SYMMETRIC MATRIX a WITH A SPECIFIED DISTRIBUTION ! OF EIGENVALUES AND A RANK EQUAL TO neig0. ! call gen_random_sym_mat( w(:neig0), a ) ! ! COMPUTE THE FROBENIUS NORM OF THE MATRIX. ! anorm = norm( w(:neig0) ) ! end if ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(n,n), resid2(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! MAKE A COPY OF THE RANDOM SELF-ADJOINT MATRIX. ! a2(:n,:n) = a(:n,:n) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! FIRST DETERMINE THE WORK TO DO. ! ! IF jobz='N' COMPUTE EIGENVALUES ONLY, ! IF jobz='V' COMPUTE EIGENVALUES AND EIGENVECTORS. ! jobz = 'V' ! ! IF range='A' ALL EIGENVALUES WILL BE FOUND, ! IF range='V' ALL EIGENVALUES IN THE HALF OPEN INTERVAL (vl,vu) WILL BE FOUND, ! IF range='I' THE il-TH THROUGH iu-TH EIGENVALUES IN ASCENDING ORDER WILL BE FOUND. ! range = 'A' ! ! IF uplo='U' UPPER TRIANGLE OF a IS STORED, ! IF uplo='L' LOWER TRIANGLE OF a IS STORED. ! uplo = 'U' ! vl = zero vu = zero ! il = 1 iu = n ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR syevr SUBROUTINE. ! lwork = -1 liwork = -1 ! call syevr( jobz, range, uplo, n, a, n, vl, vu, il, iu, abstol, & m, w, z, n, isuppz, work2, lwork, iwork2, liwork, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) + 10 liwork = iwork2(1) ! ! ALLOCATE WORK VARIABLES NEEDED BY syevr SUBROUTINE. ! allocate( work(lwork), iwork(liwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! COMPUTE EIGENVALUES AND EIGENVECTORS OF THE SELF-ADJOINT MATRIX a ! WITH SUBROUTINE syevr FROM LAPACK. ! THE EIGENVALUE DECOMPOSITION OF A REAL n-BY-n SYMMETRIC MATRIX a ! IS WRITTEN ! ! a = U * D * U**(t) ! ! WHERE D IS AN n-BY-n DIAGONAL MATRIX AND U IS AN n-BY-n ORTHOGONAL MATRIX. ! THE DIAGONAL ELEMENTS OF D ARE THE EIGENVALUES OF a; THEY ARE REAL. ! THE COLUMNS OF U ARE THE EIGENVECTORS OF a. ! call syevr( jobz, range, uplo, n, a, n, vl, vu, il, iu, abstol, & m, w, z, n, isuppz, work, lwork, iwork, liwork, info ) ! ! ON EXIT OF syevr : ! ! info= 0 : INDICATES SUCCESSFUL EXIT. ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE. ! info=i > 0 : INDICATES THAT THE ALGORITHM FAILED TO CONVERGE. ! ! ON EXIT OF syevr : ! ! THE LOWER (IF uplo='L') OR UPPER (IF uplo='U') TRIANGLE ! OF a IS DESTROYED, INCLUDING THE DIAGONAL. ! ! m GIVES THE TOTAL NUMBER OF EIGENVALUES/EIGENVECTORS FOUND. ! ! z IS OVERWRITTEN WITH THE FIRST m EIGENVECTORS ! OF a (THE EIGENVECTORS ARE STORED COLUMNWISE). ! ! w IS OVERWRITTEN WITH THE EIGENVALUES OF a IN ASCENDING ORDER, ! CORRESPONDING TO THE EIGENVECTORS IN z . ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( work, iwork ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM syevr SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to SYEVR subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*U - U*D. ! a(:n,:m) = matmul(a2(:n,:n),z(:n,:m)) - z(:n,:m)*spread(w(:m),dim=1,ncopies=n) resid2(:m) = norm( a(:n,:m), dim=2_i4b ) err1 = maxval( resid2(:m) )/( anorm*real(n,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U. ! call unit_matrix( a2(:m,:m) ) ! a(:m,:m) = abs( a2(:m,:m) - matmul( transpose(z(:n,:m)), z(:n,:m) ) ) err2 = maxval( a(:m,:m) )/real(n,stnd) ! err = max( err1, err2 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, z, w, isuppz, a2, resid2 ) else deallocate( a, z, w, isuppz ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' Matrix type = ', mat_type ! write (prtunit,*) write (prtunit,*) ' Matrix_type < 1 -> random symmetric matrix from the uniform distribution' write (prtunit,*) ' Matrix type = 1 -> slow decay of eigenvalues' write (prtunit,*) ' Matrix type = 2 -> fast decay of eigenvalues' write (prtunit,*) ' Matrix type = 3 -> s-shaped decay of eigenvalues' write (prtunit,*) ' Matrix type = 4 -> very slow decay of eigenvalues' write (prtunit,*) ' Matrix type = 5 -> strongly clustered eigenvalues at 1' write (prtunit,*) ' spectrum with few deflations (for LAPACK SYESVD routine)' write (prtunit,*) ' Matrix type = 6 -> geometric distribution of eigenvalues' write (prtunit,*) ' spectrum with moderate deflation (for LAPACK SYESVD routine)' write (prtunit,*) ' Matrix type = 7 -> arithmetic distribution of eigenvalues' write (prtunit,*) ' spectrum with complete deflation (for LAPACK SYESVD routine)' write (prtunit,*) ' Matrix type > 7 -> uniform distribution of eigenvalues' ! write (prtunit,*) write (prtunit,*) ' INFO ( from syevr() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed eigenvalues and eigenvectors = ', err1 write (prtunit,*) 'Orthogonality of the computed eigenvectors = ', err2 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing ', m, ' eigenvalues and eigenvectors of a ', & n, ' by ', n,' real symmetric matrix is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex1_lapack_syevr ! =============================== ! end program ex1_lapack_syevr
ex1_lapack_syevx.F90¶
program ex1_lapack_syevx ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutine SYEVX ! in LAPACK software for computing all eigenvalues and, optionally, ! eigenvectors of a real symmetric matrix. The eigenvalues and ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : syevx ! use Statpack, only : lgl, i4b, stnd, true, false, zero, one, two, seven, c30, c50, c1_e6, & safmin, norm, unit_matrix, random_seed_, random_number_, & gen_random_sym_mat, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! #ifdef _F2003 use ieee_arithmetic, only : ieee_support_datatype, ieee_is_normal #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, n IS THE DIMENSION OF THE GENERATED SYMMETRIC MATRIX, ! neig0 IS THE NUMERICAL RANK OF THE GENERATED SYMMETRIC MATRIX (WHICH MUST BE LESS OR EQUAL TO n) ! FOR CASES GREATER THAN 0. ! integer(i4b), parameter :: prtunit=6, n=3000, neig0=3000 ! ! conda IS THE CONDITION NUMBER OF THE GENERATED MATRIX IN CASES 5, 6 and 7, ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50, conda=c1_e6 ! character(len=*), parameter :: name_proc='Example 1 of syevx' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, err1, err2, eps, abstol, vl, vu, tmp, tmp2, & ulp, anorm, elapsed_time real(stnd) :: work2(1) real(stnd), dimension(:), allocatable :: w, work, resid2 real(stnd), dimension(:,:), allocatable :: a, a2, z ! integer :: info, lwork, iok, il, iu, m, istart, & iend, irate, imax, itime integer, dimension(:), allocatable :: iwork, ifail integer(i4b) :: i, mat_type ! logical(lgl) :: do_test ! character :: jobz, uplo, range ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : EIGENVALUES AND, OPTIONALLY, EIGENVECTORS OF A REAL SYMMETRIC ! MATRIX USING THE BISECTION AND INVERSE ITERATION METHODS. ! ! SPECIFY THE TYPE OF INPUT SYMMETRIC MATRIX: ! ! mat_type < 1 -> RANDOM SYMMETRIC MATRIX FROM THE UNIFORM DISTRIBUTION ! mat_type = 1 -> SLOW DECAY OF EIGENVALUES ! mat_type = 2 -> FAST DECAY OF EIGENVALUES ! mat_type = 3 -> S-SHAPED DECAY OF EIGENVALUES ! mat_type = 4 -> VERY SLOW DECAY OF EIGENVALUES ! mat_type = 5 -> STRONGLY CLUSTERED EIGENVALUES AT 1 WITH CONDITION NUMBER conda ! SPECTRUM WITH FEW DEFLATIONS FOR LAPACK SYESVD ROUTINE ! mat_type = 6 -> GEOMETRIC DISTRIBUTION OF EIGENVALUES WITH CONDITION NUMBER conda ! SPECTRUM WITH MODERATE DEFLATION FOR LAPACK SYESVD ROUTINE ! mat_type = 7 -> ARITHMETIC DISTRIBUTION OF EIGENVALUES WITH CONDITION NUMBER conda ! SPECTRUM WITH COMPLETE DEFLATION FOR LAPACK SYESVD ROUTINE ! mat_type > 7 -> UNIFORM DISTRIBUTION OF EIGENVALUES ! mat_type = 2_i4b ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! abstol = two*safmin ulp = epsilon( err ) eps = fudge*ulp err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a(n,n), z(n,n), w(n), iwork(5*n), ifail(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SELECT THE UNIFORM RANDOM GENERATOR TO BE USED. ! call random_seed_( alg=3 ) ! ! RESET THE SEEDS USED BY THE UNIFORM RANDOM GENERATOR. ! call random_seed_() ! ! GENERATE A RANDOM UNIFORM SYMMETRIC MATRIX OR EIGENVALUES. ! select case( mat_type ) ! case( :0_i4b ) ! ! RANDOM UNIFORM SYMMETRIC MATRIX. ! call random_number_( z ) ! a = z + transpose( z ) ! ! COMPUTE THE FROBENIUS NORM OF THE RANDOM SYMMETRIC MATRIX. ! anorm = norm( a ) ! case( 1_i4b ) ! ! SLOW DECAY OF EIGENVALUES. ! do i = 1_i4b, neig0 ! tmp = real( i, stnd ) ! w(i) = one/( tmp*tmp ) ! end do ! case( 2_i4b ) ! ! FAST DECAY OF EIGENVALUES. ! do i = 1_i4b, neig0 ! tmp = real( i, stnd ) ! w(i) = exp( -tmp/seven ) ! end do ! case( 3_i4b ) ! ! S-SHAPED DECAY OF EIGENVALUES. ! do i = 1_i4b, neig0 ! tmp = real( i, stnd ) ! w(i) = 0.0001_stnd + one/( one + exp( tmp - c30 ) ) ! end do ! case( 4_i4b ) ! ! VERY SLOW DECAY OF EIGENVALUES. ! tmp = real( neig0 - 1_i4b, stnd ) ! do i = 1_i4b, neig0 ! tmp2 = real( i - 1_i4b, stnd ) ! w(i) = exp( -tmp2/tmp ) ! end do ! case( 5_i4b ) ! ! STRONGLY CLUSTERED EIGENVALUES AT 1 WITH CONDITION NUMBER conda. ! THIS IS A SPECTRUM WITH FEW DEFLATIONS FOR LAPACK SYESVD ROUTINE. ! w(:neig0-1_i4b) = one w(neig0) = one/conda ! case( 6_i4b ) ! ! GEOMETRIC DISTRIBUTION OF EIGENVALUES WITH CONDITION NUMBER conda. ! THIS IS A SPECTRUM WITH MODERATE DEFLATION FOR LAPACK SYESVD ROUTINE. ! tmp = real( neig0 - 1_i4b, stnd ) ! do i = 1_i4b, neig0 ! tmp2 = real( i - 1_i4b, stnd ) ! w(i) = conda**( -tmp2/tmp ) ! end do ! case( 7_i4b ) ! ! ARITHMETIC DISTRIBUTION OF EIGENVALUES WITH CONDITION NUMBER conda. ! THIS IS A SPECTRUM WITH COMPLETE DEFLATION FOR LAPACK SYESVD ROUTINE. ! tmp = real( neig0 - 1_i4b, stnd ) tmp2 = one - one/conda ! do i = 1_i4b, neig0 ! w(i) = one - (real( i - 1_i4b, stnd )/tmp)*tmp2 ! end do ! case default ! ! UNIFORM DISTRIBUTION OF EIGENVALUES. ! call random_number_( w(:neig0) ) ! end select ! if ( mat_type>0_i4b ) then ! #ifdef _F2003 if ( ieee_support_datatype( w ) ) then ! if ( .not.all( ieee_is_normal( w(:neig0) ) ) ) then ! call merror( name_proc//' : Exceptions occurred when generating the input symmetric matrix !' ) ! end if ! end if #endif ! ! GENERATE A n-BY-n RANDOM REAL SYMMETRIC MATRIX a WITH A SPECIFIED DISTRIBUTION ! OF EIGENVALUES AND A RANK EQUAL TO neig0. ! call gen_random_sym_mat( w(:neig0), a ) ! ! COMPUTE THE FROBENIUS NORM OF THE MATRIX. ! anorm = norm( w(:neig0) ) ! end if ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(n,n), resid2(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! MAKE A COPY OF THE RANDOM DATA MATRIX . ! a2(:n,:n) = a(:n,:n) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! FIRST DETERMINE THE WORK TO DO. ! ! IF jobz='N' COMPUTE EIGENVALUES ONLY, ! IF jobz='V' COMPUTE EIGENVALUES AND EIGENVECTORS. ! jobz = 'V' ! ! IF range='A' ALL EIGENVALUES WILL BE FOUND, ! IF range='V' ALL EIGENVALUES IN THE HALF OPEN INTERVAL (vl,vu] WILL BE FOUND, ! IF range='I' THE il-TH THROUGH iu-TH EIGENVALUES IN ASCENDING ORDER WILL BE FOUND. ! range = 'A' ! ! IF uplo='U' UPPER TRIANGLE OF a IS STORED, ! IF uplo='L' LOWER TRIANGLE OF a IS STORED. ! uplo = 'U' ! vl = zero vu = zero ! il = 1 iu = n ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR syevx SUBROUTINE. ! lwork = -1 ! call syevx( jobz, range, uplo, n, a, n, vl, vu, il, iu, abstol, & m, w, z, n, work2, lwork, iwork, ifail, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) ! ! ALLOCATE WORK VARIABLE NEEDED BY syevx SUBROUTINE. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! COMPUTE EIGENVALUES AND EIGENVECTORS OF THE SELF-ADJOINT MATRIX a ! WITH SUBROUTINE syevx FROM LAPACK. ! THE EIGENVALUE DECOMPOSITION OF A REAL n-BY-n SYMMETRIC MATRIX a ! IS WRITTEN ! ! a = U * D * U**(t) ! ! WHERE D IS AN n-BY-n DIAGONAL MATRIX AND U IS AN n-BY-n ORTHOGONAL MATRIX. ! THE DIAGONAL ELEMENTS OF D ARE THE EIGENVALUES OF a; THEY ARE REAL. ! THE COLUMNS OF U ARE THE EIGENVECTORS OF a. ! call syevx( jobz, range, uplo, n, a, n, vl, vu, il, iu, abstol, & m, w, z, n, work, lwork, iwork, ifail, info ) ! ! ON EXIT OF syevx : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! info=i > 0 : INDICATES THAT i EIGENVECTORS FAILED TO CONVERGE AND ! THEIR INDICES ARE STORED IN ARRAY ifail. ! ! ON EXIT OF syevx : ! ! THE LOWER (IF uplo='L') OR UPPER (IF uplo='U') TRIANGLE ! OF a IS DESTROYED, INCLUDING THE DIAGONAL. ! ! m GIVES THE TOTAL NUMBER OF EIGENVALUES/EIGENVECTORS FOUND. ! ! z IS OVERWRITTEN WITH THE FIRST m EIGENVECTORS ! OF a (THE EIGENVECTORS ARE STORED COLUMNWISE). ! ! w IS OVERWRITTEN WITH THE EIGENVALUES OF a IN ASCENDING ORDER, ! CORRESPONDING TO THE EIGENVECTORS IN z . ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM syevx SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to SYEVX subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*U - U*D ! a(:n,:m) = matmul(a2(:n,:n),z(:n,:m)) - z(:n,:m)*spread(w(:m),dim=1,ncopies=n) resid2(:m) = norm( a(:n,:m), dim=2_i4b ) err1 = maxval( resid2(:m) )/( anorm*real(n,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U. ! call unit_matrix( a2(:m,:m) ) ! a(:m,:m) = abs( a2(:m,:m) - matmul( transpose(z(:n,:m)), z(:n,:m) ) ) err2 = maxval( a(:m,:m) )/real(n,stnd) ! err = max( err1, err2 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, z, w, iwork, ifail, a2, resid2 ) else deallocate( a, z, w, iwork, ifail ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' Matrix type = ', mat_type ! write (prtunit,*) write (prtunit,*) ' Matrix_type < 1 -> random symmetric matrix from the uniform distribution' write (prtunit,*) ' Matrix type = 1 -> slow decay of eigenvalues' write (prtunit,*) ' Matrix type = 2 -> fast decay of eigenvalues' write (prtunit,*) ' Matrix type = 3 -> s-shaped decay of eigenvalues' write (prtunit,*) ' Matrix type = 4 -> very slow decay of eigenvalues' write (prtunit,*) ' Matrix type = 5 -> strongly clustered eigenvalues at 1' write (prtunit,*) ' spectrum with few deflations (for LAPACK SYESVD routine)' write (prtunit,*) ' Matrix type = 6 -> geometric distribution of eigenvalues' write (prtunit,*) ' spectrum with moderate deflation (for LAPACK SYESVD routine)' write (prtunit,*) ' Matrix type = 7 -> arithmetic distribution of eigenvalues' write (prtunit,*) ' spectrum with complete deflation (for LAPACK SYESVD routine)' write (prtunit,*) ' Matrix type > 7 -> uniform distribution of eigenvalues' ! write (prtunit,*) write (prtunit,*) ' INFO ( from syevx() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed eigenvalues and eigenvectors = ', err1 write (prtunit,*) 'Orthogonality of the computed eigenvectors = ', err2 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing ', n, ' eigenvalues and eigenvectors of a ', & n, ' by ', n,' real symmetric matrix is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex1_lapack_syevx ! =============================== ! end program ex1_lapack_syevx
ex1_lapack_sysv.F90¶
program ex1_lapack_sysv ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutine SYSV ! in LAPACK software for solving a linear system with a real symmetric ! coefficient matrix. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : sysv ! use Statpack, only : lgl, i4b, stnd, true, false, zero, c100, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, n IS THE DIMENSION OF THE GENERATED SYMMETRIC MATRIX, ! nrhs IS THE NUMBER OF RIGHT HANDE-SIDE VECTORS OF THE LINEAR SYSTEM TO BE SOLVED. ! integer, parameter :: prtunit = 6, n=1000, nrhs=400 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c100 ! character(len=*), parameter :: name_proc='Example 1 of sysv' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, eps, elapsed_time, work2(1) real(stnd), dimension(:), allocatable :: work real(stnd), dimension(:,:), allocatable :: a, b, x, res ! integer(i4b), dimension(:), allocatable :: ipiv integer :: info, lwork, iok, istart, iend, irate, imax, itime ! logical(lgl) :: do_test ! character :: uplo ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : SOLUTION OF A LINEAR SYSTEM WITH A REAL SYMMETRIC COEFFICIENT ! MATRIX AND SEVERAL RIGHT HAND-SIDES. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*real( n, stnd )*epsilon( err ) ! eps = sqrt( epsilon( err ) ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a(n,n), b(n,nrhs), x(n,nrhs), ipiv(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A n-by-n RANDOM SYMMETRIC MATRIX a . ! call random_number( a ) ! a = a + transpose( a ) ! ! GENERATE A n-by-nrhs RANDOM SOLUTION MATRIX x . ! call random_number( x ) ! ! COMPUTE THE MATRIX-MATRIX PRODUCT b = a*x . ! b = matmul( a, x ) ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! IF uplo='U' UPPER TRIANGLE OF a IS STORED, ! IF uplo='L' LOWER TRIANGLE OF a IS STORED. ! uplo = 'U' ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR sysv SUBROUTINE. ! lwork = -1 ! call sysv( uplo, n, nrhs, a, n, ipiv, b, n, work2, lwork, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) ! ! ALLOCATE WORK VARIABLE NEEDED BY sysv SUBROUTINE. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! COMPUTE THE SOLUTION MATRIX FOR REAL SYMMETRIC LINEAR SYSTEM ! ! a*x = b . ! call sysv( uplo, n, nrhs, a, n, ipiv, b, n, work, lwork, info ) ! ! ON EXIT OF sysv : ! ! info = 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT the iTH ARGUMENT HAS AN ILLEGAL VALUE ! info=i > 0 : INDICATES THAT THE SOLUTION CAN NOT BE COMPUTED BECAUSE ! THE MATRIX IS SINGULAR ! ! THE ROUTINE RETURNS THE SOLUTION VECTORS IN b. ! DETAILS OF THE U*D*U**(T) (if uplo='U') OR THE L*D*L**(T) (if uplo='L') ! FACTORIZATION OF a ARE RETURNED IN ARGUMENTS ipiv AND a . ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM sysv SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to SYSV subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test ) then ! ! ALLOCATE WORK ARRAY . ! allocate( res(n,nrhs), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! res(:n,:nrhs) = b(:n,:nrhs) - x(:n,:nrhs) err = maxval( sum( abs(res), dim=1 ) / & sum(abs(x), dim=1 ) ) ! ! DEALLOCATE WORK ARRAY. ! deallocate( res ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! deallocate( a, b, x, ipiv ) ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from sysv() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed solutions = ', err end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing the solution of a linear symmetric real system of size ', & n, ' with ', nrhs,' right hand sides is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex1_lapack_sysv ! ============================== ! end program ex1_lapack_sysv
ex1_lapack_sytrd.F90¶
program ex1_lapack_sytrd ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutines SYTRD and ORGTR ! in LAPACK software for computing a tridiagonal factorization of a real symmetric matrix. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : sytrd, orgtr ! use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, & unit_matrix, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, n IS THE DIMENSION OF THE GENERATED SYMMETRIC MATRIX. ! integer, parameter :: prtunit = 6, n=3000 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 1 of sytrd' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err1, err2, err, eps, elapsed_time real(stnd) :: work2(1) real(stnd), allocatable, dimension(:) :: d, e, tau, work real(stnd), allocatable, dimension(:,:) :: a, a2, resid, trid ! integer :: info_trd, info_q, lwork, lwork_trd, lwork_q, & iok, istart, iend, irate, imax, itime integer(i4b) :: l ! logical(lgl) :: do_test ! character :: uplo ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : TRIDIAGONAL REDUCTION OF A REAL SYMMETRIC MATRIX BY THE HOUSEHOLDER METHOD. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a(n,n), d(n), e(n-1_i4b), tau(n-1_i4b), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A n-by-n RANDOM DATA MATRIX AND ! FROM IT A SELF-ADJOINT MATRIX a . ! call random_number( a ) ! a = a + transpose( a ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(n,n), trid(n,n), resid(n,n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SAVE THE SYMMETRIC MATRIX. ! a2(:n,:n) = a(:n,:n) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! IF uplo='U' UPPER TRIANGLE OF a IS STORED, ! IF uplo='L' LOWER TRIANGLE OF a IS STORED. ! uplo = 'U' ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR sytrd AND orgtr SUBROUTINES. ! lwork = -1 ! call sytrd( uplo, n, a, n, d, e, tau, work2, lwork, info=info_trd ) ! lwork_trd = int(work2(1)) ! call orgtr( uplo, n, a, n, tau, work2, lwork, info=info_q ) ! lwork_q = int(work2(1)) ! if ( min(info_trd,info_q)==0 ) then ! lwork = max( lwork_trd, lwork_q ) ! ! ALLOCATE OPTIMAL WORK VARIABLE NEEDED BY sytrd AND orgtr SUBROUTINES. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! CALL sytrd AND orgtr TO REDUCE THE MATRIX a TO TRIDIAGONAL FORM ! ! a = Q*TRID*Q**(t) ! ! WHERE Q IS ORTHOGONAL AND TRID IS A SYMMETRIC TRIDIAGONAL MATRIX. ! call sytrd( uplo, n, a, n, d, e, tau, work(:lwork_trd), lwork_trd, info=info_trd ) ! ! ON EXIT OF sytrd : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! ! d AND e ARE THE DIAGONAL AND OFF-DIAGONAL ELEMENTS OF THE SYMMETRIC TRIDIAGONAL MATRIX, RESPECTIVELY. ! a CONTAINS THE ELEMENTARY REFLECTORS WHICH DEFINE Q IN ITS UPPER TRIANGLE IF uplo='U'. ! tau CONTAINS THE SCALAR FACTORS OF THE ELEMENTARY REFLECTORS WHICH DEFINE Q. ! call orgtr( uplo, n, a, n, tau, work(:lwork_q), lwork_q, info=info_q ) ! ! ON EXIT OF THIS orgtr CALL: ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! ! a IS OVERWRITTEN WITH THE n-BY-n ORTHOGONAL MATRIX Q. ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( min(info_trd,info_q)/=0 ) then ! ! ANORMAL EXIT FROM sytrd AND orgtr SUBROUTINES, PRINT A WARNING. ! write (prtunit,*) 'Error in the calls to SYTRD or ORGTR subroutines, Info=', min(info_trd,info_q) ! else if ( do_test ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*Q - Q*TRID. ! trid(:n,:n) = zero ! do l = 1_i4b, n-1_i4b trid(l,l) = d(l) trid(l,l+1_i4b) = e(l) trid(l+1_i4b,l) = e(l) end do ! trid(n,n) = d(n) ! resid(:n,:n) = matmul( a2(:n,:n), a(:n,:n) ) & - matmul( a(:n,:n), trid(:n,:n) ) ! trid(:n,1_i4b) = norm( resid(:n,:n), dim=2_i4b ) err1 = maxval( trid(:n,1_i4b) )/( norm( a2 )*real(n,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - Q**(t)*Q. ! call unit_matrix( a2(:n,:n) ) ! resid(:n,:n) = abs( a2(:n,:n) - matmul( transpose(a(:n,:n )), a(:n,:n) ) ) err2 = maxval( resid(:n,:n) )/real(n,stnd) ! err = max( err1, err2 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, a2, trid, resid, d, e, tau ) else deallocate( a, d, e, tau ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. min(info_trd,info_q)==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from sytrd() ) = ', info_trd write (prtunit,*) ' INFO ( from orgtr() ) = ', info_q ! if ( do_test .and. min(info_trd,info_q)==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed tridiagonal decomposition a = Q*TRD*Q**(t) = ', err1 write (prtunit,*) 'Orthogonality of the computed Q orthogonal matrix = ', err2 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing the tridiagonal reduction of a ', & n, ' by ', n,' real symmetric matrix is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex1_lapack_sytrd ! =============================== ! end program ex1_lapack_sytrd
ex2_lapack_gebrd.F90¶
program ex2_lapack_gebrd ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutines GEBRD and ORGBR ! in LAPACK software for computing a bidiagonal decomposition of a complex matrix. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : gebrd, orgbr ! use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, & unit_matrix, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, m AND n ARE THE DIMENSIONS OF THE GENERATED MATRIX. ! integer, parameter :: prtunit = 6, m=1000, n=1000, k=min(m,n) ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 2 of gebrd' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err1, err2, err3, err, eps, elapsed_time real(stnd), allocatable, dimension(:) :: d, e, resid2 real(stnd), allocatable, dimension(:,:) :: ra, ia, resid_ortho ! complex(stnd) :: work2(1) complex(stnd), allocatable, dimension(:) :: tauq, taup, work complex(stnd), allocatable, dimension(:,:) :: a, a2, bd, resid, pt, q ! integer :: info_bd, info_q, info_pt, lwork, lwork_bd, lwork_q, lwork_pt, & iok, istart, iend, irate, imax, itime integer(i4b) :: l ! logical(lgl) :: do_test ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : BIDIAGONAL REDUCTION OF A COMPLEX MATRIX. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! if ( m>=n ) then allocate( a(m,n), ia(m,n), ra(m,n), d(k), e(k-1_i4b), tauq(k), taup(k), pt(k,k), stat=iok ) else allocate( a(m,n), ia(m,n), ra(m,n), d(k), e(k-1_i4b), tauq(k), taup(k), q(k,k), stat=iok ) end if ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A m-by-n COMPLEX RANDOM DATA MATRIX . ! call random_number( ra(:m,:n) ) call random_number( ia(:m,:n) ) ! a(:m,:n) = cmplx( ra(:m,:n), ia(:m,:n), stnd ) ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( ra, ia ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(m,n), bd(k,k), resid(k,n), resid2(n), resid_ortho(k,k), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SAVE THE DATA MATRIX. ! a2(:m,:n) = a(:m,:n) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR gebrd AND orgbr SUBROUTINES. ! lwork = -1 ! call gebrd( m, n, a, m, d, e, tauq, taup, work2, lwork, info=info_bd ) ! lwork_bd = int(work2(1)) ! if ( m>=n ) then ! call orgbr( 'Q', m, n, n, a, m, tauq, work2, lwork, info=info_q ) ! lwork_q = int(work2(1)) ! call orgbr( 'P', n, n, m, pt, n, taup, work2, lwork, info=info_pt ) ! lwork_pt = int(work2(1)) ! else ! call orgbr( 'Q', m, m, n, q, m, tauq, work2, lwork, info=info_q ) ! lwork_q = int(work2(1)) ! call orgbr( 'P', m, n, m, a, m, taup, work2, lwork, info=info_pt ) ! lwork_pt = int(work2(1)) ! end if ! if ( min(info_bd,info_q,info_pt)==0 ) then ! lwork = max( lwork_bd, lwork_q, lwork_pt ) ! ! ALLOCATE OPTIMAL WORK VARIABLE NEEDED BY gebrd AND orgbr SUBROUTINES. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! COMPUTE BIDIAGONAL REDUCTION OF RANDOM DATA MATRIX ! ! a = Q*BD*P**(h) ! ! WHERE Q AND P ARE UNITARY MATRICES AND BD IS A REAL BIDIAGONAL MATRIX. ! call gebrd( m, n, a, m, d, e, tauq, taup, work(:lwork_bd), lwork_bd, info=info_bd ) ! ! ON EXIT OF gebrd : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! ! d AND e ARE THE DIAGONAL AND OFF-DIAGONAL ELEMENTS OF THE REAL BIDAGONAL MATRIX BD, RESPECTIVELY. ! a CONTAINS THE ELEMENTARY REFLECTORS WHICH DEFINE Q AND P. ! taup AND tauq ARE THE SCALAR FACTORS OF THE ELEMENTARY REFLECTORS WHICH DEFINE Q AND P, RESPECTIVELY. ! if ( m>=n ) then ! pt(:n,:n) = a(:n,:n) ! call orgbr( 'Q', m, n, n, a, m, tauq, work(:lwork_q), lwork_q, info=info_q ) ! call orgbr( 'P', n, n, m, pt, n, taup, work(:lwork_pt), lwork_pt, info=info_pt ) ! ! ON EXIT OF THESE orgbr CALLS: ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! ! IF m>=n, a IS OVERWRITTEN WITH THE FIRST min(m,n) ! COLUMNS OF THE UNITARY MATRIX Q; ! pt CONTAINS THE n-BY-n UNITARY MATRIX P**(h). ! else ! q(:m,:m) = a(:m,:m) ! call orgbr( 'Q', m, m, n, q, m, tauq, work(:lwork_q), lwork_q, info=info_q ) ! call orgbr( 'P', m, n, m, a, m, taup, work(:lwork_pt), lwork_pt, info=info_pt ) ! ! ON EXIT OF orgbr CALLS: ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! ! IF m<n, a IS OVERWRITTEN WITH THE FIRST min(m,n) ! ROWS OF THE UNITARY MATRIX P**(h); ! q CONTAINS THE m-BY-m UNITARY MATRIX Q. ! end if ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( min(info_bd,info_q,info_pt)/=0 ) then ! ! ANORMAL EXIT FROM gebrd OR orgbr SUBROUTINES, PRINT A WARNING. ! write (prtunit,*) 'Error in the calls to GEBRD or ORGBR subroutines, Info=', min(info_bd,info_q,info_pt) ! else if ( do_test ) then ! bd(:k,:k) = cmplx( zero, zero, stnd ) ! if ( m>=n ) then ! ! BD IS UPPER BIDIAGONAL. ! do l = 1_i4b, n-1_i4b bd(l,l) = cmplx( d(l), zero, stnd ) bd(l,l+1_i4b) = cmplx( e(l), zero, stnd ) end do ! bd(n,n) = cmplx( d(n), zero, stnd ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION Q**(h)*a - BD*P**(h), ! resid(:n,:n) = matmul( transpose(conjg(a(:m,:n))), a2(:m,:n) ) & - matmul( bd(:n,:n), pt(:n,:n) ) ! resid2(:n) = norm( resid(:n,:n), dim=2_i4b ) err1 = norm( resid2(:n) )/(norm( a2 )*real(n,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - Q**(h)*Q. ! call unit_matrix( a2(:n,:n) ) ! resid_ortho(:n,:n) = abs( a2(:n,:n) - matmul( transpose(conjg(a(:m,:n))), a(:m,:n) ) ) err2 = maxval( resid_ortho(:n,:n) )/real(m,stnd) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - P**(h)*P. ! resid_ortho(:n,:n) = abs( a2(:n,:n) - matmul( pt(:n,:n), transpose(conjg(pt(:n,:n))) ) ) err3 = maxval( resid_ortho(:n,:n) )/real(n,stnd) ! else ! ! BD IS LOWER BIDIAGONAL. ! do l = 1_i4b, m-1_i4b bd(l,l) = cmplx( d(l), zero, stnd ) bd(l+1_i4b,l) = cmplx( e(l), zero, stnd ) end do ! bd(m,m) = cmplx( d(m), zero, stnd ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION Q**(h)*a - BD*P**(h), ! resid(:m,:n) = matmul( transpose(conjg(q(:m,:m))), a2(:m,:n) ) & - matmul( bd(:m,:m), a(:m,:n) ) ! resid2(:n) = norm( resid(:m,:n), dim=2_i4b ) err1 = maxval( resid2(:n) )/(norm( a2 )*real(m,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - Q**(h)*Q. ! call unit_matrix( a2(:m,:m) ) ! resid_ortho(:m,:m) = abs( a2(:m,:m) - matmul( transpose(conjg(q(:m,:m ))), q(:m,:m ) ) ) err2 = maxval( resid_ortho(:m,:m) )/real(m,stnd) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - P**(h)*P. ! resid_ortho(:m,:m) = abs( a2(:m,:m) - matmul( a(:m,:n), transpose(conjg(a(:m,:n))) ) ) err3 = maxval( resid_ortho(:m,:m) )/real(n,stnd) ! endif ! err = max( err1, err2, err3 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( m>=n ) then deallocate( a, pt, d, e, tauq, taup ) else deallocate( a, q, d, e, tauq, taup ) end if ! if ( do_test ) then deallocate( a2, bd, resid, resid2, resid_ortho ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. min(info_bd,info_q,info_pt)==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from gebrd() ) = ', info_bd write (prtunit,*) ' INFO ( from orgbr() ) = ', info_q write (prtunit,*) ' INFO ( from orgbr() ) = ', info_pt ! if ( do_test .and. min(info_bd,info_q,info_pt)==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed bidiagonal decomposition a = Q*BD*P**(H) = ', err1 write (prtunit,*) 'Orthogonality of the computed Q unitary matrix = ', err2 write (prtunit,*) 'Orthogonality of the computed P unitary matrix = ', err3 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing the bidiagonal reduction of a', & m, ' by', n,' complex matrix is', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex2_lapack_gebrd ! =============================== ! end program ex2_lapack_gebrd
ex2_lapack_gels.F90¶
program ex2_lapack_gels ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutine GELS in LAPACK software ! for computing solution of a full rank linear least squares complex problem using a QR/QL ! decomposition of the coefficient matrix. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : gels ! use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, m AND n ARE THE DIMENSIONS OF THE GENERATED COMPLEX MATRIX, ! nrhs IS THE NUMBER OF RIGHT HAND SIDES OF THE LINEAR LEAST SQUARE PROBLEM. ! integer, parameter :: prtunit = 6, m=1000, n=2000, p=min(m,n), k=max(m,n), nrhs=400 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 2 of gels' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, eps, elapsed_time real(stnd), dimension(:,:), allocatable :: ra, ia, rb, ib ! complex(stnd) :: work2(1) complex(stnd), allocatable :: work(:), a(:,:), a2(:,:), b(:,:), b2(:,:), res(:,:) ! integer :: info, lwork, iok, istart, iend, irate, imax, itime, mrhs ! logical(lgl) :: do_test ! character :: trans ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 2 : FULL RANK COMPLEX LINEAR LEAST SQUARES PROBLEM AND SEVERAL RIGHT HAND-SIDES ! USING THE QR OR QL DECOMPOSITION OF THE COEFFICENT MATRIX a . IT IS ! ASSUMED THAT a IS OF FULL RANK. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! If trans='N' THE LINEAR SYSTEM INVOLVES a AND If trans='C' THE LINEAR ! SYSTEM INVOLVES a**(h). IN BOTH CASES, THE RANK OF a IS ASSUMED TO BE ! min(m,n) . ! trans = 'N' ! mrhs = merge( m, n, trans=='N' ) ! ! ALLOCATE WORK ARRAYS. ! allocate( a(m,n), ra(m,n), ia(m,n), & b(k,nrhs), rb(mrhs,nrhs), ib(mrhs,nrhs), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A m-by-n COMPLEX RANDOM COEFFICIENT MATRIX a . ! call random_number( ra(:m,:n) ) call random_number( ia(:m,:n) ) ! a(:m,:n) = cmplx( ra(:m,:n), ia(:m,:n), stnd ) ! ! GENERATE A m-by-nrhs (trans='N') OR n-by-nrhs (trans='C') ! COMPLEX RANDOM RIGHT HAND-SIDE MATRIX b . ! call random_number( rb(:mrhs,:nrhs) ) call random_number( ib(:mrhs,:nrhs) ) ! b(:mrhs,:nrhs) = cmplx( rb(:mrhs,:nrhs), ib(:mrhs,:nrhs), stnd ) ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( ra, ia, rb, ib ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(m,n), b2(mrhs,nrhs), res(mrhs,nrhs), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SAVE DATA MATRIX . ! a2(:m,:n) = a(:m,:n) ! ! SAVE RIGHT HAND SIDE MATRIX . ! b2(:mrhs,:nrhs) = b(:mrhs,:nrhs) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR gels SUBROUTINE. ! lwork = -1 ! call gels( trans, m, n, nrhs, a, m, b, k, work2, lwork, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) + 10 ! ! ALLOCATE WORK VARIABLE NEEDED BY gels SUBROUTINE. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! COMPUTE MINIMAL NORM SOLUTION TO THE COMPLEX LINEAR LEAST SQUARES PROBLEM. ! call gels( trans, m, n, nrhs, a, m, b, k, work, lwork, info ) ! ! THE ROUTINE RETURNS THE MINIMUM NORM SOLUTIONS OF THE LINEAR ! LEAST SQUARE PROBLEM. ! ! ON EXIT OF gels : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT the iTH ARGUMENT HAS AN ILLEGAL VALUE ! info=i > 0 : INDICATES THAT the iTH DIAGONAL ELEMENT OF THE TRIANGULAR ! FACTOR OF a IS ZERO AND a DOES NOT HAVE FULL RANK. ! ! ON EXIT OF gels : ! ! a IS OVERWRITTEN BY DETAILS OF ITS QR (m>=n) OR LQ (m<n) FACTORIZATION. ! ! b IS OVERWRITTEN BY THE n-by-nrhs (trans='N') OR ! m-by-nrhs (trans='C') SOLUTION. ! ! If m >= n AND trans='N', THE RESIDUAL SUM-OF-SQUARES ! FOR THE SOLUTION IN THE i-th COLUMN IS GIVEN BY THE ! SUM OF SQUARES OF THE MODULUS OF ELEMENTS n+1:m ! IN THAT COLUMN. ! ! If m < n AND trans='C', THE RESIDUAL SUM-OF-SQUARES ! FOR THE SOLUTION IN THE i-th COLUMN IS GIVEN BY THE ! SUM OF SQUARES OF THE MODULUS OF ELEMENTS m+1:n ! IN THAT COLUMN. ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM gels SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to GELS subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test ) then ! ! CHECK THAT THE RESIDUALS ARE ORTHOGONAL TO THE COLUMN (trans='N') ! OR ROW (trans='C') VECTORS OF a . ! if ( trans=='N' ) then res = b2 - matmul( a2, b(:n,:nrhs) ) err = maxval( sum(abs(matmul(transpose(conjg(a2)),res)), dim=1) )/ sum( abs(a2) ) else res = b2 - matmul( transpose(conjg(a2)), b(:m,:nrhs) ) err = maxval( sum(abs(matmul(a2,res)), dim=1) )/ sum( abs(a2) ) end if ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, b, a2, b2, res ) else deallocate( a, b ) end if ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from gels() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) & 'Orthogonality of the residuals against the columns/rows of the coefficient matrix = ', err end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing the solution of a linear least squares complex problem of size ', & m, ' by ', n, ' with ', nrhs,' right hand sides is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex2_lapack_gels ! ============================== ! end program ex2_lapack_gels
ex2_lapack_gelsd.F90¶
program ex2_lapack_gelsd ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutine GELSD in LAPACK software ! for computing solution of a linear least squares complex problem using a SVD decomposition ! of the coefficient matrix. The SVD is computed with the divide and conquer method. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : gelsd ! use Statpack, only : lgl, stnd, true, false, zero, c50, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNITT, m AND n ARE THE DIMENSIONS OF THE GENERATED COMPLEX MATRIX, ! nrhs IS THE NUMBER OF RIGHT HAND SIDES OF THE LINEAR LEAST SQUARE PROBLEM. ! integer, parameter :: prtunit = 6, m=4000, n=200, p=min(m,n), k=max(m,n), nrhs=100 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 2 of gelsd' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, eps, rcond, elapsed_time, rwork2(1) real(stnd) :: s(p) real(stnd), allocatable :: ra(:,:), ia(:,:), rb(:,:), ib(:,:), rwork(:) ! complex(stnd) :: work2(1) complex(stnd), allocatable :: work(:), a(:,:), a2(:,:), b(:,:), b2(:,:), res(:,:) ! integer :: info, lwork, liwork, lrwork, rank, iok, iwork2(1), & istart, iend, irate, imax, itime integer, allocatable :: iwork(:) ! logical(lgl) :: do_test ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 2 : MINIMUM-NORM SOLUTION OF A COMPLEX LINEAR LEAST SQUARES PROBLEM ! WITH SEVERAL RIGHT HAND-SIDES USING A SVD DECOMPOSITION OF THE ! COEFFICIENT MATRIX. THE SVD IS COMPUTED WITH THE DIVIDE AND CONQUER ! METHOD. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! THE EFFECTIVE RANK OF THE COMPLEX COEFFICIENT MATRIX OF THE LINEAR LEAST SQUARE PROBLEM, rank, ! IS DETERMINED BY TREATING AS ZERO THOSE SINGULAR VALUES WHICH ARE LESS THAN rcond TIMES ! THE LARGEST SINGULAR VALUE. ! rcond = 0.0000001_stnd ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a(m,n), ra(m,n), ia(m,n), & b(k,nrhs), rb(m,nrhs), ib(m,nrhs), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A m-by-n COMPLEX RANDOM DATA MATRIX a . ! call random_number( ra(:m,:n) ) call random_number( ia(:m,:n) ) ! a(:m,:n) = cmplx( ra(:m,:n), ia(:m,:n), stnd ) ! ! GENERATE A m-by-nrhs COMPLEX RANDOM RIGHT HAND-SIDE MATRIX b . ! call random_number( rb(:m,:nrhs) ) call random_number( ib(:m,:nrhs) ) ! b(:m,:nrhs) = cmplx( rb(:m,:nrhs), ib(:m,:nrhs), stnd ) ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( ra, ia, rb, ib ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(m,n), b2(m,nrhs), res(m,nrhs), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SAVE DATA MATRIX. ! a2(:m,:n) = a(:m,:n) ! ! SAVE RIGHT HAND SIDE MATRIX. ! b2(:m,:nrhs) = b(:m,:nrhs) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR gelsd SUBROUTINE. ! lwork = -1 ! call gelsd( m, n, nrhs, a, m, b, k, s, rcond, rank, work2, lwork, rwork2, iwork2, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) + 10 lrwork = int(rwork2(1)) liwork = iwork2(1) ! ! ALLOCATE WORK VARIABLES NEEDED BY gelsd SUBROUTINE. ! allocate( work(lwork), rwork(lrwork), iwork(liwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! COMPUTE MINIMAL NORM SOLUTION TO THE LINEAR LEAST SQUARES PROBLEM . ! call gelsd( m, n, nrhs, a, m, b, k, s, rcond, rank, work, lwork, rwork, iwork, info ) ! ! THE ROUTINE RETURNS THE SOLUTIONS AND SINGULAR VALUES OF THE COMPLEX LINEAR ! LEAST SQUARE PROBLEM. ! ! ON EXIT OF gelsd : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT the iTH ARGUMENT HAS AN ILLEGAL VALUE ! info=i > 0 : INDICATES THAT the SVD ALGORITHM FAILED TO CONVERGE ! AND i SUBDIAGONAL ELEMENTS OF AN INTERMEDIATE ! BIDIAGONAL MATRIX DID NOT CONVERGE TO ZERO. ! ! ON EXIT OF gelsd : ! ! a IS DESTROYED. ! ! b IS OVERWRITTEN BY THE n-by-nrhs SOLUTION. ! If m >= n AND rank = n, THE RESIDUAL SUM-OF-SQUARES ! FOR THE SOLUTION IN THE i-th COLUMN IS GIVEN BY THE ! SUM OF SQUARES OF THE MODULUS OF ELEMENTS n+1:m IN ! THAT COLUMN. ! ! s IS OVERWRITTEN WITH THE SINGULAR VALUES OF a ! IN DECREASING ORDER. ! ! rank IS OVERWRITTEN BY THE EFFECTIVE RANK OF a, i.e. ! THE NUMBER OF SINGULAR VALUES WHICH ARE GREATER ! THAN rcond*s(1) . ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( work, iwork, rwork ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM gelsd SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to GELSD subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test ) then ! ! CHECK THAT THE RESIDUALS ARE ORTHOGONAL TO THE COLUMN VECTORS OF a . ! res = b2 - matmul( a2, b(:n,:nrhs) ) err = maxval( sum(abs(matmul(transpose(conjg(a2)),res)), dim=1) )/ sum( abs(a2) ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, b, a2, b2, res ) else deallocate( a, b ) end if ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from gelsd() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) & 'Orthogonality of the residuals against the columns of the coefficient matrix = ', err end if ! write (prtunit,*) write (*,'(a,i5,a,i5,a,i5,a,0pd12.4,a)') & 'The elapsed time for computing the solution of a linear least squares complex problem of size ', & m, ' by ', n, ' with ', nrhs,' right hand sides is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex2_lapack_gelsd ! =============================== ! end program ex2_lapack_gelsd
ex2_lapack_gelss.F90¶
program ex2_lapack_gelss ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutine GELSS in LAPACK software ! for computing solution of a linear least squares complex problem using a SVD decomposition ! of the coefficient matrix. The SVD is computed with the Golub and Reinsch bidiagonal QR method. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : gelss ! use Statpack, only : lgl, stnd, true, false, zero, c50, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, m AND n ARE THE DIMENSIONS OF THE GENERATED COMPLEX MATRIX, ! nrhs IS THE NUMBER OF RIGHT HAND SIDES OF THE LINEAR LEAST SQUARE PROBLEM. ! integer, parameter :: prtunit = 6, m=4000, n=200, p=min(m,n), k=max(m,n), nrhs=100 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 2 of gelss' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, eps, rcond, elapsed_time real(stnd) :: s(p) real(stnd), allocatable :: ra(:,:), ia(:,:), rb(:,:), ib(:,:), rwork(:) ! complex(stnd) :: work2(1) complex(stnd), allocatable :: work(:), a(:,:), a2(:,:), b(:,:), b2(:,:), res(:,:) ! integer :: info, lwork, rank, iok, istart, iend, irate, imax, itime ! logical(lgl) :: do_test ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 2 : MINIMUM-NORM SOLUTION OF A COMPLEX LINEAR LEAST SQUARES PROBLEM ! WITH SEVERAL RIGHT HAND-SIDES USING A SVD DECOMPOSITION OF THE ! COEFFICIENT MATRIX. THE SVD IS COMPUTED WITH THE GOLUB-REINSCH ! METHOD. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! THE EFFECTIVE RANK OF THE COMPLEX COEFFICIENT MATRIX OF THE LINEAR LEAST SQUARE PROBLEM, rank, ! IS DETERMINED BY TREATING AS ZERO THOSE SINGULAR VALUES WHICH ARE LESS THAN rcond TIMES ! THE LARGEST SINGULAR VALUE. ! rcond = 0.0000001_stnd ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a(m,n), ra(m,n), ia(m,n), & b(k,nrhs), rb(m,nrhs), ib(m,nrhs), & rwork( 5*p ), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A m-by-n COMPLEX RANDOM DATA MATRIX a . ! call random_number( ra(:m,:n) ) call random_number( ia(:m,:n) ) ! a(:m,:n) = cmplx( ra(:m,:n), ia(:m,:n), stnd ) ! ! GENERATE A m-by-nrhs COMPLEX RANDOM RIGHT HAND-SIDE MATRIX b . ! call random_number( rb(:m,:nrhs) ) call random_number( ib(:m,:nrhs) ) ! b(:m,:nrhs) = cmplx( rb(:m,:nrhs), ib(:m,:nrhs), stnd ) ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( ra, ia, rb, ib ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(m,n), b2(m,nrhs), res(m,nrhs), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SAVE DATA MATRIX. ! a2(:m,:n) = a(:m,:n) ! ! SAVE RIGHT HAND SIDE MATRIX. ! b2(:m,:nrhs) = b(:m,:nrhs) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR gelss SUBROUTINE. ! lwork = -1 ! call gelss( m, n, nrhs, a, m, b, k, s, rcond, rank, work2, lwork, rwork, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) + 10 ! ! ALLOCATE WORK VARIABLE NEEDED BY gelss SUBROUTINE. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! COMPUTE MINIMAL NORM SOLUTION TO THE LINEAR LEAST SQUARES PROBLEM . ! call gelss( m, n, nrhs, a, m, b, k, s, rcond, rank, work, lwork, rwork, info ) ! ! THE ROUTINE RETURNS THE SOLUTIONS AND SINGULAR VALUES OF THE COMPLEX LINEAR ! LEAST SQUARE PROBLEM. ! ! ON EXIT OF gelss : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT the iTH ARGUMENT HAS AN ILLEGAL VALUE ! info=i > 0 : INDICATES THAT the SVD ALGORITHM FAILED TO CONVERGE ! AND i SUBDIAGONAL ELEMENTS OF AN INTERMEDIATE ! BIDIAGONAL MATRIX DID NOT CONVERGE TO ZERO. ! ! ON EXIT OF gelss : ! ! a IS OVERWRITTEN BY THE FIRST min(n,m) RIGHT SINGULAR ! VECTORS OF a STORED ROW-WISE (e.g. IN THE FIRST min(n,m) ! ROWS OF a). ! ! b IS OVERWRITTEN BY THE n-by-nrhs SOLUTION. ! If m >= n AND rank = n, THE RESIDUAL SUM-OF-SQUARES ! FOR THE SOLUTION IN THE i-th COLUMN IS GIVEN BY THE ! SUM OF SQUARES OF THE MODULUS OF ELEMENTS n+1:m IN ! THAT COLUMN. ! ! s IS OVERWRITTEN WITH THE SINGULAR VALUES OF a ! IN DECREASING ORDER. ! ! rank IS OVERWRITTEN BY THE EFFECTIVE RANK OF a, i.e. ! THE NUMBER OF SINGULAR VALUES WHICH ARE GREATER ! THAN rcond*s(1) . ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM gelss SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to GELSS subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test ) then ! ! CHECK THAT THE RESIDUALS ARE ORTHOGONAL TO THE COLUMN VECTORS OF a . ! res = b2 - matmul( a2, b(:n,:nrhs) ) err = maxval( sum(abs(matmul(transpose(conjg(a2)),res)), dim=1) )/ sum( abs(a2) ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, b, rwork, a2, b2, res ) else deallocate( a, b, rwork ) end if ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from gelss() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) & 'Orthogonality of the residuals against the columns of the coefficient matrix = ', err end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing the solution of a linear least squares complex problem of size ', & m, ' by ', n, ' with ', nrhs,' right hand sides is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex2_lapack_gelss ! =============================== ! end program ex2_lapack_gelss
ex2_lapack_gelsy.F90¶
program ex2_lapack_gelsy ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutine GELSY in LAPACK software ! for computing solution of a linear least squares complex problem using a complete orthogonal ! factorization of the coefficient matrix. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : gelsy ! use Statpack, only : lgl, stnd, true, false, zero, c50, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, m AND n ARE THE DIMENSIONS OF THE GENERATED COMPLEX MATRIX, ! nrhs IS THE NUMBER OF RIGHT HAND SIDES OF THE LINEAR LEAST SQUARE PROBLEM. ! integer, parameter :: prtunit = 6, m=4000, n=2000, p=min(m,n), k=max(m,n), nrhs=400 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 2 of gelsy' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, eps, rcond, elapsed_time real(stnd), allocatable :: ra(:,:), ia(:,:), rb(:,:), ib(:,:), rwork(:) ! complex(stnd) :: work2(1) complex(stnd), allocatable :: work(:), a(:,:), a2(:,:), b(:,:), b2(:,:), res(:,:) ! integer, allocatable :: jpvt(:) integer :: info, lwork, rank, iok, istart, iend, irate, imax, itime ! logical(lgl) :: do_test ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 2 : MINIMUM-NORM SOLUTION OF A COMPLEX LINEAR LEAST SQUARES PROBLEM ! WITH SEVERAL RIGHT HAND-SIDES USING A COMPLETE ORTHOGONAL ! FACTORIZATION OF THE COEFFICIENT MATRIX. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! rcond IS USED TO DETERMINE THE EFFECTIVE RANK OF THE COEFFICIENT MATRIX, ! WHICH IS DEFINED AS THE ORDER OF THE LARGEST LEADING TRIANGULAR SUBMATRIX ! R11 IN THE QR FACTORIZATION WITH PIVOTING OF THE COEFFICIENT MATRIX, WHOSE ! ESTIMATED CONDITION NUMBER IS LESS THAN 1/rcond . ! rcond = 0.0000001_stnd ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = false ! ! ALLOCATE WORK ARRAYS. ! allocate( a(m,n), ra(m,n), ia(m,n), & b(k,nrhs), rb(m,nrhs), ib(m,nrhs), & jpvt(n), rwork(2*n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A m-by-n COMPLEX RANDOM DATA MATRIX a . ! call random_number( ra(:m,:n) ) call random_number( ia(:m,:n) ) ! a(:m,:n) = cmplx( ra(:m,:n), ia(:m,:n), stnd ) ! ! GENERATE A m-by-nrhs COMPLEX RANDOM RIGHT HAND-SIDE MATRIX b . ! call random_number( rb(:m,:nrhs) ) call random_number( ib(:m,:nrhs) ) ! b(:m,:nrhs) = cmplx( rb(:m,:nrhs), ib(:m,:nrhs), stnd ) ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( ra, ia, rb, ib ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(m,n), b2(m,nrhs), res(m,nrhs), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SAVE DATA MATRIX. ! a2(:m,:n) = a(:m,:n) ! ! SAVE RIGHT HAND SIDE MATRIX. ! b2(:m,:nrhs) = b(:m,:nrhs) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! INITIALIZE PERMUTATION VECTOR FOR COMPLETE PIVOTING OF THE ! COLUMNS OF a . ! jpvt(:n) = 0 ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR gelsy SUBROUTINE. ! lwork = -1 ! call gelsy( m, n, nrhs, a, m, b, k, jpvt, rcond, rank, work2, lwork, rwork, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) ! ! ALLOCATE WORK VARIABLE NEEDED BY gelsy SUBROUTINE. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! COMPUTE MINIMAL NORM SOLUTION TO THE LINEAR LEAST SQUARES PROBLEM . ! call gelsy( m, n, nrhs, a, m, b, k, jpvt, rcond, rank, work, lwork, rwork, info ) ! ! THE ROUTINE RETURNS THE SOLUTION OF THE LINEAR ! LEAST SQUARE PROBLEM. ! ! ON EXIT OF gelsy : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT the iTH ARGUMENT HAS AN ILLEGAL VALUE ! ! ON EXIT OF gelsy : ! ! a IS OVERWRITTEN BY DETAILS OF ITS COMPLETE ORTHOGONAL ! FACTORIZATION. ! ! b IS OVERWRITTEN BY THE n-by-nrhs MINIMUM-NORM SOLUTION. ! ! rank IS OVERWRITTEN BY THE EFFECTIVE RANK OF a. ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM gelsy SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to GELSY subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test ) then ! ! CHECK THAT THE RESIDUALS ARE ORTHOGONAL TO THE COLUMN VECTORS OF a . ! res = b2 - matmul( a2, b(:n,:nrhs) ) err = maxval( sum(abs(matmul(transpose(conjg(a2)),res)), dim=1) )/ sum( abs(a2) ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, b, jpvt, rwork, a2, b2, res ) else deallocate( a, b, jpvt, rwork ) end if ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from gelsy() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) & 'Orthogonality of the residuals against the columns of the coefficient matrix = ', err end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing the solution of a linear least squares complex problem of size ', & m, ' by ', n, ' with ', nrhs,' right hand sides is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex2_lapack_gelsy ! =============================== ! end program ex2_lapack_gelsy
ex2_lapack_gesdd.F90¶
program ex2_lapack_gesdd ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of the driver subroutine GESDD ! in LAPACK software for computing a full SVD decomposition of a complex matrix by ! the divide and conquer method. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : gesdd ! use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, unit_matrix, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, m AND n ARE THE DIMENSIONS OF THE GENERATED COMPLEX MATRIX. ! integer, parameter :: prtunit = 6, m=2000, n=2000, k=min(m,n) ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 2 of gesdd' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, err1, err2, err3, eps, elapsed_time real(stnd) :: rwork2(1) real(stnd), allocatable, dimension(:) :: s, rwork real(stnd), allocatable, dimension(:,:) :: ra, ia, resid_ortho ! complex(stnd) :: work2(1) complex(stnd), allocatable, dimension(:) :: work complex(stnd), allocatable, dimension(:,:) :: a, a2, c, resid ! integer :: info, lwork, lrwork, iok, istart, iend, irate, imax, itime integer, allocatable, dimension(:) :: iwork ! logical(lgl) :: do_test ! character :: jobz ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 2 : FULL SVD OF A COMPLEX MATRIX USING THE DIVIDE AND CONQUER METHOD. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a(m,n), ra(m,n), ia(m,n), c(k,k), s(k), iwork(8*k), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A m-by-n COMPLEX RANDOM DATA MATRIX . ! call random_number( ra(:m,:n) ) call random_number( ia(:m,:n) ) ! a(:m,:n) = cmplx( ra(:m,:n), ia(:m,:n), stnd ) ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( ra, ia ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(m,n), resid(m,k), resid_ortho(k,k), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! MAKE A COPY OF THE COMPLEX RANDOM DATA MATRIX . ! a2(:m,:n) = a(:m,:n) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! DETERMINE THE WORK TO DO AND HOW THE SINGULAR VECTORS WILL BE STORED. ! WITH THE ARGUMENTS BELOW, THE SINGULAR VECTORS ARE COMPUTED AND ! STORED AS IN SUBROUTINE svd_cmp2 IN STATPACK. ! jobz = 'O' ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR gesdd SUBROUTINE. ! lwork = -1 ! call gesdd( jobz, m, n, a, m, s, c, k, c, k, work2, lwork, rwork2, iwork, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) + 10 lrwork = k*max(5*k+7,2*max(m,n)+2*k+1) ! ! ALLOCATE WORK VARIABLES NEEDED BY gesdd SUBROUTINE. ! allocate( work(lwork), rwork(lrwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! gesdd COMPUTES THE SINGULAR VALUE DECOMPOSITION (SVD) OF A COMPLEX ! m-BY-n MATRIX a. THE SVD IS WRITTEN ! ! a = U * S * V**(h) ! ! WHERE S IS AN m-BY-n MATRIX WHICH IS ZERO EXCEPT FOR ITS ! min(m,n) DIAGONAL ELEMENTS, U IS AN m-BY-m UNITARY MATRIX, AND ! V IS AN n-BY-n UNITARY MATRIX. THE DIAGONAL ELEMENTS OF S ! ARE THE SINGULAR VALUES OF a; THEY ARE REAL AND NON-NEGATIVE. ! THE COLUMNS OF U AND V ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a. ! call gesdd( jobz, m, n, a, m, s, c, k, c, k, work, lwork, rwork, iwork, info ) ! ! THE ROUTINE RETURNS THE SINGULAR VALUES, THE LEFT AND RIGHT ! SINGULAR VECTORS. THE RIGHT SINGULAR VECTORS ARE RETURNED ROWWISE. ! MORE PRECISELY, THE ROUTINE RETURNS THE CONJUGATE-TRANSPOSE OF ! THE RIGHT SINGULAR VECTORS. ! ! ON EXIT OF gesdd : ! ! info= 0 : INDICATES SUCCESSFUL EXIT. ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE. ! info=i > 0 : INDICATES THAT THE ALGORITHM FAILED TO CONVERGE. ! ! ON EXIT OF gesdd IF JOBZ='O': ! ! IF m>=n, a IS OVERWRITTEN WITH THE FIRST min(m,n) ! COLUMNS OF U (THE LEFT SINGULAR VECTORS, ! STORED COLUMNWISE); ! c CONTAINS THE n-BY-n UNITARY MATRIX V**(h). ! ! IF m<n, a IS OVERWRITTEN WITH THE FIRST min(m,n) ! ROWS OF V**(h) (THE RIGHT SINGULAR VECTORS, ! STORED ROWWISE); ! c CONTAINS THE m-BY-m UNITARY MATRIX U. ! ! s IS OVERWRITTEN WITH THE SINGULAR VALUES OF a IN DECREASING ORDER. ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( work, rwork ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM gesdd SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to GESDD subroutine, Info=', info ! else if ( do_test ) then ! if ( m>=n ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a(:m,:n)*V(:n,:k) - U(:m,:k)*S(:k,:k). ! resid(:m,:k) = matmul(a2(:m,:k),transpose(conjg(c(:k,:k)))) - a(:m,:k)*spread(s,dim=1,ncopies=m) resid_ortho(:k,1_i4b) = norm( resid(:m,:k), dim=2_i4b ) err1 = maxval( resid_ortho(:k,1_i4b) )/( sum( abs(s) )*real(m,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U. ! call unit_matrix( a2(:n,:n) ) ! resid_ortho(:n,:n) = abs( a2(:n,:n) - matmul( transpose(conjg(a(:m,:n))), a(:m,:n) ) ) err2 = maxval( resid_ortho(:n,:n) )/real(m,stnd) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - V**(t)*V. ! resid_ortho(:n,:n) = abs( a2(:n,:n) - matmul( c(:n,:n), transpose(conjg(c(:n,:n))) ) ) err3 = maxval( resid_ortho(:n,:n) )/real(n,stnd) ! else ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a(:m,:n)*V(:n,:k) - U(:m,:k)*S(:k,:k). ! resid(:m,:k) = matmul(a2(:m,:n),transpose(conjg(a(:k,:n)))) - c(:k,:k)*spread(s,dim=1,ncopies=k) resid_ortho(:k,1_i4b) = norm( resid(:m,:k), dim=2_i4b ) err1 = maxval( resid_ortho(:k,1_i4b) )/( sum( abs(s) )*real(m,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U. ! call unit_matrix( a2(:m,:m) ) ! resid_ortho(:m,:m) = abs( a2(:m,:m) - matmul( transpose(conjg(c(:m,:m ))), c(:m,:m ) ) ) err2 = maxval( resid_ortho(:m,:m) )/real(m,stnd) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - V**(t)*V. ! resid_ortho(:m,:m) = abs( a2(:m,:m) - matmul( a(:m,:n), transpose(conjg(a(:m,:n))) ) ) err3 = maxval( resid_ortho(:m,:m) )/real(n,stnd) ! end if ! err = max( err1, err2, err3 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, c, s, iwork, a2, resid, resid_ortho ) else deallocate( a, c, s, iwork ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from gesdd() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed singular triplets = ', err1 write (prtunit,*) 'Orthogonality of the computed left singular vectors = ', err2 write (prtunit,*) 'Orthogonality of the computed right singular vectors = ', err3 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing all singular values and vectors of a', & m, ' by', n,' complex matrix is', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex2_lapack_gesdd ! =============================== ! end program ex2_lapack_gesdd
ex2_lapack_gesv.F90¶
program ex2_lapack_gesv ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of the driver subroutine GESV ! in LAPACK software for solving a complex linear system with the help of a LU decomposition ! with partial pivoting. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : gesv ! use Statpack, only : lgl, i4b, stnd, true, false, zero, c100, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, n IS THE DIMENSION OF THE COMPLEX LINEAR SYSTEM, ! nrhs IS THE NUMBER OF RIGHT HAND SIDES OF THE COMPLEX LINEAR PROBLEM TO BE SOLVED. ! integer, parameter :: prtunit = 6, n=1000, nrhs=200 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c100 ! character(len=*), parameter :: name_proc='Example 2 of gesv' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, eps, elapsed_time real(stnd), dimension(:,:), allocatable :: ra, ia, rx, ix ! complex(stnd), dimension(:,:), allocatable :: a, b, x, res ! integer(i4b), dimension(:), allocatable :: ipiv integer :: info, iok, istart, iend, irate, imax, itime ! logical(lgl) :: do_test ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 2 : SOLUTION OF A LINEAR SYSTEM WITH A COMPLEX COEFFICIENT ! MATRIX AND SEVERAL RIGHT HAND-SIDES BY A LU DECOMPOSITION ! WITH PARTIAL PIVOTING. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*real( n, stnd )*epsilon( err ) ! eps = sqrt( epsilon( err ) ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a(n,n), ra(n,n), ia(n,n), b(n,nrhs), x(n,nrhs), & rx(n,nrhs), ix(n,nrhs), ipiv(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A n-by-n COMPLEX RANDOM DATA MATRIX a . ! call random_number( ra(:n,:n) ) call random_number( ia(:n,:n) ) ! a(:n,:n) = cmplx( ra(:n,:n), ia(:n,:n), stnd ) ! ! GENERATE A n-by-nrhs COMPLEX RANDOM SOLUTION MATRIX x . ! call random_number( rx(:n,:nrhs) ) call random_number( ix(:n,:nrhs) ) ! x(:n,:nrhs) = cmplx( rx(:n,:nrhs), ix(:n,:nrhs), stnd ) ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( ra, ia, rx, ix ) ! ! COMPUTE THE MATRIX-MATRIX PRODUCT b = a*x . ! b = matmul( a, x ) ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! COMPUTE THE SOLUTION MATRIX FOR COMPLEX LINEAR SYSTEM ! ! a*x = b . ! ! WHERE a IS A n-BY-n MATRIX AND b IS A n-BY-nrhs MATRIX. ! ! THE LU DECOMPOSITION WITH PARTIAL PIVOTING AND ROW INTERCHANGES ! IS USED TO FACTOR a AS ! ! a = P*L*U ! ! WHERE P IS PERMUTATION MATRIX, L IS UNIT LOWER TRIANGULAR, AND U IS ! UPPER TRIANGULAR. THE FACTORED FORM OF a IS THEN USED TO SOLVE THE ! SYSTEM OF EQUATIONS. ! call gesv( n, nrhs, a, n, ipiv, b, n, info ) ! ! ON EXIT OF gesv : ! ! info = 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT the iTH ARGUMENT HAS AN ILLEGAL VALUE ! info=i > 0 : INDICATES THAT THE SOLUTION CAN NOT BE COMPUTED BECAUSE ! THE MATRIX IS SINGULAR ! ! ON EXIT OF gesv IF info = 0: ! ! a IS OVERWRITTEN BY THE FACTORS L AND U OF ITS FACTORIZATION. ! THE UNIT DIAGONAL ELEMENTS OF L ARE NOT STORED. ! ! ipiv STORES THE PIVOT INDICES THAT DEFINE THE PERMUTATION MATRIX P. ! ROW i OF THE MATRIX WAS INTERCHANGED WITH ROW ipiv(i). ! ! b IS OVERWRITTEN WITH THE SOLUTION MATRIX x. ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM gesv SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to GESV subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test ) then ! ! ALLOCATE WORK ARRAY . ! allocate( res(n,nrhs), stat=iok ) ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! res(:n,:nrhs) = b(:n,:nrhs) - x(:n,:nrhs) err = maxval( sum( abs(res), dim=1 ) / & sum(abs(x), dim=1 ) ) ! ! DEALLOCATE WORK ARRAY. ! deallocate( res ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! deallocate( a, b, x, ipiv ) ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from gesv() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed solutions = ', err end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing the solutions of a linear complex system of size ', & n, ' with ', nrhs,' right hand sides is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex2_lapack_gesv ! ============================== ! end program ex2_lapack_gesv
ex2_lapack_gesvd.F90¶
program ex2_lapack_gesvd ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of the driver subroutine GESVD ! in LAPACK software for computing a full SVD decomposition of a complex matrix by ! the Golub and Reinsch bidiagonal QR method. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : gesvd ! use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, unit_matrix, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, m AND n ARE THE DIMENSIONS OF THE GENERATED COMPLEX MATRIX. ! integer, parameter :: prtunit = 6, m=100, n=101, k=min(m,n) ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 2 of gesvd' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, err1, err2, err3, eps, elapsed_time real(stnd), allocatable, dimension(:) :: s, rwork real(stnd), allocatable, dimension(:,:) :: ra, ia, resid_ortho ! complex(stnd) :: work2(1) complex(stnd), allocatable, dimension(:) :: work complex(stnd), allocatable, dimension(:,:) :: a, a2, c, resid ! integer :: info, lwork, iok, istart, iend, irate, imax, itime ! logical(lgl) :: do_test ! character :: jobu, jobvt ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : FULL SVD OF A COMPLEX MATRIX USING THE QR IMPLICIT METHOD. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a(m,n), ra(m,n), ia(m,n), c(k,k), s(k), rwork(5*k), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A m-by-n COMPLEX RANDOM DATA MATRIX . ! call random_number( ra(:m,:n) ) call random_number( ia(:m,:n) ) ! a(:m,:n) = cmplx( ra(:m,:n), ia(:m,:n), stnd ) ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( ra, ia ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(m,n), resid(m,k), resid_ortho(k,k), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! MAKE A COPY OF THE COMPLEX RANDOM DATA MATRIX. ! a2(:m,:n) = a(:m,:n) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! DETERMINE THE WORK TO DO AND HOW THE SINGULAR VECTORS WILL BE STORED. ! WITH THE ARGUMENTS BELOW, THE SINGULAR VECTORS ARE COMPUTED AND ! STORED AS IN SUBROUTINE svd_cmp2 IN STATPACK. ! if ( m>=n ) then jobu = 'O' jobvt = 'S' else jobu = 'S' jobvt = 'O' end if ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR gesvd SUBROUTINE. ! lwork = -1 ! call gesvd( jobu, jobvt, m, n, a, m, s, c, k, c, k, work2, lwork, rwork, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) ! ! ALLOCATE OPTIMAL WORK VARIABLE NEEDED BY gesvd SUBROUTINE. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! gesvd COMPUTES THE SINGULAR VALUE DECOMPOSITION (SVD) OF A COMPLEX ! m-BY-n MATRIX a. THE SVD IS WRITTEN ! ! a = U * S * V**(h) ! ! WHERE S IS AN m-BY-n MATRIX WHICH IS ZERO EXCEPT FOR ITS ! min(m,n) DIAGONAL ELEMENTS, U IS AN m-BY-m UNITARY MATRIX, AND ! V IS AN n-BY-n UNITARY MATRIX. THE DIAGONAL ELEMENTS OF S ! ARE THE SINGULAR VALUES OF a; THEY ARE REAL AND NON-NEGATIVE. ! THE COLUMNS OF U AND V ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a. ! call gesvd( jobu, jobvt, m, n, a, m, s, c, k, c, k, work, lwork, rwork, info ) ! ! THE ROUTINE RETURNS THE SINGULAR VALUES, THE LEFT AND RIGHT ! SINGULAR VECTORS. THE RIGHT SINGULAR VECTORS ARE RETURNED ROWWISE. ! MORE PRECISELY, THE ROUTINE RETURNS THE CONJUGATE-TRANSPOSE OF ! THE RIGHT SINGULAR VECTORS. ! ! ON EXIT OF gesvd : ! ! info= 0 : INDICATES SUCCESSFUL EXIT. ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE. ! info=i > 0 : INDICATES THAT THE ALGORITHM FAILED TO CONVERGE ! AND i OFF-DIAGONAL ELEMENTS OF AN INTERMEDIATE ! BIDIAGONAL FORM OF a DID NOT CONVERGE TO ZERO. ! ! ON EXIT OF gesvd WITH THE VALUES SPECIFIED FOR jobu AND jobvt : ! ! IF m>=n, a IS OVERWRITTEN WITH THE FIRST min(m,n) ! COLUMNS OF U (THE LEFT SINGULAR VECTORS, ! STORED COLUMNWISE); ! c CONTAINS THE n-BY-n UNITARY MATRIX V**(h). ! ! IF m<n, a IS OVERWRITTEN WITH THE FIRST min(m,n) ! ROWS OF V**(h) (THE RIGHT SINGULAR VECTORS, ! STORED ROWWISE); ! c CONTAINS THE m-BY-m UNITARY MATRIX U. ! ! s IS OVERWRITTEN WITH THE SINGULAR VALUES OF a IN DECREASING ORDER. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM gesvd SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to GESVD subroutine, Info=', info ! else if ( do_test ) then ! if ( m>=n ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a(:m,:n)*V(:n,:k) - U(:m,:k)*S(:k,:k). ! resid(:m,:k) = matmul(a2(:m,:k),transpose(conjg(c(:k,:k)))) - a(:m,:k)*spread(s,dim=1,ncopies=m) resid_ortho(:k,1_i4b) = norm( resid(:m,:k), dim=2_i4b ) err1 = maxval( resid_ortho(:k,1_i4b) )/( sum( abs(s) )*real(m,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U. ! call unit_matrix( a2(:n,:n) ) ! resid_ortho(:n,:n) = abs( a2(:n,:n) - matmul( transpose(conjg(a(:m,:n))), a(:m,:n) ) ) err2 = maxval( resid_ortho(:n,:n) )/real(m,stnd) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - V**(t)*V. ! resid_ortho(:n,:n) = abs( a2(:n,:n) - matmul( c(:n,:n), transpose(conjg(c(:n,:n))) ) ) err3 = maxval( resid_ortho(:n,:n) )/real(n,stnd) ! else ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a(:m,:n)*V(:n,:k) - U(:m,:k)*S(:k,:k). ! resid(:m,:k) = matmul(a2(:m,:n),transpose(conjg(a(:k,:n)))) - c(:k,:k)*spread(s,dim=1,ncopies=k) resid_ortho(:k,1_i4b) = norm( resid(:m,:k), dim=2_i4b ) err1 = maxval( resid_ortho(:k,1_i4b) )/( sum( abs(s) )*real(m,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U. ! call unit_matrix( a2(:m,:m) ) ! resid_ortho(:m,:m) = abs( a2(:m,:m) - matmul( transpose(conjg(c(:m,:m ))), c(:m,:m ) ) ) err2 = maxval( resid_ortho(:m,:m) )/real(m,stnd) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - V**(t)*V. ! resid_ortho(:m,:m) = abs( a2(:m,:m) - matmul( a(:m,:n), transpose(conjg(a(:m,:n))) ) ) err3 = maxval( resid_ortho(:m,:m) )/real(n,stnd) ! end if ! err = max( err1, err2, err3 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, c, s, rwork, a2, resid, resid_ortho ) else deallocate( a, c, s, rwork ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from gesvd() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed singular triplets = ', err1 write (prtunit,*) 'Orthogonality of the computed left singular vectors = ', err2 write (prtunit,*) 'Orthogonality of the computed right singular vectors = ', err3 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing all singular values and vectors of a ', & m, ' by ', n,' complex matrix is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex2_lapack_gesvd ! =============================== ! end program ex2_lapack_gesvd
ex2_lapack_gesvdx.F90¶
program ex2_lapack_gesvdx ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of the driver subroutine GESVDX ! in LAPACK software for computing all or selected singular triplets of a complex matrix. ! The singular triplets are computed by the bisection and inverse iteration methods ! applied to an associated eigenvalue problem. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : gesvdx ! use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, unit_matrix, merror, & allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, m AND n ARE THE DIMENSIONS OF THE GENERATED COMPLEX MATRIX, ! nsing IS THE TARGET RANK OF THE APPROXIMATE PARTIAL SVD, WHICH IS SOUGHT. ! integer, parameter :: prtunit = 6, m=1000, n=1000, k=min(m,n), nsing=100 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 2 of gesvdx' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, err1, err2, err3, eps, elapsed_time, vl, vu real(stnd), allocatable, dimension(:) :: s, rwork real(stnd), allocatable, dimension(:,:) :: ra, ia, resid_ortho ! complex(stnd) :: work2(1) complex(stnd), allocatable, dimension(:) :: work complex(stnd), allocatable, dimension(:,:) :: a, a2, u, vt ! integer :: info, lwork, il, iu, ns, iok, & istart, iend, irate, imax, itime integer, allocatable, dimension(:) :: iwork ! logical(lgl) :: do_test ! character :: jobu, jobvt, range ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : FULL OR PARTIAL SVD OF A COMPLEX MATRIX USING AN ASSOCIATED EIGENVALUE PROBLEM ! AND THE BISECTION AND INVERSE ITERATION METHODS. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a(m,n), ra(m,n), ia(m,n), u(m,k), vt(k,n), s(k), & iwork(12*k), rwork((k+1)*(2*k)+16*k), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A m-by-n COMPLEX RANDOM DATA MATRIX. ! call random_number( ra(:m,:n) ) call random_number( ia(:m,:n) ) ! a(:m,:n) = cmplx( ra(:m,:n), ia(:m,:n), stnd ) ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( ra, ia ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAY. ! allocate( a2(m,n), resid_ortho(k,k), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! MAKE A COPY OF THE RANDOM DATA MATRIX. ! a2(:m,:n) = a(:m,:n) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! DETERMINE THE WORK TO DO AND HOW MANY SINGULAR TRIPLETS ! WILL BE COMPUTED AND STORED. ! ! IF jobu = 'V', LEFT SINGULAR VECTORS WILL BE COMPUTED. ! IF jobu = 'N', LEFT SINGULAR VECTORS WILL NOT BE COMPUTED. ! IF jobvt = 'V', RIGHT SINGULAR VECTORS WILL BE COMPUTED. ! IF jobvt = 'N', RIGHT SINGULAR VECTORS WILL NOT BE COMPUTED. ! jobu = 'V' jobvt = 'V' ! ! range DETERMINED HOW MANY SINGULAR VALUES AND VECTORS WILL BE COMPUTED. ! ! IF range='A' ALL SINGULAR VALUES WILL BE FOUND, ! IF range='V' ALL SINGULAR VALUES IN THE HALF OPEN INTERVAL (vl,vu] WILL BE FOUND, ! IF range='I' THE il-TH THROUGH iu-TH SINGULAR VALUES IN DESCENDING ORDER WILL BE FOUND. ! ! IN EACH CASE, THE ASSOCIATED SINGULAR VECTORS WILL BE ALSO COMPUTED. ! ! range = 'A' range = 'I' ! vl = zero vu = zero ! ! FOR FINDING THE nsing LARGEST SINGULAR VALUES USE THE NEXT TWO LINES. ! il = 1 iu = nsing ! ! FOR FINDING THE nsing SMALLEST SINGULAR VALUES USE THE NEXT TWO LINES. ! ! il = k - nsing + 1 ! iu = k ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR gesvdx SUBROUTINE. ! lwork = -1 ! call gesvdx( jobu, jobvt, range, m, n, a, m, vl, vu, il, iu, ns, & s, u, m, vt, k, work2, lwork, rwork, iwork, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) ! ! ALLOCATE OPTIMAL WORK VARIABLE NEEDED BY gesvdx SUBROUTINE. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! gesvdx COMPUTES THE SINGULAR VALUE DECOMPOSITION (SVD) OF A COMPLEX ! m-BY-n MATRIX a BY SOLVING AN ASSOCIATE EIGENVALUE PROBLEM. THE SVD ! IS WRITTEN ! ! a = U * S * V**(h) ! ! WHERE S IS AN m-BY-n MATRIX WHICH IS ZERO EXCEPT FOR ITS ! min(m,n) DIAGONAL ELEMENTS, U IS AN m-BY-m UNITARY MATRIX, AND ! V IS AN n-BY-n UNITARY MATRIX. THE DIAGONAL ELEMENTS OF S ! ARE THE SINGULAR VALUES OF a; THEY ARE REAL AND NON-NEGATIVE. ! THE COLUMNS OF U AND V ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a. ! ! THE ADVANTAGE OF gesvdx SUBROUTINE COMPARED TO OTHER SVD SUBROUTINES ! AVAILABLE IN LAPACK (E.G. gesvd OR gesdd) IS THAT gesvdx IS ABLE TO COMPUTE ! A PARTIAL SVD DECOMPOSITION OR SELECTED SINGULAR TRIPLETS OF THE INPUT ! COMPLEX MATRIX WHILE THE OTHER SUBROUTINES DO NOT OFFER THIS POSSIBILITY. ! HOWEVER, BEWARE THAT THE gesvdx SUBROUTINE IS AVAILABLE ONLY IN LAPACK 3.6.0 ! AND ABOVE. ! call gesvdx( jobu, jobvt, range, m, n, a, m, vl, vu, il, iu, ns, & s, u, m, vt, k, work, lwork, rwork, iwork, info ) ! ! THE ROUTINE RETURNS THE SINGULAR VALUES, THE LEFT AND RIGHT ! SINGULAR VECTORS. THE RIGHT SINGULAR VECTORS ARE RETURNED ROWWISE. ! MORE PRECISELY, THE ROUTINE RETURNS THE CONJUGATE-TRANSPOSE OF ! THE RIGHT SINGULAR VECTORS. ! ! ON EXIT OF gesvdx : ! ! info= 0 : INDICATES SUCCESSFUL EXIT. ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE. ! info=i > 0 : INDICATES THAT i EIVENVECTORS FAILED TO CONVERGE. ! info=n*2+1 : INDICATES THAT AN INTERNAL ERROR OCCURRED. ! ! ON EXIT OF gesvdx WITH THE VALUES SPECIFIED ABOVE FOR jobu ('V'), ! jobvt ('V') AND range ('A'): ! ! u IS OVERWRITTEN WITH THE FIRST min(m,n) ! COLUMNS OF U (THE LEFT SINGULAR VECTORS, ! STORED COLUMNWISE); ! ! vt IS OVERWRITTEN WITH THE FIRST min(m,n) ! ROWS OF V**(h) (THE RIGHT SINGULAR VECTORS, ! STORED ROWWISE); ! ! s IS OVERWRITTEN WITH THE SINGULAR VALUES OF a IN DECREASING ORDER. ! ! FOR range='I' OR range='V', ns IS THE NUMBER OF SINGULAR TRIPLETS ! COMPUTED AND STORED BY THE SUBROUTINE IN ARGUMENTS u, vt AND s. ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart ! if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM gesvdx SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to GESVDX subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a(:m,:n)*V(:n,:ns) - U(:m,:ns)*S(:ns,:ns). ! a(:m,:ns) = matmul(a2(:m,:n),transpose(conjg(vt(:ns,:n)))) - u(:m,:ns)*spread(s(:ns),dim=1,ncopies=m) resid_ortho(:ns,1_i4b) = norm( a(:m,:ns), dim=2_i4b ) ! err1 = maxval( resid_ortho(:ns,1_i4b) )/( norm( a2 )*real(m,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(h)*U. ! call unit_matrix( a2(:ns,:ns) ) ! resid_ortho(:ns,:ns) = abs( a2(:ns,:ns) - matmul( transpose(conjg(u(:m,:ns))), u(:m,:ns) ) ) ! err2 = maxval( resid_ortho(:ns,:ns) )/real(m,stnd) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - V**(h)*V. ! resid_ortho(:ns,:ns) = abs( a2(:ns,:ns) - matmul( vt(:ns,:n), transpose(conjg(vt(:ns,:n))) ) ) ! err3 = maxval( resid_ortho(:ns,:ns) )/real(n,stnd) ! err = max( err1, err2, err3 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, s, u, vt, rwork, iwork, a2, resid_ortho ) else deallocate( a, s, u, vt, rwork, iwork ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from gesvdx() ) = ', info ! if ( do_test .and. info==0 ) then ! write (prtunit,*) write (prtunit,*) 'Accuracy of the computed singular triplets = ', err1 write (prtunit,*) 'Orthogonality of the computed left singular vectors = ', err2 write (prtunit,*) 'Orthogonality of the computed right singular vectors = ', err3 ! end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing ', ns,' singular values and vectors of a ', & m, ' by ', n,' complex matrix is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex2_lapack_gesvdx ! ================================ ! end program ex2_lapack_gesvdx
ex2_lapack_ormbr.F90¶
program ex2_lapack_ormbr ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutines GEBRD and ORMBR ! in LAPACK software for computing a bidiagonal factorization and a partial SVD ! decomposition of a real matrix. ! ! ! Further Details ! =============== ! ! The program also shows the use of subroutines BD_SVD and BD_INVITER ! in module SVD_Procedures. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : gebrd, ormbr ! use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, unit_matrix, & bd_svd, bd_inviter, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, m AND n ARE THE DIMENSIONS OF THE GENERATED COMPLEX MATRIX, ! nvec IS THE NUMBER OF SINGULAR VECTORS, WHICH WILL BE COMPUTED BY INVERSE ITERATIONS. ! integer, parameter :: prtunit = 6, m=3000, n=3000, nvec=100, k=min(m,n) ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 2 of ormbr' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err1, err2, err3, err, eps, elapsed_time real(stnd), allocatable, dimension(:) :: d, e, singval, e2 real(stnd), allocatable, dimension(:,:) :: ra, ia, bd_leftvec, bd_rightvec, resid_ortho ! complex(stnd) :: work2(1) complex(stnd), allocatable, dimension(:) :: tauq, taup, work complex(stnd), allocatable, dimension(:,:) :: a, a2, leftvec, rightvec ! integer :: info_bd, info_q, info_p, lwork, lwork_bd, lwork_q, lwork_p, & iok, istart, iend, irate, imax, itime integer(i4b) :: maxiter=4, l ! logical(lgl) :: failure, bd_is_upper, do_test ! character :: sort='d' ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : BIDIAGONAL REDUCTION AND PARTIAL SVD DECOMPOSITION ! OF A COMPLEX MATRIX USING AN INVERSE ITERATION METHOD ! BY COMBINING LAPACK AND STATPACK SUBROUTINES. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! bd_is_upper = m>=n ! ! ALLOCATE WORK ARRAYS. ! allocate( a(m,n), ra(m,n), ia(m,n), & bd_leftvec(k,nvec), bd_rightvec(k,nvec), & leftvec(m,nvec), rightvec(n,nvec), d(k), e(k), & tauq(k), taup(k), singval(k), e2(k), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A m-by-n COMPLEX RANDOM DATA MATRIX . ! call random_number( ra(:m,:n) ) call random_number( ia(:m,:n) ) ! a(:m,:n) = cmplx( ra(:m,:n), ia(:m,:n), stnd ) ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( ra, ia ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(m,n), resid_ortho(nvec,nvec), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SAVE THE DATA MATRIX. ! a2(:m,:n) = a(:m,:n) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR gebrd AND orgbr SUBROUTINES. ! lwork = -1 ! call gebrd( m, n, a, m, d(:k), e(2_i4b:k), tauq, taup, work2, lwork, info=info_bd ) ! lwork_bd = int(work2(1)) ! call ormbr( 'Q', 'L', 'N', m, nvec, n, a, m, tauq, leftvec, m, work2, lwork, info=info_q ) ! lwork_q = int(work2(1)) ! call ormbr( 'P', 'L', 'N', n, nvec, m, a, m, taup, rightvec, n, work2, lwork, info=info_p ) ! lwork_p = int(work2(1)) ! if ( min(info_bd,info_q,info_p)==0 ) then ! lwork = max( lwork_bd, lwork_q, lwork_p ) ! ! ALLOCATE OPTIMAL WORK VARIABLE NEEDED BY gebrd AND ormbr SUBROUTINES. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! COMPUTE BIDIAGONAL REDUCTION OF RANDOM DATA MATRIX a = Q*BD*P**(h). ! WHERE Q AND P ARE UNITARY MATRICES AND BD IS A REAL BIDIAGONAL MATRIX ! call gebrd( m, n, a, m, d(:k), e(2_i4b:k), tauq, taup, work(:lwork_bd), lwork_bd, info=info_bd ) ! ! ON EXIT OF gebrd : ! ! info= 0 : INDICATES SUCCESSFUL EXIT. ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE. ! ! d AND e ARE THE DIAGONAL AND OFF-DIAGONAL ELEMENTS OF THE BIDAGONAL MATRIX BD, RESPECTIVELY. ! a CONTAINS THE ELEMENTARY REFLECTORS WHICH DEFINE Q AND P. ! taup AND tauq ARE THE SCALAR FACTORS OF THE ELEMENTARY REFLECTORS WHICH DEFINE Q AND P, RESPECTIVELY. ! ! MAKE A COPY OF THE BIDIAGONAL MATRIX. ! singval(:k) = d(:k) e2(:k) = e(:k) ! ! COMPUTE ALL SINGULAR VALUES OF THE REAL BIDIAGONAL MATRIX BD. ! call bd_svd( bd_is_upper, singval(:k), e2(:k), failure, sort=sort ) ! if ( .not. failure ) then ! ! COMPUTE THE FIRST nvec SINGULAR VECTORS OF THE BIDIAGONAL MATRIX BY maxiter INVERSE ITERATIONS. ! call bd_inviter( bd_is_upper, d(:k), e(:k), singval(:nvec), bd_leftvec(:k,:nvec), & bd_rightvec(:k,:nvec), failure, maxiter=maxiter ) ! ! NOW COMPUTE THE FIRST nvec SINGULAR VECTORS OF THE FULL m-BY-n COMPLEX MATRIX a BY BACK-TRANSFORMATION ! WITH LAPACK SUBROUTINE ormbr. ! leftvec(:k,:nvec) = cmplx( bd_leftvec(:k,:nvec), zero, stnd ) rightvec(:k,:nvec) = cmplx( bd_rightvec(:k,:nvec), zero, stnd ) ! if ( bd_is_upper ) then leftvec(k+1_i4b:m,:nvec) = cmplx( zero, zero, stnd ) else rightvec(k+1_i4b:n,:nvec) = cmplx( zero, zero, stnd ) end if ! call ormbr( 'Q', 'L', 'N', m, nvec, n, a, m, tauq, leftvec, m, work(:lwork_q), lwork_q, info=info_q ) ! call ormbr( 'P', 'L', 'N', n, nvec, m, a, m, taup, rightvec, n, work(:lwork_p), lwork_p, info=info_p ) ! ! ON EXIT OF THESE ormbr CALLS: ! ! info= 0 : INDICATES SUCCESSFUL EXIT. ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE. ! ! leftvec IS OVERWRITTEN WITH THE FIRST nvec LEFT SINGULAR VECTORS of a STORED COLUMNWISE. ! rightvec IS OVERWRITTEN WITH THE FIRST nvec RIGHT SINGULAR VECTORS of a STORED COLUMNWISE. ! end if ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( min(info_bd,info_q,info_p)/=0 ) then ! ! ANORMAL EXIT FROM gebrd OR ormbr SUBROUTINES, PRINT A WARNING. ! write (prtunit,*) 'Error in the calls to GEBRD or ORMBR subroutines, Info=', min(info_bd,info_q,info_p) ! else if ( do_test .and. .not.failure ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*rightvec - leftvec*diag(singval(:nvec)), ! WHERE leftvec AND rightvec ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a. ! a(:m,:nvec) = matmul(a2,rightvec) - leftvec*spread( singval(:nvec),dim=1,ncopies=m ) ! resid_ortho(:nvec,1_i4b) = norm( a(:m,:nvec), dim=2_i4b ) err1 = maxval( resid_ortho(:nvec,1_i4b) )/( sum( abs(singval(:k)) )*real(m,stnd) ) err1 = norm( a(:m,:nvec) )/( sum( abs(singval(:k)) )*real(nvec,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - leftvec**(h)*leftvec. ! call unit_matrix( a2(:nvec,:nvec) ) ! resid_ortho(:nvec,:nvec) = abs( a2(:nvec,:nvec) - matmul( transpose(conjg(leftvec(:m,:nvec))), leftvec(:m,:nvec) ) ) err2 = maxval( resid_ortho(:nvec,:nvec) )/real(m,stnd) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - rightvec**(h)*rightvec. ! resid_ortho(:nvec,:nvec) = abs( a2(:nvec,:nvec) - matmul( transpose(conjg(rightvec(:n,:nvec))), rightvec(:n,:nvec) ) ) err3 = maxval( resid_ortho(:nvec,:nvec) )/real(n,stnd) ! err = max( err1, err2, err3 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, a2, bd_leftvec, bd_rightvec, leftvec, rightvec, & d, e, tauq, taup, singval, e2, resid_ortho ) else deallocate( a, bd_leftvec, bd_rightvec, leftvec, rightvec, d, e, & tauq, taup, singval, e2 ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. min(info_bd,info_q,info_p)==0 .and. .not.failure ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from gebrd() ) = ', info_bd write (prtunit,*) ' INFO ( from ormbr() ) = ', info_q write (prtunit,*) ' INFO ( from ormbr() ) = ', info_p write (prtunit,*) ' FAILURE ( from bd_inviter() ) = ', failure ! if ( do_test .and. min(info_bd,info_q,info_p)==0 .and. .not.failure ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed singular triplets = ', err1 write (prtunit,*) 'Orthogonality of the computed left singular vectors = ', err2 write (prtunit,*) 'Orthogonality of the computed right singular vectors = ', err3 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing all singular values and', nvec, ' singular vectors of a', & m, ' by', n,' complex matrix is', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex2_lapack_ormbr ! =============================== ! end program ex2_lapack_ormbr
ex2_lapack_ormtr.F90¶
program ex2_lapack_ormtr ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutines (x)SYTRD and (x)ORMTR ! in LAPACK software for computing a tridiagonal decomposition and all or selected eigenvalues ! and eigenvectors of a complex hermitian matrix. ! ! ! Further Details ! =============== ! ! The program also shows the use of subroutines SYMTRID_QRI and TRID_INVITER ! in module EIG_Procedures. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : sytrd, ormtr ! use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, unit_matrix, & symtrid_qri, trid_inviter, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, n IS THE DIMENSION OF THE GENERATED COMPLEX HERMITIAN MATRIX ! AND nvec IS THE NUMBER OF EIGENVECTORS VECTORS, WHICH WILL BE COMPUTED BY INVERSE ITERATIONS. ! integer, parameter :: prtunit = 6, n=3000, nvec=1000 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 2 of ormtr' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err1, err2, err, eps, elapsed_time real(stnd), allocatable, dimension(:) :: d, e, eigval, e2 real(stnd), allocatable, dimension(:,:) :: ra, ia, eigvec2, resid ! complex(stnd) :: work2(1) complex(stnd), allocatable, dimension(:) :: tau, work complex(stnd), allocatable, dimension(:,:) :: a, eigvec, a2 ! integer :: info_trd, info_q, lwork, lwork_trd, lwork_q, iok, & istart, iend, irate, imax, itime integer(i4b) :: l, maxiter=2 ! logical(lgl) :: failure, failure2, do_test ! character :: uplo, sort='d' ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 2 : TRIDIAGONAL REDUCTION OF A COMPLEX HERMITIAN MATRIX AND ! EIGENVALUES AND, OPTIONALLY, EIGENVECTORS OF A COMPLEX ! HERMITIAN MATRIX USING THE INVERSE ITERATION METHOD ! BY COMBINING LAPACK AND STATPACK DRIVERS. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a(n,n), ra(n,n), ia(n,n), eigvec(n,nvec), eigvec2(n,nvec), & d(n), e(n), tau(n-1_i4b), eigval(n), e2(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A RANDOM COMPLEX DATA MATRIX AND FROM IT ! A HERMITIAN MATRIX a . ! call random_number( ra(:n,:n) ) call random_number( ia(:n,:n) ) ! a(:n,:n) = cmplx( ra(:n,:n), ia(:n,:n), stnd ) ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( ra, ia ) ! a = a + transpose( conjg( a ) ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(n,n), resid(nvec,nvec), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SAVE THE HERMITIAN MATRIX. ! a2(:n,:n) = a(:n,:n) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! IF uplo='U' UPPER TRIANGLE OF a IS STORED, ! IF uplo='L' LOWER TRIANGLE OF a IS STORED. ! uplo = 'U' ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR sytrd AND ormtr SUBROUTINES. ! lwork = -1 ! call sytrd( uplo, n, a, n, d, e, tau, work2, lwork, info=info_trd ) ! lwork_trd = int(work2(1)) ! call ormtr( 'L', uplo, 'N', n, nvec, a, n, tau, eigvec, n, work2, lwork, info=info_q ) ! lwork_q = int(work2(1)) ! if ( info_trd==0 .and. info_q==0 ) then ! lwork = max( lwork_trd, lwork_q ) ! ! ALLOCATE OPTIMAL WORK VARIABLE NEEDED BY sytrd AND ormtr SUBROUTINES. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! CALL sytrd TO REDUCE THE COMPLEX MATRIX a TO TRIDIAGONAL FORM ! ! a = Q*TRID*Q**(h) ! ! WHERE Q IS UNITARY AND TRID IS A REAL SYMMETRIC TRIDIAGONAL MATRIX. ! call sytrd( uplo, n, a, n, d, e, tau, work(:lwork_trd), lwork_trd, info=info_trd ) ! ! ON EXIT OF sytrd : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! ! d AND e ARE THE DIAGONAL AND OFF-DIAGONAL ELEMENTS OF THE SYMMETRIC TRIDIAGONAL MATRIX, RESPECTIVELY. ! a CONTAINS THE ELEMENTARY REFLECTORS WHICH DEFINE Q IN ITS UPPER TRIANGLE IF uplo='U'. ! tau CONTAINS THE SCALAR FACTORS OF THE ELEMENTARY REFLECTORS WHICH DEFINE Q. ! ! MAKE A COPY OF THE TRIDIAGONAL MATRIX. ! eigval(:n) = d(:n) e2(:n) = e(:n) ! ! COMPUTE ALL THE EIGENVALUES OF THE SYMMETRIC TRIDIAGONAL MATRIX WITH SUBROUTINE symtrid_qri. ! call symtrid_qri( eigval, e2, failure, sort=sort ) ! if ( .not.failure ) then ! ! COMPUTE THE FIRST nvec EIGENVECTORS OF THE SELF-ADJOINT MATRIX a BY ! maxiter INVERSE ITERATIONS ON THE INTERMEDIATE TRIDIAGONAL MATRIX ! AND BACK-TRANSFORMATION WITH LAPACK SUBROUTINE ormtr. ! call trid_inviter( d(:n), e(:n), eigval(:nvec), eigvec2(:n,:nvec), failure, maxiter=maxiter ) ! eigvec(:n,:nvec) = cmplx( eigvec2(:n,:nvec), zero, stnd ) ! call ormtr( 'L', uplo, 'N', n, nvec, a, n, tau, eigvec, n, work(:lwork_q), lwork_q, info=info_q ) ! ! ON EXIT OF THIS ormtr CALL: ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! ! eigvec IS OVERWRITTEN WITH THE FIRST nvec EIGENVECTORS OF a STORED COLUMNWISE. ! end if ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! failure2 = info_trd/=0 .or. info_q/=0 ! if ( failure2 ) then ! ! ANORMAL EXIT FROM sytrd OR ormtr SUBROUTINES, PRINT A WARNING. ! write (prtunit,*) 'Errors in the calls to SYTRD or ORMTR subroutines, Info=', & info_trd, info_q ! if ( info_trd<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value in SYTRD'')') - info_trd ! end if ! if ( info_q<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value in ORMTR'')') - info_q ! end if ! else if ( do_test .and. .not.failure ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*eigvec - eigvec*diag(eigval(:nvec)) ! WHERE eigval ARE THE EIGENVALUES AND eigvec THE EIGENVECTORS OF a. ! a(:n,:nvec) = matmul( a2, eigvec ) - eigvec*spread( eigval(:nvec), 1, n ) ! resid(:nvec,1) = norm( a(:n,:nvec), dim=2_i4b ) err1 = maxval( resid(:nvec,1) )/( norm(a2)*real(n,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - eigvec**(h)*eigvec ! WHERE eigvec are THE EIGENVECTORS OF THE MATRIX a. ! call unit_matrix( a(:nvec,:nvec) ) ! resid(:nvec,:nvec) = abs( a(:nvec,:nvec) - matmul( transpose( conjg(eigvec) ), eigvec ) ) err2 = maxval( resid(:nvec,:nvec) )/real(n,stnd) ! err = max( err1, err2 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, a2, eigvec, eigvec2, d, e, tau, eigval, e2, resid ) else deallocate( a, eigvec, eigvec2, d, e, tau, eigval, e2 ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. .not.failure .and. .not.failure2 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from sytrd() ) = ', info_trd write (prtunit,*) ' INFO ( from ormtr() ) = ', info_q write (prtunit,*) ' FAILURE ( from trid_inviter() ) = ', failure ! if ( do_test .and. .not.failure .and. .not.failure2 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed eigenvalues and eigenvectors = ', err1 write (prtunit,*) 'Orthogonality of the computed eigenvectors = ', err2 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing all eigenvalues and', nvec, ' eigenvectors of a', & n, ' by', n,' complex hermitian matrix is', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex2_lapack_ormtr ! =============================== ! end program ex2_lapack_ormtr
ex2_lapack_posv.F90¶
program ex2_lapack_posv ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutine POSV ! in LAPACK software for solving a complex linear system with a positive definite ! hermitian coefficient matrix and a Cholesky factorization of this coefficient ! matrix. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : posv ! use Statpack, only : lgl, i4b, stnd, true, false, zero, c100, norm, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, n IS THE DIMENSION OF THE GENERATED COMPLEX HERMITIAN DEFINITE POSITIVE MATRIX, ! nrhs IS THE NUMBER OF RIGHT HANDE-SIDE VECTORS OF THE LINEAR SYSTEM TO BE SOLVED. ! integer, parameter :: prtunit = 6, n=1000, m=n+10, nrhs=200 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c100 ! character(len=*), parameter :: name_proc='Example 2 of posv' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, eps, elapsed_time real(stnd), dimension(:,:), allocatable :: rc, ic, rx, ix ! complex(stnd), dimension(:,:), allocatable :: a, b, c, x, res ! integer :: info, iok, istart, iend, irate, imax, itime ! logical(lgl) :: do_test ! character :: uplo ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 2 : SOLUTION OF A LINEAR SYSTEM WITH A COMPLEX HERMITIAN DEFINITE POSITIVE COEFFICIENT ! MATRIX AND SEVERAL RIGHT HAND-SIDES. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*real( n, stnd )*epsilon( err ) ! eps = sqrt( epsilon( err ) ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( c(m,n), rc(m,n), ic(m,n), & x(n,nrhs), rx(n,nrhs), ix(n,nrhs), & a(n,n), b(n,nrhs), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A n-by-n RANDOM COMPLEX HERMITIAN POSITIVE DEFINITE MATRIX a . ! call random_number( rc(:m,:n) ) call random_number( ic(:m,:n) ) ! c(:m,:n) = cmplx( rc(:m,:n), ic(:m,:n), stnd ) ! a = matmul( transpose(conjg(c)), c ) ! ! GENERATE A n-by-nrhs COMPLEX RANDOM SOLUTION MATRIX x . ! call random_number( rx(:n,:nrhs) ) call random_number( ix(:n,:nrhs) ) ! x(:n,:nrhs) = cmplx( rx(:n,:nrhs), ix(:n,:nrhs), stnd ) ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( c, rc, ic, rx, ix ) ! ! COMPUTE THE MATRIX-MATRIX PRODUCT b = a*x . ! b = matmul( a, x ) ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! COMPUTE THE SOLUTION MATRIX FOR HERMITIAN POSITIVE DEFINITE SYSTEM ! ! a*x = b . ! ! FIRST SPECIFY IF UPPER OR LOWER TRIANGLE OF a IS STORED . ! uplo = 'U' ! call posv( uplo, n, nrhs, a, n, b, n, info ) ! ! ON EXIT OF posv : ! ! info = 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT the iTH ARGUMENT HAS AN ILLEGAL VALUE ! info=i > 0 : INDICATES THAT THE SOLUTION CAN NOT BE COMPUTED BECAUSE ! THE MATRIX IS SINGULAR ! ! THE ROUTINE RETURNS THE SOLUTION VECTORS IN b. ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! ! CHECK THAT THE LAPACK ROUTINE HAS BEEN SUCCESSFUL. ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM posv SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to POSV subroutine, Info=', info write (prtunit,*) ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! else if (info>0) then ! write (prtunit,'(''Zero diagonal value detected in upper ''// & ''triangular factor at position '',i7)') info ! end if ! else if ( do_test ) then ! ! ALLOCATE WORK ARRAY . ! allocate( res(n,nrhs), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! res(:n,:nrhs) = b(:n,:nrhs) - x(:n,:nrhs) err = maxval( norm(res, dim=2_i4b ) / & norm(x, dim=2_i4b ) )/real(n,stnd) ! ! DEALLOCATE WORK ARRAY. ! deallocate( res ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! deallocate( a, b, x ) ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from posv() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed solutions = ', err end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for solving a positive definite hermitian system of size ', & n, ' with', nrhs, ' right hand side vectors is', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex2_lapack_posv ! ============================== ! end program ex2_lapack_posv
ex2_lapack_stemr.F90¶
program ex2_lapack_stemr ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutines (x)SYTRD, (x)STEMR ! and (x)ORMTR in LAPACK software for computing all or selected eigenvalues and ! eigenvectors of a complex hermitian matrix. The eigenvalues and eigenvectors ! are computed by the MRRR method. ! ! ! Further Details ! =============== ! ! The (x)STEMR subroutines will work properly only with IEEE arithmetic. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : sytrd, ormtr, stemr ! use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, unit_matrix, & merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, n IS THE DIMENSION OF THE GENERATED HERMITIAN MATRIX ! neig IS THE NUMBER OF EIGENVECTORS, WHICH WILL BE COMPUTED WITH THE MRRR ALGORITHM. ! integer, parameter :: prtunit = 6, n=3000, neig=1000 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 2 of stemr' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err1, err2, err, eps, vl, vu, elapsed_time real(stnd) :: rwork2(1) real(stnd), allocatable, dimension(:) :: d, e, w, rwork real(stnd), allocatable, dimension(:,:) :: ra, ia, resid ! complex(stnd) :: work2(1) complex(stnd), allocatable, dimension(:) :: tau, work complex(stnd), allocatable, dimension(:,:) :: a, z, a2 ! integer :: info_trd, info_q, info_mrrr, lwork, liwork, lwork_trd, lwork_mrrr, lwork_q, & iok, istart, iend, irate, imax, itime, il, iu, m, nzc integer :: iwork2(1) integer, dimension(:), allocatable :: isuppz, iwork ! logical :: tryrac logical(lgl) :: do_test, failure ! character :: uplo, jobz, range ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : TRIDIAGONAL REDUCTION OF A COMPLEX HERMITIAN MATRIX AND, ! OPTIONALLY, neig EIGENVALUES AND EIGENVECTORS OF A COMPLEX ! HERMITIAN MATRIX USING THE MRRR METHOD. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( ra(n,n), ia(n,n), a(n,n), z(n,neig), d(n), e(n), w(n), & isuppz(2*n), tau(n-1_i4b), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A RANDOM COMPLEX DATA MATRIX AND FROM IT ! A HERMITIAN MATRIX a . ! call random_number( ra(:n,:n) ) call random_number( ia(:n,:n) ) ! a(:n,:n) = cmplx( ra(:n,:n), ia(:n,:n), stnd ) ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( ra, ia ) ! a = a + transpose( conjg( a ) ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(n,n), resid(neig,neig), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SAVE THE HERMITIAN MATRIX. ! a2(:n,:n) = a(:n,:n) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! IF uplo='U' UPPER TRIANGLE OF a IS STORED, ! IF uplo='L' LOWER TRIANGLE OF a IS STORED. ! uplo = 'U' ! ! FIRST DETERMINE THE WORK TO DO FOR stemr SUBROUTINE. ! ! IF jobz='N' COMPUTE EIGENVALUES ONLY, ! IF jobz='V' COMPUTE EIGENVALUES AND EIGENVECTORS. ! jobz = 'V' ! ! IF range='A' ALL EIGENVALUES WILL BE FOUND, ! IF range='V' ALL EIGENVALUES IN THE HALF OPEN INTERVAL (vl,vu) WILL BE FOUND, ! IF range='I' THE il-TH THROUGH iu-TH EIGENVALUES IN ASCENDING ORDER WILL BE FOUND. ! range = 'I' ! vl = zero vu = zero ! il = n - neig + 1 iu = n ! ! tryrac = .true. INDICATES THAT THE CODE WILL TRY TO COMPUTE THE EIGENVALUES OF THE TRIDIAGONAL MATRIX ! TO HIGH RELATIVE ACCURACY IF POSSIBLE. IF tryrac IS SET TO .false. THE CODE IS NOT REQUIRED ! TO GARANTEE RELATIVELY ACCURATE EIGENVALUES AND CAN USE A FASTEST METHOD. ! tryrac = .true. ! ! nzc IS AN UPPER BOUND FOR THE NUMBER OF EIGENVECTORS TO BE FOUND. nzc DEPENDS ON THE VALUE OF RANGE, IF: ! ! range='A' THEN nzc>=n; ! range='V' THEN nzc>=THE NUMBER OF EIGENVALUES IN (VL,VU], ! range='I' THEN nzc>=iu-il+1 . ! ! IF nzc=-1, THEN THE stemr SUBROUTINE WILL RETURN THE ESTIMATE OF nzc IN z(1,1) WITHOUT DOING ANY COMPUTATION. ! nzc = neig ! ! NOW COMPUTE OPTIMAL WORKSPACE FOR sytrd, stemr AND ormtr SUBROUTINES. ! lwork = -1 ! call sytrd( uplo, n, a, n, d, e, tau, work2, lwork, info=info_trd ) ! lwork_trd = int(work2(1)) ! call ormtr( 'L', uplo, 'N', n, neig, a, n, tau, z, n, work2, lwork, info=info_q ) ! lwork_q = int(work2(1)) ! liwork = -1 ! call stemr( jobz, range, n, d, e, vl, vu, il, iu, m, w, z, n, nzc, & isuppz, tryrac, rwork2, lwork, iwork2, liwork, info=info_mrrr ) ! if ( info_trd==0 .and. info_q==0 .and. info_mrrr==0 ) then ! lwork = max( lwork_trd, lwork_q ) lwork_mrrr = int(rwork2(1)) liwork = iwork2(1) ! ! ALLOCATE OPTIMAL WORK VARIABLES NEEDED BY sytrd, stemr AND ormtr SUBROUTINES. ! allocate( work(lwork), rwork(lwork_mrrr), iwork(liwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! CALL sytrd TO REDUCE THE HERMITIAN MATRIX a TO TRIDIAGONAL FORM ! ! a = Q*TRID*Q**(h) ! ! WHERE Q IS COMPLEX UNITARY AND TRID IS A REAL SYMMETRIC TRIDIAGONAL MATRIX. ! call sytrd( uplo, n, a, n, d, e, tau, work(:lwork_trd), lwork_trd, info=info_trd ) ! ! ON EXIT OF sytrd : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! ! d AND e ARE THE DIAGONAL AND OFF-DIAGONAL ELEMENTS OF THE SYMMETRIC TRIDIAGONAL MATRIX, RESPECTIVELY. ! a CONTAINS THE ELEMENTARY REFLECTORS WHICH DEFINE Q IN ITS UPPER TRIANGLE IF uplo='U'. ! tau CONTAINS THE SCALAR FACTORS OF THE ELEMENTARY REFLECTORS WHICH DEFINE Q. ! ! ! COMPUTE neig EIGENVALUES AND EIGENVECTORS OF THE SYMMETRIC TRIDIAGONAL MATRIX WITH SUBROUTINE stemr. ! THE EIGENVALUE DECOMPOSITION OF A REAL n-BY-n SYMMETRIC TRIDIAGONAL MATRIX TRID ! IS WRITTEN ! ! TRID = U * D * U**(t) ! ! WHERE D IS AN n-BY-n DIAGONAL MATRIX AND U IS AN n-BY-n ORTHOGONAL MATRIX. ! THE DIAGONAL ELEMENTS OF D ARE THE EIGENVALUES OF TRID; THEY ARE REAL. ! THE COLUMNS OF U ARE THE EIGENVECTORS OF TRID. ! call stemr( jobz, range, n, d, e, vl, vu, il, iu, m, w, z, n, nzc, isuppz, tryrac, & rwork(:lwork_mrrr), lwork_mrrr, iwork, liwork, info=info_mrrr ) ! ! ON EXIT OF stemr : ! ! info= 0 : INDICATES SUCCESSFUL EXIT. ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE. ! info=i > 0 : INDICATES THAT THE ALGORITHM FAILED TO CONVERGE. ! ! ON EXIT OF stemr : ! ! m GIVES THE TOTAL NUMBER OF EIGENVALUES/EIGENVECTORS FOUND. ! ! z IS OVERWRITTEN WITH THE FIRST m EIGENVECTORS ! OF THE TRIDIAGONAL MATRIX (THE EIGENVECTORS ARE STORED COLUMNWISE AND IN COMPLEX FORMAT). ! ! w IS OVERWRITTEN WITH THE EIGENVALUES OF THE TRIDIAGONAL MATRIX IN ASCENDING ORDER, ! CORRESPONDING TO THE EIGENVECTORS IN z . ! ! COMPUTE THE FIRST m EIGENVECTORS OF THE SELF-ADJOINT MATRIX a BY ! BACK-TRANSFORMATION WITH LAPACK SUBROUTINE ormtr. ! call ormtr( 'L', uplo, 'N', n, m, a, n, tau, z, n, work(:lwork_q), lwork_q, info=info_q ) ! ! ON EXIT OF THIS ormtr CALL: ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! ! z IS OVERWRITTEN WITH THE FIRST m EIGENVECTORS OF a STORED COLUMNWISE. ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( work, rwork, iwork ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! failure = info_trd/=0 .or. info_q/=0 .or. info_mrrr/=0 ! if ( failure ) then ! ! ANORMAL EXIT FROM sytrd, stemr OR ormtr SUBROUTINES, PRINT A WARNING. ! write (prtunit,*) 'Errors in the calls to SYTRD, STEMR or ORMTR subroutines, Info=', & info_trd, info_mrrr, info_q ! if ( info_trd<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value in SYTRD'')') - info_trd ! end if ! if ( info_mrrr<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value in STEMR'')') - info_mrrr ! end if ! if ( info_q<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value in ORMTR'')') - info_q ! end if ! else if ( do_test ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*eigvec - eigvec*diag(eigval(:m)) ! WHERE eigval ARE THE EIGENVALUES AND eigvec THE EIGENVECTORS OF a. ! a(:n,:m) = matmul( a2, z(:n,:m) ) - z(:n,:m)*spread( w(:m), dim=1, ncopies=n ) ! resid(:m,1) = norm( a(:n,:m), dim=2_i4b ) err1 = maxval( resid(:m,1) )/( norm(a2)*real(n,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - eigvec**(h)*eigvec ! WHERE eigvec are THE EIGENVECTORS OF THE MATRIX a. ! call unit_matrix( a(:m,:m) ) ! resid(:m,:m) = abs( a(:m,:m) - matmul( transpose( conjg(z(:n,:m)) ), z(:n,:m) ) ) err2 = maxval( resid(:m,:m) )/real(n,stnd) ! err = max( err1, err2 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, z, d, e, tau, w, isuppz, a2, resid ) else deallocate( a, z, d, e, tau, w, isuppz ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. .not.failure ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from sytrd() ) = ', info_trd write (prtunit,*) ' INFO ( from stemr() ) = ', info_mrrr write (prtunit,*) ' INFO ( from ormtr() ) = ', info_q ! if ( do_test .and. .not.failure ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed eigenvalues and eigenvectors = ', err1 write (prtunit,*) 'Orthogonality of the computed eigenvectors = ', err2 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing ', m,' eigenvalues and eigenvectors of a', & n, ' by', n,' complex hermitian matrix is', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex2_lapack_stemr ! =============================== ! end program ex2_lapack_stemr
ex2_lapack_syev.F90¶
program ex2_lapack_syev ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutine SYEV ! in LAPACK software for computing all eigenvalues and, optionally, ! eigenvectors of a complex hermitian matrix. The eigenvalues and ! eigenvectors are computed by the tridiagonal QR implicit method. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : syev ! use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, unit_matrix, & merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, n IS THE DIMENSION OF THE GENERATED COMPLEX HERMITIAN MATRIX. ! integer, parameter :: prtunit = 6, n=1000 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 2 of syev' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, err1, err2, eps, elapsed_time real(stnd), dimension(:), allocatable :: w, rwork real(stnd), dimension(:,:), allocatable :: ra, ia, resid_ortho ! complex(stnd) :: work2(1) complex(stnd), dimension(:), allocatable :: work complex(stnd), dimension(:,:), allocatable :: a, a2, resid ! integer :: info, lwork, iok, istart, iend, irate, imax, itime ! logical(lgl) :: do_test ! character :: jobz, uplo ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : EIGENVALUES AND, OPTIONALLY, EIGENVECTORS OF A COMPLEX HERMITIAN ! MATRIX USING THE QR IMPLICIT METHOD. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! lwork = 3*n - 2 ! allocate( a(n,n), ra(n,n), ia(n,n), w(n), rwork(lwork), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A n-by-n RANDOM COMPLEX DATA MATRIX AND FROM IT ! A HERMITIAN MATRIX a . ! call random_number( ra(:n,:n) ) call random_number( ia(:n,:n) ) ! a(:n,:n) = cmplx( ra(:n,:n), ia(:n,:n), stnd ) ! a = a + transpose( conjg( a ) ) ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( ra, ia ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(n,n), resid(n,n), resid_ortho(n,n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! MAKE A COPY OF THE RANDOM HERMITIAN MATRIX a . ! a2(:n,:n) = a(:n,:n) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! IF jobz='N' COMPUTE EIGENVALUES ONLY, ! IF jobz='V' COMPUTE EIGENVALUES AND EIGENVECTORS. ! jobz = 'V' ! ! IF uplo='U' UPPER TRIANGLE OF a IS STORED, ! IF uplo='L' LOWER TRIANGLE OF a IS STORED. ! uplo = 'U' ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR syev SUBROUTINE. ! lwork = -1 ! call syev( jobz, uplo, n, a, n, w, work2, lwork, rwork, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) ! ! ALLOCATE WORK VARIABLE NEEDED BY syev SUBROUTINE. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! COMPUTE EIGENVALUES AND EIGENVECTORS OF THE HERMITIAN MATRIX a ! WITH SUBROUTINE syev FROM LAPACK. ! THE EIGENVALUE DECOMPOSITION OF A COMPLEX n-BY-n HERMITIAN MATRIX a ! IS WRITTEN ! ! a = U * D * U**(h) ! ! WHERE D IS AN n-BY-n DIAGONAL MATRIX AND U IS AN n-BY-n UNITARY MATRIX. ! THE DIAGONAL ELEMENTS OF D ARE THE EIGENVALUES OF a; THEY ARE REAL. ! THE COLUMNS OF U ARE THE EIGENVECTORS OF a. ! call syev( jobz, uplo, n, a, n, w, work, lwork, rwork, info ) ! ! ON EXIT OF syev : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! info=i > 0 : INDICATES THAT THE ALGORITHM FAILED TO CONVERGE ! AND i OFF-DIAGONAL ELEMENTS OF AN INTERMEDIATE ! TRIDIAGONAL FORM OF a DID NOT CONVERGE TO ZERO. ! ! ON EXIT OF syev : ! ! a IS OVERWRITTEN WITH THE EIGENVECTORS OF a IF ! jobz='V' (THE EIGENVECTORS ARE STORED COLUMNWISE). ! ! w IS OVERWRITTEN WITH THE EIGENVALUES OF a IN ASCENDING ORDER. ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM syev SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to SYEV subroutine, Info=', info ! else if ( do_test ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*U - U*D ! resid(:n,:n) = matmul(a2(:n,:n),a(:n,:n)) - a(:n,:n)*spread(w,dim=1,ncopies=n) resid_ortho(:n,1_i4b) = norm( resid(:n,:n), dim=2_i4b ) err1 = maxval( resid_ortho(:n,1_i4b) )/( norm( a2 )*real(n,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(h)*U. ! call unit_matrix( a2(:n,:n) ) ! resid_ortho(:n,:n) = abs( a2(:n,:n) - matmul( transpose(conjg(a(:n,:n))), a(:n,:n) ) ) err2 = maxval( resid_ortho(:n,:n) )/real(n,stnd) ! err = max( err1, err2 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, w, rwork, a2, resid, resid_ortho ) else deallocate( a, w, rwork ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from syev() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed eigenvalues and eigenvectors = ', err1 write (prtunit,*) 'Orthogonality of the computed eigenvectors = ', err2 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing ', n, ' eigenvalues and eigenvectors of a', & n, ' by', n,' complex hermitian matrix is', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex2_lapack_syev ! ============================== ! end program ex2_lapack_syev
ex2_lapack_syevd.F90¶
program ex2_lapack_syevd ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutine SYEVD ! in LAPACK software for computing all eigenvalues and, optionally, ! eigenvectors of a complex hermitian matrix. The eigenvalues and ! eigenvectors are computed by the divide and conquer method. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : syevd ! use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, unit_matrix, & merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, n IS THE DIMENSION OF THE GENERATED COMPLEX HERMITIAN MATRIX. ! integer, parameter :: prtunit = 6, n=1000 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 2 of syevd' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, err1, err2, eps, elapsed_time real(stnd) :: rwork2(1) real(stnd), dimension(:), allocatable :: w, rwork real(stnd), dimension(:,:), allocatable :: ra, ia, resid_ortho ! complex(stnd) :: work2(1) complex(stnd), dimension(:), allocatable :: work complex(stnd), dimension(:,:), allocatable :: a, a2, resid ! integer :: info, lwork, liwork, lrwork, iok, istart, & iend, irate, imax, itime integer :: iwork2(1) integer, dimension(:), allocatable :: iwork ! logical(lgl) :: do_test ! character :: jobz, uplo ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 2 : EIGENVALUES AND, OPTIONALLY, EIGENVECTORS OF A COMPLEX HERMITIAN MATRIX ! MATRIX USING THE DIVIDE AND CONQUER METHOD. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAY. ! allocate( a(n,n), ra(n,n), ia(n,n), w(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A RANDOM COMPLEX DATA MATRIX AND FROM IT ! A HERMITIAN MATRIX a . ! call random_number( ra(:n,:n) ) call random_number( ia(:n,:n) ) ! a(:n,:n) = cmplx( ra(:n,:n), ia(:n,:n), stnd ) ! a = a + transpose( conjg( a ) ) ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( ra, ia ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(n,n), resid(n,n), resid_ortho(n,n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! MAKE A COPY OF THE RANDOM HERMITIAN MATRIX . ! a2(:n,:n) = a(:n,:n) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! IF jobz='N' COMPUTE EIGENVALUES ONLY, ! IF jobz='V' COMPUTE EIGENVALUES AND EIGENVECTORS. ! jobz = 'V' ! ! IF uplo='U' UPPER TRIANGLE OF a IS STORED, ! IF uplo='L' LOWER TRIANGLE OF a IS STORED. ! uplo = 'U' ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR syevd SUBROUTINE. ! lwork = -1 liwork = -1 lrwork = -1 ! call syevd( jobz, uplo, n, a, n, w, work2, lwork, rwork2, lrwork, iwork2, liwork, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) + 10 lrwork = int(rwork2(1)) + 10 liwork = iwork2(1) ! ! ALLOCATE WORK VARIABLES NEEDED BY syevd SUBROUTINE. ! allocate( work(lwork), rwork(lrwork), iwork(liwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! COMPUTE EIGENVALUES AND EIGENVECTORS OF THE HERMITIAN MATRIX a ! WITH SUBROUTINE syevd FROM LAPACK. ! THE EIGENVALUE DECOMPOSITION OF A COMPLEX n-BY-n HERMITIAN MATRIX a ! IS WRITTEN ! ! a = U * D * U**(h) ! ! WHERE D IS AN n-BY-n DIAGONAL MATRIX AND U IS AN n-BY-n UNITARY MATRIX. ! THE DIAGONAL ELEMENTS OF D ARE THE EIGENVALUES OF a; THEY ARE REAL. ! THE COLUMNS OF U ARE THE EIGENVECTORS OF a. ! call syevd( jobz, uplo, n, a, n, w, work, lwork, rwork, lrwork, iwork, liwork, info ) ! ! ON EXIT OF syevd : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! info=i > 0 : INDICATES THAT THE ALGORITHM FAILED TO CONVERGE. ! ! ON EXIT OF syevd : ! ! a IS OVERWRITTEN WITH THE EIGENVECTORS OF a IF ! jobz='V' (THE EIGENVECTORS ARE STORED COLUMNWISE). ! ! w IS OVERWRITTEN WITH THE EIGENVALUES OF a IN ASCENDING ORDER. ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( work, rwork, iwork ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM syevd SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to SYEVD subroutine, Info=', info ! else if ( do_test ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*U - U*D ! resid(:n,:n) = matmul(a2(:n,:n),a(:n,:n)) - a(:n,:n)*spread(w,dim=1,ncopies=n) resid_ortho(:n,1_i4b) = norm( resid(:n,:n), dim=2_i4b ) err1 = maxval( resid_ortho(:n,1_i4b) )/( norm( a2 )*real(n,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(h)*U. ! call unit_matrix( a2(:n,:n) ) ! resid_ortho(:n,:n) = abs( a2(:n,:n) - matmul( transpose(conjg(a(:n,:n))), a(:n,:n) ) ) err2 = maxval( resid_ortho(:n,:n) )/real(n,stnd) ! err = max( err1, err2 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, w, a2, resid, resid_ortho ) else deallocate( a, w ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from syevd() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed eigenvalues and eigenvectors = ', err1 write (prtunit,*) 'Orthogonality of the computed eigenvectors = ', err2 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing ', n, ' eigenvalues and eigenvectors of a', & n, ' by', n,' complex hermitian matrix is', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex2_lapack_syevd ! =============================== ! end program ex2_lapack_syevd
ex2_lapack_syevr.F90¶
program ex2_lapack_syevr ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutine SYEVR ! in LAPACK software for computing all eigenvalues and, optionally, ! eigenvectors of a complex hermitian matrix. The eigenvalues and ! eigenvectors are computed by the MRRR method. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : syevr ! use Statpack, only : lgl, i4b, stnd, true, false, zero, two, c50, norm, & safmin, merror, allocate_error, unit_matrix ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, n IS THE DIMENSION OF THE GENERATED COMPLEX HERMITIAN MATRIX. ! integer, parameter :: prtunit = 6, n=1000 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 2 of syevr' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, err1, err2, eps, abstol, vl, vu, elapsed_time real(stnd) :: rwork2(1) real(stnd), dimension(:), allocatable :: w, rwork real(stnd), dimension(:,:), allocatable :: rz, iz, resid_ortho ! complex(stnd) :: work2(1) complex(stnd), dimension(:), allocatable :: work complex(stnd), dimension(:,:), allocatable :: a2, a, z ! integer :: info, lwork, lrwork, liwork, iok, il, iu, m, & istart, iend, irate, imax, itime integer :: iwork2(1) integer, dimension(:), allocatable :: iwork, isuppz ! logical(lgl) :: do_test ! character :: jobz, uplo, range ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 2 : EIGENVALUES AND, OPTIONALLY, EIGENVECTORS OF A COMPLEX HERMITIAN MATRIX ! MATRIX USING THE MRRR ALGORITHM. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! abstol = two*safmin eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a(n,n), rz(n,n), iz(n,n), z(n,n), w(n), isuppz(2*n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A n-by-n RANDOM COMPLEX DATA MATRIX AND FROM IT ! A HERMITIAN MATRIX a . ! call random_number( rz(:n,:n) ) call random_number( iz(:n,:n) ) ! z(:n,:n) = cmplx( rz(:n,:n), iz(:n,:n), stnd ) ! a = z + transpose( conjg( z ) ) ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( rz, iz ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(n,n), resid_ortho(n,n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! MAKE A COPY OF THE RANDOM DATA MATRIX . ! a2(:n,:n) = a(:n,:n) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! FIRST DETERMINE THE WORK TO DO. ! ! IF jobz='N' COMPUTE EIGENVALUES ONLY, ! IF jobz='V' COMPUTE EIGENVALUES AND EIGENVECTORS. ! jobz = 'V' ! ! IF range='A' ALL EIGENVALUES WILL BE FOUND, ! IF range='V' ALL EIGENVALUES IN THE HALF OPEN INTERVAL (vl,vu) WILL BE FOUND, ! IF range='I' THE il-TH THROUGH iu-TH EIGENVALUES IN ASCENDING ORDER WILL BE FOUND. ! range = 'A' ! ! IF uplo='U' UPPER TRIANGLE OF a IS STORED, ! IF uplo='L' LOWER TRIANGLE OF a IS STORED. ! uplo = 'U' ! vl = zero vu = zero ! il = 1 iu = n ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR syevr SUBROUTINE. ! lwork = -1 lrwork = -1 liwork = -1 ! call syevr( jobz, range, uplo, n, a, n, vl, vu, il, iu, abstol, m, w, & z, n, isuppz, work2, lwork, rwork2, lrwork, iwork2, liwork, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) + 10 lrwork = int(rwork2(1)) + 10 liwork = iwork2(1) ! ! ALLOCATE WORK VARIABLES NEEDED BY syevr SUBROUTINE. ! allocate( work(lwork), rwork(lrwork), iwork(liwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! COMPUTE EIGENVALUES AND EIGENVECTORS OF THE HERMITIAN MATRIX a ! WITH SUBROUTINE syevr FROM LAPACK. ! THE EIGENVALUE DECOMPOSITION OF A COMPLEX n-BY-n HERMITIAN MATRIX a ! IS WRITTEN ! ! a = U * D * U**(h) ! ! WHERE D IS AN n-BY-n DIAGONAL MATRIX AND U IS AN n-BY-n UNITARY MATRIX. ! THE DIAGONAL ELEMENTS OF D ARE THE EIGENVALUES OF a; THEY ARE REAL. ! THE COLUMNS OF U ARE THE EIGENVECTORS OF a. ! call syevr( jobz, range, uplo, n, a, n, vl, vu, il, iu, abstol, m, w, & z, n, isuppz, work, lwork, rwork, lrwork, iwork, liwork, info ) ! ! ON EXIT OF syevr : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! info=i > 0 : INDICATES THAT THE ALGORITHM FAILED TO CONVERGE ! ! ON EXIT OF syevr : ! ! THE LOWER (IF uplo='L') OR UPPER (IF uplo='U') TRIANGLE ! OF a IS DESTROYED, INCLUDING THE DIAGONAL. ! ! m GIVES THE TOTAL NUMBER OF EIGENVALUES/EIGENVECTORS FOUND. ! ! z IS OVERWRITTEN WITH THE FIRST m EIGENVECTORS ! OF a (THE EIGENVECTORS ARE STORED COLUMNWISE). ! ! w IS OVERWRITTEN WITH THE EIGENVALUES OF a IN ASCENDING ORDER, ! CORRESPONDING TO THE EIGENVECTORS IN z . ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( work, rwork, iwork ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM syevr SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to SYEVR subroutine, Info=', info ! else if ( do_test ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*U - U*D ! a(:n,:m) = matmul(a2(:n,:n),z(:n,:m)) - z(:n,:m)*spread(w(:m),dim=1,ncopies=n) resid_ortho(:m,1_i4b) = norm( a(:n,:m), dim=2_i4b ) err1 = maxval( resid_ortho(:m,1_i4b) )/( norm( a2 )*real(n,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(h)*U. ! call unit_matrix( a2(:m,:m) ) ! resid_ortho(:m,:m) = abs( a2(:m,:m) - matmul( transpose(conjg(z(:n,:m))), z(:n,:m) ) ) err2 = maxval( resid_ortho(:m,:m) )/real(n,stnd) ! err = max( err1, err2 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, z, w, isuppz, a2, resid_ortho ) else deallocate( a, z, w, isuppz ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from syevr() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed eigenvalues and eigenvectors = ', err1 write (prtunit,*) 'Orthogonality of the computed eigenvectors = ', err2 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing ', m, ' eigenvalues and eigenvectors of a', & n, ' by', n,' complex hermitian matrix is', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex2_lapack_syevr ! =============================== ! end program ex2_lapack_syevr
ex2_lapack_syevx.F90¶
program ex2_lapack_syevx ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutine SYEVX ! in LAPACK software for computing all eigenvalues and, optionally, ! eigenvectors of a complex hermitian matrix. The eigenvalues and ! eigenvectors are computed by the bisection and inverse iteration methods. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : syevx ! use Statpack, only : lgl, i4b, stnd, true, false, zero, two, c50, norm, & safmin, merror, allocate_error, unit_matrix ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, n IS THE DIMENSION OF THE GENERATED COMPLEX HERMITIAN MATRIX ! integer, parameter :: prtunit = 6, n=1000 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 2 of syevx' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, err1, err2, eps, abstol, vl, vu, elapsed_time real(stnd), dimension(:), allocatable :: w, rwork real(stnd), dimension(:,:), allocatable :: rz, iz, resid_ortho ! complex(stnd) :: work2(1) complex(stnd), dimension(:), allocatable :: work complex(stnd), dimension(:,:), allocatable :: a2, a, z ! integer :: info, lwork, iok, il, iu, m, & istart, iend, irate, imax, itime integer, dimension(:), allocatable :: iwork, ifail ! logical(lgl) :: do_test ! character :: jobz, uplo, range ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 2 : EIGENVALUES AND, OPTIONALLY, EIGENVECTORS OF A COMPLEX HERMITIAN MATRIX ! MATRIX USING THE BISECTION AND INVERSE ITERATION METHODS. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! abstol = two*safmin eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a(n,n), rz(n,n), iz(n,n), z(n,n), w(n), & rwork(7*n), iwork(5*n), ifail(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A n-by-n RANDOM COMPLEX DATA MATRIX AND FROM IT ! A HERMITIAN MATRIX a . ! call random_number( rz(:n,:n) ) call random_number( iz(:n,:n) ) ! z(:n,:n) = cmplx( rz(:n,:n), iz(:n,:n), stnd ) ! a = z + transpose( conjg( z ) ) ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( rz, iz ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAY. ! allocate( a2(n,n), resid_ortho(n,n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! MAKE A COPY OF THE RANDOM DATA MATRIX. ! a2(:n,:n) = a(:n,:n) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! FIRST DETERMINE THE WORK TO DO. ! ! IF jobz='N' COMPUTE EIGENVALUES ONLY, ! IF jobz='V' COMPUTE EIGENVALUES AND EIGENVECTORS. ! jobz = 'V' ! ! IF range='A' ALL EIGENVALUES WILL BE FOUND, ! IF range='V' ALL EIGENVALUES IN THE HALF OPEN INTERVAL (vl,vu) WILL BE FOUND, ! IF range='I' THE il-TH THROUGH iu-TH EIGENVALUES IN ASCENDING ORDER WILL BE FOUND. ! range = 'A' ! ! IF uplo='U' UPPER TRIANGLE OF a IS STORED, ! IF uplo='L' LOWER TRIANGLE OF a IS STORED. ! uplo = 'U' ! vl = zero vu = zero ! il = 1 iu = n ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR syevx SUBROUTINE. ! lwork = -1 ! call syevx( jobz, range, uplo, n, a, n, vl, vu, il, iu, abstol, & m, w, z, n, work2, lwork, rwork, iwork, ifail, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) ! ! ALLOCATE WORK VARIABLE NEEDED BY syevx SUBROUTINE. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! COMPUTE EIGENVALUES AND EIGENVECTORS OF THE HERMITIAN MATRIX a ! WITH SUBROUTINE syevx FROM LAPACK. ! THE EIGENVALUE DECOMPOSITION OF A COMPLEX n-BY-n HERMITIAN MATRIX a ! IS WRITTEN ! ! a = U * D * U**(h) ! ! WHERE D IS AN n-BY-n DIAGONAL MATRIX AND U IS AN n-BY-n UNITARY MATRIX. ! THE DIAGONAL ELEMENTS OF D ARE THE EIGENVALUES OF a; THEY ARE REAL. ! THE COLUMNS OF U ARE THE EIGENVECTORS OF a. ! call syevx( jobz, range, uplo, n, a, n, vl, vu, il, iu, abstol, & m, w, z, n, work, lwork, rwork, iwork, ifail, info ) ! ! ON EXIT OF syevx : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! info=i > 0 : INDICATES THAT i EIGENVECTORS FAILED TO CONVERGE AND ! THEIR INDICES ARE STORED IN ARRAY ifail. ! ! ON EXIT OF syevx : ! ! THE LOWER (IF uplo='L') OR UPPER (IF uplo='U') TRIANGLE ! OF a IS DESTROYED, INCLUDING THE DIAGONAL. ! ! m GIVES THE TOTAL NUMBER OF EIGENVALUES/EIGENVECTORS FOUND. ! ! z IS OVERWRITTEN WITH THE FIRST m EIGENVECTORS ! OF a (THE EIGENVECTORS ARE STORED COLUMNWISE). ! ! w IS OVERWRITTEN WITH THE EIGENVALUES OF a IN ASCENDING ORDER, ! CORRESPONDING TO THE EIGENVECTORS IN z . ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM syevx SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to SYEVX subroutine, Info=', info ! else if ( do_test ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*U - U*D ! a(:n,:m) = matmul(a2(:n,:n),z(:n,:m)) - z(:n,:m)*spread(w(:m),dim=1,ncopies=n) resid_ortho(:m,1_i4b) = norm( a(:n,:m), dim=2_i4b ) err1 = maxval( resid_ortho(:m,1_i4b) )/( norm( a2 )*real(n,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(h)*U. ! call unit_matrix( a2(:m,:m) ) ! resid_ortho(:m,:m) = abs( a2(:m,:m) - matmul( transpose(conjg(z(:n,:m))), z(:n,:m) ) ) err2 = maxval( resid_ortho(:m,:m) )/real(n,stnd) ! err = max( err1, err2 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, z, w, rwork, iwork, ifail, a2, resid_ortho ) else deallocate( a, z, w, rwork, iwork, ifail ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from syevx() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed eigenvalues and eigenvectors = ', err1 write (prtunit,*) 'Orthogonality of the computed eigenvectors = ', err2 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing ', m, ' eigenvalues and eigenvectors of a', & n, ' by', n,' complex hermitian matrix is', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex2_lapack_syevx ! =============================== ! end program ex2_lapack_syevx
ex2_lapack_sysv.F90¶
program ex2_lapack_sysv ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutine SYSV ! in LAPACK software for solving a linear system with a complex symmetric ! coefficient matrix. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : sysv ! use Statpack, only : lgl, i4b, stnd, true, false, zero, c100, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, n IS THE DIMENSION OF THE GENERATED COMPLEX SYMMETRIC MATRIX, ! nrhs IS THE NUMBER OF RIGHT HANDE-SIDE VECTORS OF THE LINEAR SYSTEM TO BE SOLVED. ! integer, parameter :: prtunit = 6, n=1000, nrhs=400 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c100 ! character(len=*), parameter :: name_proc='Example 2 of sysv' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, eps, elapsed_time real(stnd), dimension(:,:), allocatable :: ra, ia, rx, ix ! complex(stnd) :: work2(1) complex(stnd), dimension(:), allocatable :: work complex(stnd), dimension(:,:), allocatable :: a, b, x, res ! integer(i4b), dimension(:), allocatable :: ipiv integer :: info, lwork, iok, istart, & iend, irate, imax, itime ! logical(lgl) :: do_test ! character :: uplo ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 2 : SOLUTION OF A LINEAR SYSTEM WITH A COMPLEX SYMMETRIC COEFFICIENT ! MATRIX AND SEVERAL RIGHT HAND-SIDES. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*real( n, stnd )*epsilon( err ) ! eps = sqrt( epsilon( err ) ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a(n,n), ra(n,n), ia(n,n), b(n,nrhs), x(n,nrhs), & rx(n,nrhs), ix(n,nrhs), ipiv(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A n-by-n COMPLEX RANDOM SYMMETRIC MATRIX a . ! call random_number( ra(:n,:n) ) call random_number( ia(:n,:n) ) ! a(:n,:n) = cmplx( ra(:n,:n), ia(:n,:n), stnd ) ! a = a + transpose( a ) ! ! GENERATE A n-by-nrhs COMPLEX RANDOM SOLUTION MATRIX x . ! call random_number( rx(:n,:nrhs) ) call random_number( ix(:n,:nrhs) ) ! x(:n,:nrhs) = cmplx( rx(:n,:nrhs), ix(:n,:nrhs), stnd ) ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( ra, ia, rx, ix ) ! ! COMPUTE THE MATRIX-MATRIX PRODUCT b = a*x . ! b = matmul( a, x ) ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! IF uplo='U' UPPER TRIANGLE OF a IS STORED, ! IF uplo='L' LOWER TRIANGLE OF a IS STORED. ! uplo = 'U' ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR sysv SUBROUTINE. ! lwork = -1 ! call sysv( uplo, n, nrhs, a, n, ipiv, b, n, work2, lwork, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) ! ! ALLOCATE WORK VARIABLE NEEDED BY sysv SUBROUTINE. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! COMPUTE THE SOLUTION MATRIX FOR COMPLEX SYMMETRIC LINEAR SYSTEM ! ! a*x = b . ! call sysv( uplo, n, nrhs, a, n, ipiv, b, n, work, lwork, info ) ! ! ON EXIT OF sysv : ! ! info = 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT the iTH ARGUMENT HAS AN ILLEGAL VALUE ! info=i > 0 : INDICATES THAT THE SOLUTION CAN NOT BE COMPUTED BECAUSE ! THE MATRIX IS SINGULAR ! ! THE ROUTINE RETURNS THE SOLUTION VECTORS IN b. ! DETAILS OF THE U*D*U**(T) (if uplo='U') OR THE L*D*L**(T) (if uplo='L') ! FACTORIZATION OF a ARE RETURNED IN ARGUMENTS ipiv AND a . ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM sysv SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to SYSV subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test ) then ! ! ALLOCATE WORK ARRAY . ! allocate( res(n,nrhs), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! res(:n,:nrhs) = b(:n,:nrhs) - x(:n,:nrhs) err = maxval( sum( abs(res), dim=1 ) / & sum(abs(x), dim=1 ) ) ! ! DEALLOCATE WORK ARRAY. ! deallocate( res ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! deallocate( a, b, x, ipiv ) ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from sysv() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed solutions = ', err end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing the solution of a linear symmetric complex system of size ', & n, ' with ', nrhs,' right hand sides is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex2_lapack_sysv ! ============================== ! end program ex2_lapack_sysv
ex2_lapack_sytrd.F90¶
program ex2_lapack_sytrd ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutines SYTRD and ORGTR ! in LAPACK software for computing a tridiagonal factorization of a complex hermitian matrix. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : sytrd, orgtr ! use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, & unit_matrix, merror, allocate_error ! #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif ! #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, n IS THE DIMENSION OF THE GENERATED COMPLEX HERMITIAN MATRIX. ! integer, parameter :: prtunit = 6, n=3000 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 2 of sytrd' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err1, err2, err, eps, elapsed_time real(stnd), allocatable, dimension(:) :: d, e real(stnd), allocatable, dimension(:,:) :: ra, ia, resid_ortho ! complex(stnd) :: work2(1) complex(stnd), allocatable, dimension(:) :: tau, work complex(stnd), allocatable, dimension(:,:) :: a, a2, resid, trid ! integer :: info_trd, info_q, lwork, lwork_trd, lwork_q, & iok, istart, iend, irate, imax, itime integer(i4b) :: l ! logical(lgl) :: do_test ! character :: uplo ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : TRIDIAGONAL REDUCTION OF A COMPLEX HERMITIAN MATRIX BY THE HOUSEHOLDER METHOD. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a(n,n), ra(n,n), ia(n,n), d(n), e(n-1_i4b), tau(n-1_i4b), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A RANDOM COMPLEX DATA MATRIX AND FROM IT ! A HERMITIAN MATRIX a . ! call random_number( ra(:n,:n) ) call random_number( ia(:n,:n) ) ! a(:n,:n) = cmplx( ra(:n,:n), ia(:n,:n), stnd ) ! a = a + transpose( conjg( a ) ) ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( ra, ia ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(n,n), trid(n,n), resid(n,n), resid_ortho(n,n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SAVE THE HERMITIAN MATRIX. ! a2(:n,:n) = a(:n,:n) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! IF uplo='U' UPPER TRIANGLE OF a IS STORED, ! IF uplo='L' LOWER TRIANGLE OF a IS STORED. ! uplo = 'U' ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR sytrd AND orgtr SUBROUTINES. ! lwork = -1 ! call sytrd( uplo, n, a, n, d, e, tau, work2, lwork, info=info_trd ) ! lwork_trd = int(work2(1)) ! call orgtr( uplo, n, a, n, tau, work2, lwork, info=info_q ) ! lwork_q = int(work2(1)) ! if ( min(info_trd,info_q)==0 ) then ! lwork = max( lwork_trd, lwork_q ) ! ! ALLOCATE OPTIMAL WORK VARIABLE NEEDED BY sytrd AND orgtr SUBROUTINES. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! CALL sytrd AND orgtr TO REDUCE THE MATRIX a TO TRIDIAGONAL FORM ! ! a = Q*TRID*Q**(h) ! ! WHERE Q IS UNITARY AND TRID IS A REAL SYMMETRIC TRIDIAGONAL MATRIX. ! call sytrd( uplo, n, a, n, d, e, tau, work(:lwork_trd), lwork_trd, info=info_trd ) ! ! ON EXIT OF sytrd : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! ! d AND e ARE THE DIAGONAL AND OFF-DIAGONAL ELEMENTS OF THE REAL SYMMETRIC TRIDIAGONAL MATRIX, RESPECTIVELY. ! a CONTAINS THE ELEMENTARY REFLECTORS WHICH DEFINE Q IN ITS UPPER TRIANGLE IF uplo='U'. ! tau CONTAINS THE SCALAR FACTORS OF THE ELEMENTARY REFLECTORS WHICH DEFINE Q. ! call orgtr( uplo, n, a, n, tau, work(:lwork_q), lwork_q, info=info_q ) ! ! ON EXIT OF THIS orgtr CALL: ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! ! a IS OVERWRITTEN WITH THE n-BY-n UNITARY MATRIX Q. ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( min(info_trd,info_q)/=0 ) then ! ! ANORMAL EXIT FROM sytrd AND orgtr SUBROUTINES, PRINT A WARNING. ! write (prtunit,*) 'Error in the calls to SYTRD or ORGTR subroutines, Info=', min(info_trd,info_q) ! else if ( do_test ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*Q - Q*TRID ! trid(:n,:n) = cmplx( zero, zero, stnd ) ! do l = 1_i4b, n-1_i4b trid(l,l) = cmplx( d(l), zero, stnd ) trid(l,l+1_i4b) = cmplx( e(l), zero, stnd ) trid(l+1_i4b,l) = cmplx( e(l), zero, stnd ) end do ! trid(n,n) = cmplx( d(n), zero, stnd ) ! resid(:n,:n) = matmul( a2(:n,:n), a(:n,:n) ) & - matmul( a(:n,:n), trid(:n,:n) ) ! resid_ortho(:n,1_i4b) = norm( resid(:n,:n), dim=2_i4b ) err1 = maxval( resid_ortho(:n,1_i4b) )/( norm( a2 )*real(n,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - Q**(h)*Q. ! call unit_matrix( a2(:n,:n) ) ! resid_ortho(:n,:n) = abs( a2(:n,:n) - matmul( transpose(conjg(a(:n,:n ))), a(:n,:n) ) ) err2 = maxval( resid_ortho(:n,:n) )/real(n,stnd) ! err = max( err1, err2 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, a2, trid, resid, resid_ortho, d, e, tau ) else deallocate( a, d, e, tau ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. min(info_trd,info_q)==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from sytrd() ) = ', info_trd write (prtunit,*) ' INFO ( from orgtr() ) = ', info_q ! if ( do_test .and. min(info_trd,info_q)==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed tridiagonal decomposition a = Q*TRD*Q**(h) = ', err1 write (prtunit,*) 'Orthogonality of the computed Q unitary matrix = ', err2 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing the tridiagonal reduction of a ', & n, ' by ', n,' complex hermitian matrix is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex2_lapack_sytrd ! =============================== ! end program ex2_lapack_sytrd
ex3_lapack_gesdd.F90¶
program ex3_lapack_gesdd ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of the driver subroutine GESDD ! in LAPACK software for computing all singular values of a real matrix. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : gesdd ! use Statpack, only : lgl, i4b, stnd, true, false, zero, one, seven, c30, c1_e6, & random_seed_, random_number_, gen_random_mat, singval_sort, & merror, allocate_error ! #ifdef _F2003 use ieee_arithmetic, only : ieee_support_datatype, ieee_is_normal #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, m AND n ARE THE DIMENSIONS OF THE GENERATED MATRIX, ! nsvd0 IS THE NUMERICAL RANK OF THE GENERATED MATRIX (WHICH MUST BE LESS OR EQUAL TO k) ! FOR CASES GREATER THAN 0. ! integer(i4b), parameter :: prtunit = 6, m=3000, n=3000, k=min(m,n), nsvd0=3000 ! ! conda IS THE CONDITION NUMBER OF THE GENERATED MATRIX IN CASES 5, 6 and 7. ! real(stnd), parameter :: conda=c1_e6 ! character(len=*), parameter :: name_proc='Example 3 of gesdd' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: tmp, tmp2, abs_err, rel_err, elapsed_time real(stnd) :: work2(1) real(stnd), allocatable, dimension(:) :: s, s0, scal, work real(stnd), allocatable, dimension(:,:) :: a ! integer :: info, lwork, iok, istart, iend, irate, imax, itime integer, allocatable, dimension(:) :: iwork integer(i4b) :: i, mat_type ! logical(lgl) :: do_test ! character :: jobz ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : SINGULAR VALUES OF A REAL MATRIX. ! ! SPECIFY THE TYPE OF INPUT MATRIX: ! ! mat_type < 1 -> RANDOM MATRIX FROM THE UNIFORM DISTRIBUTION ! mat_type = 1 -> SLOW DECAY OF SINGULAR VALUES ! mat_type = 2 -> FAST DECAY OF SINGULAR VALUES ! mat_type = 3 -> S-SHAPED DECAY OF SINGULAR VALUES ! mat_type = 4 -> VERY SLOW DECAY OF SINGULAR VALUES ! mat_type = 5 -> STRONGLY CLUSTERED SINGULAR VALUES AT 1 WITH CONDITION NUMBER conda ! SPECTRUM WITH FEW DEFLATIONS FOR LAPACK GESDD ROUTINE ! mat_type = 6 -> GEOMETRIC DISTRIBUTION OF SINGULAR VALUES WITH CONDITION NUMBER conda ! SPECTRUM WITH MODERATE DEFLATION FOR LAPACK GESDD ROUTINE ! mat_type = 7 -> ARITHMETIC DISTRIBUTION OF SINGULAR VALUES WITH CONDITION NUMBER conda ! SPECTRUM WITH COMPLETE DEFLATION FOR LAPACK GESDD ROUTINE ! mat_type > 7 -> UNIFORM DISTRIBUTION OF SINGULAR VALUES ! mat_type = 7_i4b ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! SELECT THE UNIFORM RANDOM GENERATOR TO BE USED. ! call random_seed_( alg=3 ) ! ! RESET THE SEEDS USED BY THE UNIFORM RANDOM GENERATOR. ! call random_seed_() ! ! ALLOCATE WORK ARRAYS. ! allocate( a(m,n), s(k), iwork(8*k), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A RANDOM UNIFORM MATRIX OR SINGULAR VALUES. ! select case( mat_type ) ! case( :0_i4b ) ! ! RANDOM UNIFORM MATRIX. ! call random_number_( a ) ! case( 1_i4b ) ! ! SLOW DECAY OF SINGULAR VALUES. ! do i = 1_i4b, nsvd0 ! tmp = real( i, stnd ) ! s(i) = one/( tmp*tmp ) ! end do ! case( 2_i4b ) ! ! FAST DECAY OF SINGULAR VALUES. ! do i = 1_i4b, nsvd0 ! tmp = real( i, stnd ) ! s(i) = exp( -tmp/seven ) ! end do ! case( 3_i4b ) ! ! S-SHAPED DECAY OF SINGULAR VALUES. ! do i = 1_i4b, nsvd0 ! tmp = real( i, stnd ) ! s(i) = 0.0001_stnd + one/( one + exp( tmp - c30 ) ) ! end do ! case( 4_i4b ) ! ! VERY SLOW DECAY OF SINGULAR VALUES. ! tmp = real( nsvd0 - 1_i4b, stnd ) ! do i = 1_i4b, nsvd0 ! tmp2 = real( i - 1_i4b, stnd ) ! s(i) = exp( -tmp2/tmp ) ! end do ! case( 5_i4b ) ! ! STRONGLY CLUSTERED SINGULAR VALUES AT 1 WITH CONDITION NUMBER conda. ! THIS IS A SPECTRUM WITH FEW DEFLATIONS FOR LAPACK GESDD ROUTINE. ! s(:nsvd0-1_i4b) = one s(nsvd0) = one/conda ! case( 6_i4b ) ! ! GEOMETRIC DISTRIBUTION OF SINGULAR VALUES WITH CONDITION NUMBER conda. ! THIS IS A SPECTRUM WITH MODERATE DEFLATION FOR LAPACK GESDD ROUTINE. ! tmp = real( nsvd0 - 1_i4b, stnd ) ! do i = 1_i4b, nsvd0 ! tmp2 = real( i - 1_i4b, stnd ) ! s(i) = conda**( -tmp2/tmp ) ! end do ! case( 7_i4b ) ! ! ARITHMETIC DISTRIBUTION OF SINGULAR VALUES WITH CONDITION NUMBER conda. ! THIS IS A SPECTRUM WITH COMPLETE DEFLATION FOR LAPACK GESDD ROUTINE. ! tmp = real( nsvd0 - 1_i4b, stnd ) tmp2 = one - one/conda ! do i = 1_i4b, nsvd0 ! s(i) = one - (real( i - 1_i4b, stnd )/tmp)*tmp2 ! end do ! case default ! ! UNIFORM DISTRIBUTION OF SINGULAR VALUES. ! call random_number_( s(:nsvd0) ) ! end select ! if ( mat_type>0_i4b ) then ! #ifdef _F2003 if ( ieee_support_datatype( s ) ) then ! if ( .not.all( ieee_is_normal( s(:nsvd0) ) ) ) then ! call merror( name_proc//' : Exceptions occurred when generating the input matrix !' ) ! end if ! end if #endif ! ! SORT THE SINGULAR VALUES BY DECREASING MAGNITUDE. ! call singval_sort( 'D', s(:nsvd0) ) ! ! GENERATE A m-BY-n RANDOM REAL MATRIX a WITH A SPECIFIED DISTRIBUTION ! OF SINGULAR VALUES AND A RANK EQUAL TO nsvd0. ! call gen_random_mat( s(:nsvd0), a ) ! end if ! if ( do_test .and. mat_type>0_i4b ) then ! ! ALLOCATE WORK ARRAY. ! allocate( s0(k), scal(k), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SAVE THE TRUE SINGULAR VALUES. ! s0(:nsvd0) = s(:nsvd0) s0(nsvd0+1_i4b:k) = zero ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! DETERMINE THE WORK TO DO. ! WITH THE ARGUMENTS BELOW, THE SUBROUTINE COMPUTES ONLY THE SINGULAR VALUES ! OF THE INPUT MATRIX. ! jobz = 'N' ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR gesdd SUBROUTINE. ! lwork = -1 ! call gesdd( jobz, m, n, a, m, s, a, m, a, m, work2, lwork, iwork, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) + 10 ! ! ALLOCATE WORK VARIABLE NEEDED BY gesdd SUBROUTINE. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! gesdd COMPUTES THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL ! m-BY-n MATRIX a. THE SVD IS WRITTEN ! ! a = U * S * V**(t) ! ! WHERE S IS AN m-BY-n MATRIX WHICH IS ZERO EXCEPT FOR ITS ! min(m,n) DIAGONAL ELEMENTS, U IS AN m-BY-m ORTHOGONAL MATRIX, AND ! V IS AN n-BY-n ORTHOGONAL MATRIX. THE DIAGONAL ELEMENTS OF S ! ARE THE SINGULAR VALUES OF a; THEY ARE REAL AND NON-NEGATIVE. ! THE COLUMNS OF U AND V ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a. ! call gesdd( jobz, m, n, a, m, s, a, m, a, m, work, lwork, iwork, info ) ! ! THE ROUTINE RETURNS THE SINGULAR VALUES, THE LEFT AND RIGHT ! SINGULAR VECTORS. THE RIGHT SINGULAR VECTORS ARE RETURNED ROWWISE. ! ! ON EXIT OF gesdd : ! ! info= 0 : INDICATES SUCCESSFUL EXIT. ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE. ! info=i > 0 : INDICATES THAT THE ALGORITHM FAILED TO CONVERGE. ! ! ON EXIT OF gesdd IF JOBZ='N': ! ! s IS OVERWRITTEN WITH THE SINGULAR VALUES OF a IN DECREASING ORDER. ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM gesdd SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to GESDD subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test .and. mat_type>0_i4b ) then ! ! COMPUTE ABSOLUTE ERRORS OF SINGULAR VALUES. ! abs_err = maxval( abs( s(:k) - s0(:k) ) ) ! ! COMPUTE RELATIVE ERRORS OF SINGULAR VALUES. ! where( s0(:k)/=zero ) scal(:k) = s0(:k) elsewhere scal(:k) = one end where ! rel_err = maxval( abs( (s(:k) - s0(:k))/scal(:k) ) ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test .and. mat_type>0_i4b ) then ! deallocate( a, s, s0, scal, iwork ) ! else ! deallocate( a, s, iwork ) ! end if ! ! CHECK AND PRINT THE RESULTS. ! if ( info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' Matrix type = ', mat_type ! write (prtunit,*) write (prtunit,*) ' Matrix_type < 1 -> random matrix from the uniform distribution' write (prtunit,*) ' Matrix type = 1 -> slow decay of singular values' write (prtunit,*) ' Matrix type = 2 -> fast decay of singular values' write (prtunit,*) ' Matrix type = 3 -> s-shaped decay of singular values' write (prtunit,*) ' Matrix type = 4 -> very slow decay of singular values' write (prtunit,*) ' Matrix type = 5 -> strongly clustered singular values at 1' write (prtunit,*) ' spectrum with few deflations (for LAPACK GESDD routine)' write (prtunit,*) ' Matrix type = 6 -> geometric distribution of singular values' write (prtunit,*) ' spectrum with moderate deflation (for LAPACK GESDD routine)' write (prtunit,*) ' Matrix type = 7 -> arithmetic distribution of singular values' write (prtunit,*) ' spectrum with complete deflation (for LAPACK GESDD routine)' write (prtunit,*) ' Matrix type > 7 -> uniform distribution of singular values' ! write (prtunit,*) write (prtunit,*) ' INFO ( from gesdd() ) = ', info ! if ( do_test .and. mat_type>0_i4b .and. info==0 ) then ! write (prtunit,*) ! write (prtunit,*) 'Absolute accuracy of the computed singular values = ', abs_err write (prtunit,*) 'Relative accuracy of the computed singular values = ', rel_err ! end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing all singular values of a ', & m, ' by ', n,' real matrix is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex3_lapack_gesdd ! =============================== ! end program ex3_lapack_gesdd
ex3_lapack_gesvd.F90¶
program ex3_lapack_gesvd ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of the driver subroutine GESVD ! in LAPACK software for computing all singular values of a real matrix. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : gesvd ! use Statpack, only : lgl, i4b, stnd, true, false, zero, one, seven, c30, c1_e6, & random_seed_, random_number_, gen_random_mat, singval_sort, & merror, allocate_error ! #ifdef _F2003 use ieee_arithmetic, only : ieee_support_datatype, ieee_is_normal #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, m AND n ARE THE DIMENSIONS OF THE GENERATED MATRIX, ! nsvd0 IS THE NUMERICAL RANK OF THE GENERATED MATRIX (WHICH MUST BE LESS OR EQUAL TO k) ! FOR CASES GREATER THAN 0. ! integer(i4b), parameter :: prtunit = 6, m=3000, n=3000, k=min(m,n), nsvd0=3000 ! ! conda IS THE CONDITION NUMBER OF THE GENERATED MATRIX IN CASES 5, 6 and 7. ! real(stnd), parameter :: conda=c1_e6 ! character(len=*), parameter :: name_proc='Example 3 of gesvd' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: tmp, tmp2, abs_err, rel_err, elapsed_time real(stnd) :: work2(1) real(stnd), allocatable, dimension(:) :: s, s0, scal, work real(stnd), allocatable, dimension(:,:) :: a ! integer :: info, lwork, iok, istart, iend, irate, imax, itime integer(i4b) :: i, mat_type ! logical(lgl) :: do_test ! character :: jobu, jobvt ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 1 : SINGULAR VALUES OF A REAL MATRIX USING THE QR IMPLICIT METHOD. ! ! SPECIFY THE TYPE OF INPUT MATRIX: ! ! mat_type < 1 -> RANDOM MATRIX FROM THE UNIFORM DISTRIBUTION ! mat_type = 1 -> SLOW DECAY OF SINGULAR VALUES ! mat_type = 2 -> FAST DECAY OF SINGULAR VALUES ! mat_type = 3 -> S-SHAPED DECAY OF SINGULAR VALUES ! mat_type = 4 -> VERY SLOW DECAY OF SINGULAR VALUES ! mat_type = 5 -> STRONGLY CLUSTERED SINGULAR VALUES AT 1 WITH CONDITION NUMBER conda ! SPECTRUM WITH FEW DEFLATIONS FOR LAPACK GESDD ROUTINE ! mat_type = 6 -> GEOMETRIC DISTRIBUTION OF SINGULAR VALUES WITH CONDITION NUMBER conda ! SPECTRUM WITH MODERATE DEFLATION FOR LAPACK GESDD ROUTINE ! mat_type = 7 -> ARITHMETIC DISTRIBUTION OF SINGULAR VALUES WITH CONDITION NUMBER conda ! SPECTRUM WITH COMPLETE DEFLATION FOR LAPACK GESDD ROUTINE ! mat_type > 7 -> UNIFORM DISTRIBUTION OF SINGULAR VALUES ! mat_type = 1_i4b ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! SELECT THE UNIFORM RANDOM GENERATOR TO BE USED. ! call random_seed_( alg=3 ) ! ! RESET THE SEEDS USED BY THE UNIFORM RANDOM GENERATOR. ! call random_seed_() ! ! ALLOCATE WORK ARRAYS. ! allocate( a(m,n), s(k), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A RANDOM UNIFORM MATRIX OR SINGULAR VALUES. ! select case( mat_type ) ! case( :0_i4b ) ! ! RANDOM UNIFORM MATRIX. ! call random_number_( a ) ! case( 1_i4b ) ! ! SLOW DECAY OF SINGULAR VALUES. ! do i = 1_i4b, nsvd0 ! tmp = real( i, stnd ) ! s(i) = one/( tmp*tmp ) ! end do ! case( 2_i4b ) ! ! FAST DECAY OF SINGULAR VALUES. ! do i = 1_i4b, nsvd0 ! tmp = real( i, stnd ) ! s(i) = exp( -tmp/seven ) ! end do ! case( 3_i4b ) ! ! S-SHAPED DECAY OF SINGULAR VALUES. ! do i = 1_i4b, nsvd0 ! tmp = real( i, stnd ) ! s(i) = 0.0001_stnd + one/( one + exp( tmp - c30 ) ) ! end do ! case( 4_i4b ) ! ! VERY SLOW DECAY OF SINGULAR VALUES. ! tmp = real( nsvd0 - 1_i4b, stnd ) ! do i = 1_i4b, nsvd0 ! tmp2 = real( i - 1_i4b, stnd ) ! s(i) = exp( -tmp2/tmp ) ! end do ! case( 5_i4b ) ! ! STRONGLY CLUSTERED SINGULAR VALUES AT 1 WITH CONDITION NUMBER conda. ! THIS IS A SPECTRUM WITH FEW DEFLATIONS FOR LAPACK GESDD ROUTINE. ! s(:nsvd0-1_i4b) = one s(nsvd0) = one/conda ! case( 6_i4b ) ! ! GEOMETRIC DISTRIBUTION OF SINGULAR VALUES WITH CONDITION NUMBER conda. ! THIS IS A SPECTRUM WITH MODERATE DEFLATION FOR LAPACK GESDD ROUTINE. ! tmp = real( nsvd0 - 1_i4b, stnd ) ! do i = 1_i4b, nsvd0 ! tmp2 = real( i - 1_i4b, stnd ) ! s(i) = conda**( -tmp2/tmp ) ! end do ! case( 7_i4b ) ! ! ARITHMETIC DISTRIBUTION OF SINGULAR VALUES WITH CONDITION NUMBER conda. ! THIS IS A SPECTRUM WITH COMPLETE DEFLATION FOR LAPACK GESDD ROUTINE. ! tmp = real( nsvd0 - 1_i4b, stnd ) tmp2 = one - one/conda ! do i = 1_i4b, nsvd0 ! s(i) = one - (real( i - 1_i4b, stnd )/tmp)*tmp2 ! end do ! case default ! ! UNIFORM DISTRIBUTION OF SINGULAR VALUES. ! call random_number_( s(:nsvd0) ) ! end select ! if ( mat_type>0_i4b ) then ! #ifdef _F2003 if ( ieee_support_datatype( s ) ) then ! if ( .not.all( ieee_is_normal( s(:nsvd0) ) ) ) then ! call merror( name_proc//' : Exceptions occurred when generating the input matrix !' ) ! end if ! end if #endif ! ! SORT THE SINGULAR VALUES BY DECREASING MAGNITUDE. ! call singval_sort( 'D', s(:nsvd0) ) ! ! GENERATE A m-BY-n RANDOM REAL MATRIX a WITH A SPECIFIED DISTRIBUTION ! OF SINGULAR VALUES AND A RANK EQUAL TO nsvd0. ! call gen_random_mat( s(:nsvd0), a ) ! end if ! if ( do_test .and. mat_type>0_i4b ) then ! ! ALLOCATE WORK ARRAY. ! allocate( s0(k), scal(k), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SAVE THE TRUE SINGULAR VALUES. ! s0(:nsvd0) = s(:nsvd0) s0(nsvd0+1_i4b:k) = zero ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! DETERMINE THE WORK TO DO AND HOW THE SINGULAR VECTORS WILL BE STORED. ! WITH THE ARGUMENTS BELOW, THE SINGULAR VECTORS ARE NOT COMPUTED. ! jobu = 'N' jobvt = 'N' ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR gesvd SUBROUTINE. ! lwork = -1 ! call gesvd( jobu, jobvt, m, n, a, m, s, a, m, a, m, work2, lwork, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) ! ! ALLOCATE OPTIMAL WORK VARIABLE NEEDED BY gesvd SUBROUTINE. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! gesvd COMPUTES THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL ! m-BY-n MATRIX a. THE SVD IS WRITTEN ! ! a = U * S * V**(t) ! ! WHERE S IS AN m-BY-n MATRIX WHICH IS ZERO EXCEPT FOR ITS ! min(m,n) DIAGONAL ELEMENTS, U IS AN m-BY-m ORTHOGONAL MATRIX, AND ! V IS AN n-BY-n ORTHOGONAL MATRIX. THE DIAGONAL ELEMENTS OF S ! ARE THE SINGULAR VALUES OF a; THEY ARE REAL AND NON-NEGATIVE. ! THE COLUMNS OF U AND V ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a. ! call gesvd( jobu, jobvt, m, n, a, m, s, a, m, a, m, work, lwork, info ) ! ! THE ROUTINE RETURNS THE SINGULAR VALUES, THE LEFT AND RIGHT ! SINGULAR VECTORS. THE RIGHT SINGULAR VECTORS ARE RETURNED ROWWISE. ! ! ON EXIT OF gesvd : ! ! info= 0 : INDICATES SUCCESSFUL EXIT. ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE. ! info=i > 0 : INDICATES THAT THE ALGORITHM FAILED TO CONVERGE ! AND i OFF-DIAGONAL ELEMENTS OF AN INTERMEDIATE ! BIDIAGONAL FORM OF a DID NOT CONVERGE TO ZERO. ! ! ON EXIT OF gesvd WITH THE VALUES SPECIFIED FOR jobu AND jobvt: ! ! s IS OVERWRITTEN WITH THE SINGULAR VALUES OF a IN DECREASING ORDER. ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM gesvd SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to GESVD subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test .and. mat_type>0_i4b ) then ! ! COMPUTE ABSOLUTE ERRORS OF SINGULAR VALUES. ! abs_err = maxval( abs( s(:k) - s0(:k) ) ) ! ! COMPUTE RELATIVE ERRORS OF SINGULAR VALUES. ! where( s0(:k)/=zero ) scal(:k) = s0(:k) elsewhere scal(:k) = one end where ! rel_err = maxval( abs( (s(:k) - s0(:k))/scal(:k) ) ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test .and. mat_type>0_i4b ) then ! deallocate( a, s, s0, scal ) ! else ! deallocate( a, s ) ! end if ! ! CHECK AND PRINT THE RESULTS. ! if ( info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' Matrix type = ', mat_type ! write (prtunit,*) write (prtunit,*) ' Matrix_type < 1 -> random matrix from the uniform distribution' write (prtunit,*) ' Matrix type = 1 -> slow decay of singular values' write (prtunit,*) ' Matrix type = 2 -> fast decay of singular values' write (prtunit,*) ' Matrix type = 3 -> s-shaped decay of singular values' write (prtunit,*) ' Matrix type = 4 -> very slow decay of singular values' write (prtunit,*) ' Matrix type = 5 -> strongly clustered singular values at 1' write (prtunit,*) ' spectrum with few deflations (for LAPACK GESDD routine)' write (prtunit,*) ' Matrix type = 6 -> geometric distribution of singular values' write (prtunit,*) ' spectrum with moderate deflation (for LAPACK GESDD routine)' write (prtunit,*) ' Matrix type = 7 -> arithmetic distribution of singular values' write (prtunit,*) ' spectrum with complete deflation (for LAPACK GESDD routine)' write (prtunit,*) ' Matrix type > 7 -> uniform distribution of singular values' ! write (prtunit,*) write (prtunit,*) ' INFO ( from gesvd() ) = ', info ! if ( do_test .and. mat_type>0_i4b .and. info==0 ) then ! write (prtunit,*) ! write (prtunit,*) 'Absolute accuracy of the computed singular values = ', abs_err write (prtunit,*) 'Relative accuracy of the computed singular values = ', rel_err ! end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing all singular values of a ', & m, ' by ', n,' real matrix is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex3_lapack_gesvd ! =============================== ! end program ex3_lapack_gesvd
ex3_lapack_gesvdx.F90¶
program ex3_lapack_gesvdx ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of the driver subroutine GESVDX ! in LAPACK software for computing a partial SVD decomposition of a real matrix. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : gesvdx ! use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, unit_matrix, merror, & allocate_error #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, m AND n ARE THE DIMENSIONS OF THE GENERATED MATRIX, ! le IS THE TARGET RANK OF THE APPROXIMATE PARTIAL SVD, WHICH IS SOUGHT. ! integer, parameter :: prtunit = 6, m=2000, n=2000, k=min(m,n), le=100 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 3 of gesvdx' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, err1, err2, err3, eps, elapsed_time, vl, vu real(stnd) :: work2(1) real(stnd), allocatable, dimension(:) :: s, work, resid real(stnd), allocatable, dimension(:,:) :: a, a2, u, vt ! integer :: info, lwork, il, iu, ns, iok, & istart, iend, irate, imax, itime integer, allocatable, dimension(:) :: iwork ! logical(lgl) :: do_test ! character :: jobu, jobvt, range ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 3 : FIRST le SINGULAR TRIPLETS OF A REAL MATRIX USING AN ASSOCIATED EIGENVALUE PROBLEM ! AND THE BISECTION AND INVERSE ITERATION METHODS. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a(m,n), u(m,le), vt(le,n), s(k), iwork(12*k), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A m-by-n REAL RANDOM DATA MATRIX . ! call random_number( a ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAY. ! allocate( a2(m,n), resid(k), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! MAKE A COPY OF THE RANDOM DATA MATRIX . ! a2(:m,:n) = a(:m,:n) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! DETERMINE THE WORK TO DO AND HOW MANY SINGULAR TRIPLETS ! WILL BE COMPUTED AND STORED. ! ! IF jobu = 'V', LEFT SINGULAR VECTORS WILL BE COMPUTED. ! IF jobu = 'N', LEFT SINGULAR VECTORS WILL NOT BE COMPUTED. ! IF jobvt = 'V', RIGHT SINGULAR VECTORS WILL BE COMPUTED. ! IF jobvt = 'N', RIGHT SINGULAR VECTORS WILL NOT BE COMPUTED. ! jobu = 'V' jobvt = 'V' ! ! range DETERMINED HOW MANY SINGULAR VALUES AND VECTORS WILL BE COMPUTED. ! ! IF range='A' ALL SINGULAR VALUES WILL BE FOUND, ! IF range='V' ALL SINGULAR VALUES IN THE HALF OPEN INTERVAL (vl,vu] WILL BE FOUND, ! IF range='I' THE il-TH THROUGH iu-TH SINGULAR VALUES IN DESCENDING ORDER WILL BE FOUND. ! range = 'I' ! vl = zero vu = zero ! ! FOR FINDING THE le LARGEST SINGULAR VALUES USE THE NEXT TWO LINES. ! il = 1 iu = le ! ! FOR FINDING THE le SMALLEST SINGULAR VALUES USE THE NEXT TWO LINES. ! ! il = k - le + 1 ! iu = k ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR gesvdx SUBROUTINE. ! lwork = -1 ! call gesvdx( jobu, jobvt, range, m, n, a, m, vl, vu, il, iu, ns, & s, u, m, vt, le, work2, lwork, iwork, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) ! ! ALLOCATE OPTIMAL WORK VARIABLE NEEDED BY gesvdx SUBROUTINE. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! gesvdx COMPUTES THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL ! m-BY-n MATRIX a BY SOLVING AN ASSOCIATE EIGENVALUE PROBLEM. THE SVD ! IS WRITTEN ! ! a = U * S * V**(t) ! ! WHERE S IS AN m-BY-n MATRIX WHICH IS ZERO EXCEPT FOR ITS ! min(m,n) DIAGONAL ELEMENTS, U IS AN m-BY-m ORTHOGONAL MATRIX, AND ! V IS AN n-BY-n ORTHOGONAL MATRIX. THE DIAGONAL ELEMENTS OF S ! ARE THE SINGULAR VALUES OF a; THEY ARE REAL AND NON-NEGATIVE. ! THE COLUMNS OF U AND V ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a. ! ! THE ADVANTAGE OF gesvdx SUBROUTINE COMPARED TO OTHER SVD SUBROUTINES ! AVAILABLE IN LAPACK (EG gesvd or gesdd) IS THAT gesvdx IS ABLE TO COMPUTE ! A PARTIAL SVD DECOMPOSITION OR SELECTED SINGULAR TRIPLETS OF THE INPUT ! REAL MATRIX WHILE THE OTHER SUBROUTINES DO NOT OFFER THIS POSSIBILITY. ! HOWEVER, BEWARE THAT THE gesvdx SUBROUTINE IS AVAILABLE ONLY IN LAPACK 3.6.0 ! AND ABOVE. ! call gesvdx( jobu, jobvt, range, m, n, a, m, vl, vu, il, iu, ns, & s, u, m, vt, le, work, lwork, iwork, info ) ! ! THE ROUTINE RETURNS THE SINGULAR VALUES, THE LEFT AND RIGHT ! SINGULAR VECTORS. THE RIGHT SINGULAR VECTORS ARE RETURNED ROWWISE. ! ! ON EXIT OF gesvdx : ! ! info= 0 : INDICATES SUCCESSFUL EXIT. ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE. ! info=i > 0 : INDICATES THAT i EIVENVECTORS FAILED TO CONVERGE. ! info=n*2+1 : INDICATES THAT AN INTERNAL ERROR OCCURRED. ! ! ON EXIT OF gesvdx WITH THE VALUES SPECIFIED ABOVE FOR jobu ('V'), ! jobvt ('V') AND range ('I'): ! ! u IS OVERWRITTEN WITH THE FIRST le ! COLUMNS OF U (THE LEFT SINGULAR VECTORS, ! STORED COLUMNWISE); ! ! vt IS OVERWRITTEN WITH THE FIRST le ! ROWS OF V**(t) (THE RIGHT SINGULAR VECTORS, ! STORED ROWWISE); ! ! s IS OVERWRITTEN WITH THE FIRST le SINGULAR VALUES OF a IN DECREASING ORDER. ! ! FOR range='I' OR range='V', ns IS THE NUMBER OF SINGULAR TRIPLETS ! COMPUTED AND STORED BY THE SUBROUTINE IN ARGUMENTS u, vt AND s. ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM gesvdx SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to GESVDX subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a(:m,:n)*V(:n,:ns) - U(:m,:ns)*S(:ns,:ns). ! a(:m,:ns) = matmul(a2(:m,:n),transpose(vt(:ns,:n))) - u(:m,:ns)*spread(s(:ns),dim=1,ncopies=m) resid(:ns) = norm( a(:m,:ns), dim=2_i4b ) err1 = maxval( resid(:ns) )/( norm( a2 )*real(m,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U. ! call unit_matrix( a2(:ns,:ns) ) ! a(:ns,:ns) = abs( a2(:ns,:ns) - matmul( transpose(u(:m,:ns)), u(:m,:ns) ) ) err2 = maxval( a(:ns,:ns) )/real(m,stnd) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - V**(t)*V. ! a(:ns,:ns) = abs( a2(:ns,:ns) - matmul( vt(:ns,:n), transpose(vt(:ns,:n)) ) ) err3 = maxval( a(:ns,:ns) )/real(n,stnd) ! err = max( err1, err2, err3 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, s, u, vt, iwork, a2, resid ) else deallocate( a, s, u, vt, iwork ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from gesvdx() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed singular triplets = ', err1 write (prtunit,*) 'Orthogonality of the computed left singular vectors = ', err2 write (prtunit,*) 'Orthogonality of the computed right singular vectors = ', err3 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing ', ns,' singular values and vectors of a ', & m, ' by ', n,' real matrix is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex3_lapack_gesvdx ! ================================ ! end program ex3_lapack_gesvdx
ex3_lapack_spevx.F90¶
program ex3_lapack_spevx ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutine SPEVX ! in LAPACK software for computing all or selected eigenvalues and eigenvectors ! of a real symmetric matrix stored in packed format. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : spevx ! use Statpack, only : lgl, i4b, stnd, true, false, zero, two, c50, safmin, norm, & merror, allocate_error, unit_matrix, triangle #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, n IS THE DIMENSION OF THE SYMMETRIX MATRIX, ! le IS THE NUMBER OF EIGENVALUES AND EIGENVECTORS, WHICH WILL BE COMPUTED. ! integer(i4b), parameter :: prtunit = 6, n=3000, p=(n*(n+1))/2, le=100 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 3 of spevx' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, err1, err2, eps, abstol, vl, vu, elapsed_time real(stnd), dimension(:), allocatable :: a_packed, w, work, resid2 real(stnd), dimension(:,:), allocatable :: a, z, resid ! integer(i4b) :: info, i, il, iu, m, iok, istart, iend, irate, imax, itime integer(i4b), dimension(:), allocatable :: iwork, ifail ! logical(lgl) :: do_test ! character :: jobz, uplo, range ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 3 : FIRST le EIGENVALUES AND, OPTIONALLY, EIGENVECTORS OF A REAL SYMMETRIC ! MATRIX IN PACKED STORAGE USING THE BISECTION AND INVERSE ITERATION METHODS. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! abstol = two*safmin eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a_packed(p), z(n,n), w(n), work(8*n), iwork(5*n), ifail(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A RANDOM SELF-ADJOINT MATRIX a IN PACKED FORM. ! call random_number( a_packed(:p) ) ! ! MAKE a POSITIVE DEFINITE ASSUMING THAT THE UPPER TRIANGLE OF ! THE SELF-ADJOINT MATRIX IS STORED IN PACKED FORM. ! do i = 1_i4b, n a_packed(i+((i-1_i4b)*i/2_i4b)) = real( n, stnd ) end do ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a(n,n), resid(n,n), resid2(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! UNPACKED AND SAVE RANDOM SELF-ADJOINT MATRIX a ! ASSUMING THAT THE UPPER TRIANGLE OF THE SELF-ADJOINT ! MATRIX IS STORED IN PACKED FORM. ! a(:n,:n) = unpack( a_packed(:p), mask=triangle( true, n, n, extra=1_i4b), field=zero ) ! do i = 1_i4b, n a(i+1_i4b:n,i) = a(i,i+1_i4b:n) end do ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! FIRST DETERMINE THE WORK TO DO. ! ! IF jobz='N' COMPUTE EIGENVALUES ONLY, ! IF jobz='V' COMPUTE EIGENVALUES AND EIGENVECTORS. ! jobz = 'V' ! ! IF range='A' ALL EIGENVALUES WILL BE FOUND, ! IF range='V' ALL EIGENVALUES IN THE HALF OPEN INTERVAL (vl,vu] WILL BE FOUND, ! IF range='I' THE il-TH THROUGH iu-TH EIGENVALUES IN ASCENDING ORDER WILL BE FOUND. ! range = 'I' ! ! IF uplo='U' UPPER TRIANGLE OF a IS STORED, ! IF uplo='L' LOWER TRIANGLE OF a IS STORED. ! uplo = 'U' ! vl = zero vu = zero ! il = n - le + 1 iu = n ! ! COMPUTE EIGENVALUES AND EIGENVECTORS OF THE SELF-ADJOINT MATRIX a ! IN PACKED STORAGE WITH SUBROUTINE spevx FROM LAPACK. ! THE EIGENVALUE DECOMPOSITION OF A REAL n-BY-n SYMMETRIC MATRIX a ! IS WRITTEN ! ! a = U * D * U**(t) ! ! WHERE D IS AN n-BY-n DIAGONAL MATRIX AND U IS AN n-BY-n ORTHOGONAL MATRIX. ! THE DIAGONAL ELEMENTS OF D ARE THE EIGENVALUES OF a; THEY ARE REAL. ! THE COLUMNS OF U ARE THE EIGENVECTORS OF a. ! call spevx( jobz, range, uplo, n, a_packed, vl, vu, il, iu, abstol, & m, w, z, n, work, iwork, ifail, info ) ! ! ON EXIT OF spevx : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! info=i > 0 : INDICATES THAT i EIGENVECTORS FAILED TO CONVERGE AND ! THEIR INDICES ARE STORED IN ARRAY ifail. ! ! ON EXIT OF spevx : ! ! a_packed IS OVERWITTEN BY DETAILS OF ITS TRIDIAGONAL FACTORIZATION. ! ! m GIVES THE TOTAL NUMBER OF EIGENVALUES/EIGENVECTORS FOUND. ! ! z IS OVERWRITTEN WITH THE EIGENVECTORS ! OF a (THE EIGENVECTORS ARE STORED COLUMNWISE). ! ! w IS OVERWRITTEN WITH THE EIGENVALUES OF a IN ASCENDING ORDER, ! CORRESPONDING TO THE EIGENVECTORS IN z . ! ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM spevx SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to SPEVX subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*U - U*D ! resid(:n,:m) = matmul(a(:n,:n),z(:n,:m)) - z(:n,:m)*spread(w(:m),1,n) resid2(:m) = norm( resid(:n,:m), dim=2_i4b ) err1 = maxval( resid2(:m) )/( norm( a )*real(n,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U. ! call unit_matrix( a(:m,:m) ) ! resid(:m,:m) = abs( a(:m,:m) - matmul( transpose(z(:n,:m)), z(:n,:m) ) ) err2 = maxval( resid(:m,:m) )/real(n,stnd) ! err = max( err1, err2 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a_packed, z, w, work, iwork, ifail, a, resid, resid2 ) else deallocate( a_packed, z, w, work, iwork, ifail ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from spevx() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed eigenvalues and eigenvectors = ', err1 write (prtunit,*) 'Orthogonality of the computed eigenvectors = ', err2 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing ', m, ' eigenvalues and eigenvectors of a ', & n, ' by ', n,' real symmetric matrix in packed storage is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex3_lapack_spevx ! =============================== ! end program ex3_lapack_spevx
ex3_lapack_stemr.F90¶
program ex3_lapack_stemr ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutine (x)STEMR ! in LAPACK software for computing all or selected eigenvalues and ! eigenvectors of a real symmetric tridiagonal matrix. ! ! ! Further Details ! =============== ! ! The (x)STEMR subroutines will work properly only with IEEE arithmetic. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : stemr ! use Statpack, only : lgl, stnd, true, false, zero, half, one, two, c50, & unit_matrix, norm, merror, allocate_error #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, n IS THE DIMENSION OF THE SYMMETRIX TRIDIAGONAL MATRIX, ! le IS THE NUMBER OF EIGENVECTORS, WHICH WILL BE COMPUTED WITH THE MRRR ALGORITHM. ! integer, parameter :: prtunit=6, p=2000, n=2*p+1, le=1000 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 3 of stemr' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err1, err2, err, eps, vl, vu, tmp, & normr, normt, elapsed_time real(stnd) :: work2(1), z2(1,1) real(stnd), allocatable, dimension(:) :: d, e, w, work, diag, sup, sup2 real(stnd), allocatable, dimension(:,:) :: id, resid, z ! integer :: info, lwork, liwork, il, iu, m, nzc, & iok, istart, iend, irate, imax, itime, j, l integer :: iwork2(1) integer, dimension(:), allocatable :: isuppz, iwork ! logical :: tryrac logical(lgl) :: do_test ! character :: jobz, range ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! PRINT LABEL OF THE TEST. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 3 : FIRST le EIGENVALUES AND, OPTIONALLY, EIGENVECTORS OF A REAL SYMMETRIC TRIDIAGONAL ! MATRIX USING THE MRRR ALGORITHM. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( d(n), e(n), w(n), isuppz(2*n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE THE WILKINSON TRIDIAGONAL MATRIX OF ORDER n. ! j = p + 1 d(j) = zero ! do l = 1, p ! tmp = real( l, stnd) d(j+l) = tmp d(j-l) = tmp ! end do ! e(:n) = one ! ! GENERATE A (1-2-1) TRIDIAGONAL MATRIX. ! THE DIAGONAL ELEMENTS ARE STORED IN d . ! THE OFF-DIAGONAL ELEMENTS ARE STORED IN e . ! ! d(:n) = two ! e(:n) = one ! ! d(:n) = half ! e(:n) = half ! ! call random_number( d(:n) ) ! call random_number( e(:n) ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( id(le,le), resid(n,le), diag(n), sup(n), sup2(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! SAVE THE TRIDIAGONAL MATRIX. ! diag(:n) = d(:n) sup(:n) = e(:n) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! FIRST DETERMINE THE WORK TO DO. ! ! IF jobz='N' COMPUTE EIGENVALUES ONLY, ! IF jobz='V' COMPUTE EIGENVALUES AND EIGENVECTORS. ! jobz = 'V' ! ! IF range='A' ALL EIGENVALUES WILL BE FOUND, ! IF range='V' ALL EIGENVALUES IN THE HALF OPEN INTERVAL (vl,vu) WILL BE FOUND, ! IF range='I' THE il-TH THROUGH iu-TH EIGENVALUES IN ASCENDING ORDER WILL BE FOUND. ! range = 'I' ! vl = zero vu = zero ! il = n - le + 1 iu = n ! ! tryrac = .true. INDICATES THAT THE CODE WILL TRY TO COMPUTE THE EIGENVALUES OF THE TRIDIAGONAL MATRIX ! TO HIGH RELATIVE ACCURACY IF POSSIBLE. IF tryrac IS SET TO .false. THE CODE IS NOT REQUIRED ! TO GARANTEE RELATIVELY ACCURATE EIGENVALUES AND CAN USE A FASTEST METHOD. ! tryrac = .true. ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR stemr SUBROUTINE. ! lwork = -1 liwork = -1 ! ! nzc IS AN UPPER BOUND FOR THE NUMBER OF EIGENVECTORS TO BE FOUND. nzc DEPENDS ON THE VALUE OF RANGE, IF: ! ! range='A' THEN nzc>=n; ! range='V' THEN nzc>=THE NUMBER OF EIGENVALUES IN (VL,VU], ! range='I' THEN nzc>=iu-il+1 . ! ! IF nzc=-1, THEN THE SUBROUTINE WILL RETURN THE ESTIMATE OF nzc IN z2(1,1) ! nzc = -1 ! call stemr( jobz, range, n, d, e, vl, vu, il, iu, m, w, z2, n, nzc, & isuppz, tryrac, work2, lwork, iwork2, liwork, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) + 10 liwork = iwork2(1) nzc = z2(1,1) ! ! ALLOCATE WORK VARIABLES NEEDED BY stemr SUBROUTINE. ! allocate( work(lwork), iwork(liwork), z(n,nzc), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! COMPUTE SELECTED EIGENVALUES AND EIGENVECTORS OF THE SYMMETRIC TRIDIAGONAL MATRIX ! WITH SUBROUTINE stemr FROM LAPACK. ! THE EIGENVALUE DECOMPOSITION OF A REAL n-BY-n SYMMETRIC TRIDIAGONAL MATRIX a ! IS WRITTEN ! ! a = U * D * U**(t) ! ! WHERE D IS AN n-BY-n DIAGONAL MATRIX AND U IS AN n-BY-n ORTHOGONAL MATRIX. ! THE DIAGONAL ELEMENTS OF D ARE THE EIGENVALUES OF a; THEY ARE REAL. ! THE COLUMNS OF U ARE THE EIGENVECTORS OF a . ! call stemr( jobz, range, n, d, e, vl, vu, il, iu, m, w, z, n, nzc, & isuppz, tryrac, work, lwork, iwork, liwork, info ) ! ! ON EXIT OF stemr : ! ! info= 0 : INDICATES SUCCESSFUL EXIT. ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE. ! info=i > 0 : INDICATES THAT THE ALGORITHM FAILED TO CONVERGE. ! ! ON EXIT OF stemr : ! ! m GIVES THE TOTAL NUMBER OF EIGENVALUES/EIGENVECTORS FOUND. ! ! z IS OVERWRITTEN WITH THE FIRST m EIGENVECTORS ! OF THE TRIDIAGONAL MATRIX (THE EIGENVECTORS ARE STORED COLUMNWISE). ! ! w IS OVERWRITTEN WITH THE EIGENVALUES OF THE TRIDIAGONAL MATRIX IN ASCENDING ORDER, ! CORRESPONDING TO THE EIGENVECTORS IN z . ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( work, iwork ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM stemr SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to STEMR subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*u - u*s, ! WHERE s ARE THE EIGENVALUES AND u THE EIGENVECTORS OF THE TRIDIAGONAL MATRIX a . ! sup2(:n) = eoshift( sup(:n), -1 ) resid(:n,:le) = spread( diag(:n), dim=2, ncopies=le )*z(:n,:le) + & spread( sup2(:n), dim=2, ncopies=le )*eoshift( z(:n,:le), shift=-1, dim=1 ) + & eoshift( spread(sup2(:n), dim=2, ncopies=le )*z(:n,:le), shift=1 ) - & spread( w(:le), dim=1, ncopies=n )*z(:n,:le) ! normr = norm( resid(:n,:le) ) normt = sqrt( sum( diag(:n)**2 ) + sum( sup(:n-1)**2 ) ) ! err1 = normr/( normt*real(n,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u**(t)*u ! WHERE u are THE EIGENVECTORS OF THE TRIDIAGONAL MATRIX . ! call unit_matrix( id(:le,:le) ) ! resid(:le,:le) = id(:le,:le) - matmul( transpose( z(:n,:le) ), z(:n,:le) ) err2 = norm( resid(:le,:le) )/real(n,stnd) ! err = max( err1, err2 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then ! deallocate( d, e, w, isuppz, z, diag, sup, sup2, id, resid ) ! else ! deallocate( d, e, w, isuppz, z ) ! end if ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from stemr() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed eigenvalues and eigenvectors = ', err1 write (prtunit,*) 'Orthogonality of the computed eigenvectors = ', err2 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing ', le,' eigenvalues and eigenvectors of a ', & n, ' by ', n,' real symmetric tridiagonal matrix is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex3_lapack_stemr ! =============================== ! end program ex3_lapack_stemr
ex3_lapack_syevr.F90¶
program ex3_lapack_syevr ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of the driver subroutines (x)SYEVR ! in LAPACK software for computing all or selected eigenvalues and ! eigenvectors of a real symmetric tridiagonal matrix. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : syevr ! use Statpack, only : lgl, i4b, stnd, true, false, zero, two, c50, safmin, norm, & merror, allocate_error, unit_matrix #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, n IS THE DIMENSION OF THE SYMMETRIX TRIDIAGONAL MATRIX, ! le IS THE NUMBER OF EIGENVECTORS, WHICH WILL BE COMPUTED. ! integer, parameter :: prtunit = 6, n=3000, le=100 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 3 of syevr' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, err1, err2, eps, abstol, vl, vu, elapsed_time real(stnd) :: work2(1) real(stnd), dimension(:), allocatable :: w, work, resid2 real(stnd), dimension(:,:), allocatable :: a, a2, z ! integer :: info, lwork, liwork, iok, il, iu, m, & istart, iend, irate, imax, itime integer :: iwork2(1) integer, dimension(:), allocatable :: isuppz, iwork ! logical(lgl) :: do_test ! character :: jobz, uplo, range ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 3 : FIRST le EIGENVALUES AND, OPTIONALLY, EIGENVECTORS OF A REAL SYMMETRIC ! MATRIX USING THE MRRR ALGORITHM (HOWEVER, IN THE CURRENT VERSION OF LAPACK ! SYEVR CALLS (x)STEBZ AND (x)STEIN SUBROUTINES WHEN PARTIAL SPECTRUM REQUESTS ! ARE MADE). ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! abstol = two*safmin eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a(n,n), z(n,n), w(n), isuppz(2*n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A n-by-n RANDOM DATA MATRIX AND FROM IT ! A SELF-ADJOINT MATRIX a . ! call random_number( z ) ! a = z + transpose( z ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(n,n), resid2(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! MAKE A COPY OF THE RANDOM DATA MATRIX. ! a2(:n,:n) = a(:n,:n) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! FIRST DETERMINE THE WORK TO DO. ! ! IF jobz='N' COMPUTE EIGENVALUES ONLY, ! IF jobz='V' COMPUTE EIGENVALUES AND EIGENVECTORS. ! jobz = 'V' ! ! IF range='A' ALL EIGENVALUES WILL BE FOUND, ! IF range='V' ALL EIGENVALUES IN THE HALF OPEN INTERVAL (vl,vu) WILL BE FOUND, ! IF range='I' THE il-TH THROUGH iu-TH EIGENVALUES IN ASCENDING ORDER WILL BE FOUND. ! range = 'I' ! ! IF uplo='U' UPPER TRIANGLE OF a IS STORED, ! IF uplo='L' LOWER TRIANGLE OF a IS STORED. ! uplo = 'U' ! vl = zero vu = zero ! il = n - le + 1 iu = n ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR syevr SUBROUTINE. ! lwork = -1 liwork = -1 ! call syevr( jobz, range, uplo, n, a, n, vl, vu, il, iu, abstol, & m, w, z, n, isuppz, work2, lwork, iwork2, liwork, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) + 10 liwork = iwork2(1) ! ! ALLOCATE WORK VARIABLES NEEDED BY syevr SUBROUTINE. ! allocate( work(lwork), iwork(liwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! COMPUTE SELECTED EIGENVALUES AND EIGENVECTORS OF THE SELF-ADJOINT MATRIX a ! WITH SUBROUTINE syevr FROM LAPACK. ! THE EIGENVALUE DECOMPOSITION OF A REAL n-BY-n SYMMETRIC MATRIX a ! IS WRITTEN ! ! a = U * D * U**(t) ! ! WHERE D IS AN n-BY-n DIAGONAL MATRIX AND U IS AN n-BY-n ORTHOGONAL MATRIX. ! THE DIAGONAL ELEMENTS OF D ARE THE EIGENVALUES OF a; THEY ARE REAL. ! THE COLUMNS OF U ARE THE EIGENVECTORS OF a. ! call syevr( jobz, range, uplo, n, a, n, vl, vu, il, iu, abstol, & m, w, z, n, isuppz, work, lwork, iwork, liwork, info ) ! ! ON EXIT OF syevr : ! ! info= 0 : INDICATES SUCCESSFUL EXIT. ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE. ! info=i > 0 : INDICATES THAT THE ALGORITHM FAILED TO CONVERGE. ! ! ON EXIT OF syevr : ! ! THE LOWER (IF uplo='L') OR UPPER (IF uplo='U') TRIANGLE ! OF a IS DESTROYED, INCLUDING THE DIAGONAL. ! ! m GIVES THE TOTAL NUMBER OF EIGENVALUES/EIGENVECTORS FOUND. ! ! z IS OVERWRITTEN WITH THE FIRST m EIGENVECTORS ! OF a (THE EIGENVECTORS ARE STORED COLUMNWISE). ! ! w IS OVERWRITTEN WITH THE EIGENVALUES OF a IN ASCENDING ORDER, ! CORRESPONDING TO THE EIGENVECTORS IN z . ! ! DEALLOCATE WORK ARRAYS. ! deallocate ( work, iwork ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM syevr SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to SYEVR subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*U - U*D ! a(:n,:m) = matmul(a2(:n,:n),z(:n,:m)) - z(:n,:m)*spread(w(:m),1,n) resid2(:m) = norm( a(:n,:m), dim=2_i4b ) err1 = maxval( resid2(:m) )/( norm( a2 )*real(n,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U. ! call unit_matrix( a2(:m,:m) ) ! a(:m,:m) = abs( a2(:m,:m) - matmul( transpose(z(:n,:m)), z(:n,:m) ) ) err2 = maxval( a(:m,:m) )/real(n,stnd) ! err = max( err1, err2 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, z, w, isuppz, a2, resid2 ) else deallocate( a, z, w, isuppz ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from syevr() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed eigenvalues and eigenvectors = ', err1 write (prtunit,*) 'Orthogonality of the computed eigenvectors = ', err2 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing ', m, ' eigenvalues and eigenvectors of a ', & n, ' by ', n,' real symmetric matrix is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex3_lapack_syevr ! =============================== ! end program ex3_lapack_syevr
ex3_lapack_syevx.F90¶
program ex3_lapack_syevx ! ! ! Purpose ! ======= ! ! This program is intended to demonstrate the use of subroutine SYEVX ! in LAPACK software for computing all or selected eigenvalues and ! eigenvectors of a real symmetric tridiagonal matrix. ! ! LATEST REVISION : 06/11/2023 ! ! ================================================================================================ ! ! ! USED MODULES ! ============ ! use Lapack_interfaces, only : syevx ! use Statpack, only : lgl, i4b, stnd, true, false, zero, two, c50, safmin, norm, & merror, allocate_error, unit_matrix #ifdef _MATMUL use Statpack, only : matmul=>matmul2 #endif #ifdef _TRANSPOSE use Statpack, only : transpose=>transpose2 #endif ! ! ! STRONG TYPING IMPOSED ! ===================== ! implicit none ! ! ! PARAMETERS ! ========== ! ! prtunit IS THE PRINTING UNIT, n IS THE DIMENSION OF THE SYMMETRIX TRIDIAGONAL MATRIX, ! le IS THE NUMBER OF EIGENVALUES AND EIGENVECTORS, WHICH WILL BE COMPUTED. ! integer, parameter :: prtunit = 6, n=3000, le=100 ! ! fudge IS A FUDGING FACTOR FOR THE ACCURACY TESTS. ! real(stnd), parameter :: fudge=c50 ! character(len=*), parameter :: name_proc='Example 3 of syevx' ! ! ! SPECIFICATIONS FOR VARIABLES ! ============================ ! real(stnd) :: err, err1, err2, eps, abstol, vl, vu, elapsed_time real(stnd) :: work2(1) real(stnd), dimension(:), allocatable :: w, work, resid2 real(stnd), dimension(:,:), allocatable :: a, a2, z ! integer :: info, lwork, iok, il, iu, m, istart, & iend, irate, imax, itime integer, dimension(:), allocatable :: iwork, ifail ! logical(lgl) :: do_test ! character :: jobz, uplo, range ! ! ! EXECUTABLE STATEMENTS ! ===================== ! ! ! PRINT LABEL OF THE EXAMPLE. ! write (prtunit,*) write (prtunit,*) name_proc,' :' write (prtunit,*) repeat('*', len(name_proc) ) write (prtunit,*) ! ! EXAMPLE 3 : FIRST le EIGENVALUES AND, OPTIONALLY, EIGENVECTORS OF A REAL SYMMETRIC ! MATRIX USING THE BISECTION AND INVERSE ITERATION METHODS. ! ! SET THE REQUIRED PRECISION OF THE RESULTS. ! abstol = two*safmin eps = fudge*epsilon( err ) err = zero ! ! SPECIFY IF NUMERICAL TESTS MUST BE PERFORMED. ! do_test = true ! ! ALLOCATE WORK ARRAYS. ! allocate( a(n,n), z(n,n), w(n), iwork(5*n), ifail(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! GENERATE A n-by-n RANDOM DATA MATRIX AND FROM IT ! A SELF-ADJOINT MATRIX a . ! call random_number( z ) ! a = z + transpose( z ) ! if ( do_test ) then ! ! ALLOCATE WORK ARRAYS. ! allocate( a2(n,n), resid2(n), stat=iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! MAKE A COPY OF THE RANDOM DATA MATRIX. ! a2(:n,:n) = a(:n,:n) ! end if ! ! START TIMING THE COMPUTATIONS. ! call system_clock( count_rate=irate, count_max=imax ) call system_clock( count=istart ) ! ! FIRST DETERMINE THE WORK TO DO. ! ! IF jobz='N' COMPUTE EIGENVALUES ONLY, ! IF jobz='V' COMPUTE EIGENVALUES AND EIGENVECTORS. ! jobz = 'V' ! ! IF range='A' ALL EIGENVALUES WILL BE FOUND, ! IF range='V' ALL EIGENVALUES IN THE HALF OPEN INTERVAL (vl,vu] WILL BE FOUND, ! IF range='I' THE il-TH THROUGH iu-TH EIGENVALUES IN ASCENDING ORDER WILL BE FOUND. ! range = 'I' ! ! IF uplo='U' UPPER TRIANGLE OF a IS STORED, ! IF uplo='L' LOWER TRIANGLE OF a IS STORED. ! uplo = 'U' ! vl = zero vu = zero ! il = n - le + 1 iu = n ! ! COMPUTE FIRST OPTIMAL WORKSPACE FOR syevx SUBROUTINE. ! lwork = -1 ! call syevx( jobz, range, uplo, n, a, n, vl, vu, il, iu, abstol, & m, w, z, n, work2, lwork, iwork, ifail, info ) ! if ( info==0 ) then ! lwork = int(work2(1)) ! ! ALLOCATE WORK VARIABLE NEEDED BY syevx SUBROUTINE. ! allocate( work(lwork), stat = iok ) ! if ( iok/=0 ) then call merror( name_proc//allocate_error ) end if ! ! COMPUTE EIGENVALUES AND EIGENVECTORS OF THE SELF-ADJOINT MATRIX a ! WITH SUBROUTINE syevx FROM LAPACK. ! THE EIGENVALUE DECOMPOSITION OF A REAL n-BY-n SYMMETRIC MATRIX a ! IS WRITTEN ! ! a = U * D * U**(t) ! ! WHERE D IS AN n-BY-n DIAGONAL MATRIX AND U IS AN n-BY-n ORTHOGONAL MATRIX. ! THE DIAGONAL ELEMENTS OF D ARE THE EIGENVALUES OF a; THEY ARE REAL. ! THE COLUMNS OF U ARE THE EIGENVECTORS OF a. ! call syevx( jobz, range, uplo, n, a, n, vl, vu, il, iu, abstol, & m, w, z, n, work, lwork, iwork, ifail, info ) ! ! ON EXIT OF syevx : ! ! info= 0 : INDICATES SUCCESSFUL EXIT ! info=-i < 0 : INDICATES THAT THE iTH ARGUMENT HAS AN ILLEGAL VALUE ! info=i > 0 : INDICATES THAT i EIGENVECTORS FAILED TO CONVERGE AND ! THEIR INDICES ARE STORED IN ARRAY ifail. ! ! ON EXIT OF syevx : ! ! THE LOWER (IF uplo='L') OR UPPER (IF uplo='U') TRIANGLE ! OF a IS DESTROYED, INCLUDING THE DIAGONAL. ! ! m GIVES THE TOTAL NUMBER OF EIGENVALUES/EIGENVECTORS FOUND. ! ! z IS OVERWRITTEN WITH THE FIRST m EIGENVECTORS ! OF a (THE EIGENVECTORS ARE STORED COLUMNWISE). ! ! w IS OVERWRITTEN WITH THE EIGENVALUES OF a IN ASCENDING ORDER, ! CORRESPONDING TO THE EIGENVECTORS IN z . ! ! DEALLOCATE WORK ARRAY. ! deallocate ( work ) ! end if ! ! STOP THE TIMER. ! call system_clock( count=iend ) ! itime = iend - istart if ( iend<istart ) then itime = itime + imax end if ! elapsed_time = real( itime, stnd )/real( irate, stnd ) ! if ( info/=0 ) then ! ! ANORMAL EXIT FROM syevx SUBROUTINE, PRINT A WARNING. ! write (prtunit,*) 'Error in the call to SYEVX subroutine, Info=', info ! if ( info<0 ) then ! write (prtunit,'(''Argument '',i3,'' has an illegal value'')') - info ! end if ! else if ( do_test ) then ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*U - U*D ! a(:n,:m) = matmul(a2(:n,:n),z(:n,:m)) - z(:n,:m)*spread(w(:m),1,n) resid2(:m) = norm( a(:n,:m), dim=2_i4b ) err1 = maxval( resid2(:m) )/( norm( a2 )*real(n,stnd) ) ! ! CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U. ! call unit_matrix( a2(:m,:m) ) ! a(:m,:m) = abs( a2(:m,:m) - matmul( transpose(z(:n,:m)), z(:n,:m) ) ) err2 = maxval( a(:m,:m) )/real(n,stnd) ! err = max( err1, err2 ) ! end if ! ! DEALLOCATE WORK ARRAYS. ! if ( do_test ) then deallocate( a, z, w, iwork, ifail, a2, resid2 ) else deallocate( a, z, w, iwork, ifail ) end if ! ! CHECK THE RESULTS FOR SMALL RESIDUALS. ! if ( err<=eps .and. info==0 ) then write (prtunit,*) name_proc//' is correct' else write (prtunit,*) name_proc//' is incorrect' end if ! write (prtunit,*) write (prtunit,*) ' INFO ( from syevx() ) = ', info ! if ( do_test .and. info==0 ) then write (prtunit,*) write (prtunit,*) 'Accuracy of the computed eigenvalues and eigenvectors = ', err1 write (prtunit,*) 'Orthogonality of the computed eigenvectors = ', err2 end if ! write (prtunit,*) write (*,'(a,i6,a,i6,a,i6,a,0pd12.4,a)') & 'The elapsed time for computing ', m, ' eigenvalues and eigenvectors of a ', & n, ' by ', n,' real symmetric matrix is ', elapsed_time, ' seconds' ! ! ! END OF PROGRAM ex3_lapack_syevx ! =============================== ! end program ex3_lapack_syevx