STATPACK examples

ex1_apply_q_bd.F90

program ex1_apply_q_bd
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines APPLY_Q_BD and APPLY_P_BD
!   in module SVD_Procedures.
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutines BD_CMP, BD_SVD and BD_INVITER
!    in module SVD_Procedures.
!
! LATEST REVISION : 10/06/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, bd_inviter,     &
                         bd_cmp, bd_svd, apply_q_bd, apply_p_bd, norm, c50
#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
!
    integer(i4b), parameter :: prtunit=6, n=1000, m=500, mn=min(m,n), nsing=20
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of apply_q_bd'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                     :: err, eps
    real(stnd), dimension(n,m)     :: a, a2
    real(stnd), dimension(n,nsing) :: leftvec
    real(stnd), dimension(m,nsing) :: rightvec
    real(stnd), dimension(mn)      :: s, d, e, e2, tauq, taup
!
    integer(i4b) :: maxiter=2
!
    logical(lgl) :: failure, bd_is_upper
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
!
!   GENERATE A RANDOM DATA MATRIX a.
!
    call random_number( a )
!
!   SAVE RANDOM DATA MATRIX a .
!
    a2(:n,:m) = a(:n,:m)
!
!   REDUCE a TO LOWER OR UPPER BIDIAGONAL FORM.
!
    call bd_cmp( a, s, e2, tauq, taup )
!
!   THE DIAGONAL ELEMENTS ARE STORED IN s .
!   THE OFF-DIAGONAL ELEMENTS ARE STORED IN e2 .
!
!   SAVE BIDIAGONAL FORM OF a .
!
     e(:mn) = e2(:mn)
     d(:mn) = s(:mn)
!
     bd_is_upper = n>=m
!
!    COMPUTE SINGULAR VALUES OF BIDIAGONAL FORM OF a .
!
     call bd_svd( bd_is_upper, s, e2, failure, sort=sort  )
!
     if ( .not. failure ) then
!
!       COMPUTE THE FIRST nsing SINGULAR VECTORS OF a BY maxiter
!       INVERSE ITERATIONS ON THE INTERMEDIATE BIDIAGONAL MATRIX
!       d_e AND BACK-TRANSFORMATION.
!
        call bd_inviter( bd_is_upper, d, e, s(:nsing), leftvec(:mn,:nsing), rightvec(:mn,:nsing),  &
                         failure, maxiter=maxiter )
!
!       COMPUTE SINGULAR VECTORS OF a BY BACK-TRANSFORMATION.
!
        if ( bd_is_upper ) then
            leftvec(mn+1_i4b:n,:nsing) = zero
        else
            rightvec(mn+1_i4b:m,:nsing) = zero
        end if
!
!       GENERATE LEFT SINGULAR VECTORS OF a IN leftvec BY BACK-TRANSFORMATION.
!
        call apply_q_bd( a, tauq, leftvec,  left=true, trans=false )
!
!       GENERATE RIGHT SINGULAR VECTORS OF a IN rightvec BY BACK-TRANSFORMATION.
!
        call apply_p_bd( a, taup, rightvec, left=true, trans=false )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*rightvec - leftvec*s(:nsing),
!       WHERE leftvec AND rightvec ARE THE LEFT AND RIGHT SINGULAR VECTORS.
!
        err =  norm( matmul(a2,rightvec) - leftvec*spread(s(:nsing),dim=1,ncopies=n) )/( sum( abs(s(:mn)) )*real(mn,stnd) )
!
    end if
!
    if ( err<=eps .and. .not.failure ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex1_apply_q_bd
! =============================
!
end program ex1_apply_q_bd

ex1_bd_cmp.F90

program ex1_bd_cmp
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines BD_CMP and ORTHO_GEN_BD
!   in module SVD_Procedures .
!                                                                              
! LATEST REVISION : 23/05/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, bd_cmp,         &
                         ortho_gen_bd, 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
!
    integer(i4b), parameter :: prtunit=6, m=3000, n=3000, nm=min(n,m)
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of bd_cmp'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err3, err, eps, elapsed_time
    real(stnd), allocatable, dimension(:)   :: d, e, tauq, taup
    real(stnd), allocatable, dimension(:,:) :: a, a2, resid, bd, p
!
    integer(i4b) :: l
!
    integer      :: 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 : BIDIAGONAL REDUCTION OF A m-by-n REAL MATRIX.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
!
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(m,n), p(n,nm), d(nm), e(nm),     &
              tauq(nm), taup(nm), 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 ARRAYS.
!
        allocate( a2(m,n), bd(nm,nm), resid(nm,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 )
!
!   FIRST, CALL bd_cmp TO REDUCE THE MATRIX a TO BIDIAGONAL FORM
!
!                      a = Q*BD*P**(t)
!
!   WHERE Q AND P ARE ORTHOGONAL AND BD IS AN UPPER OR LOWER BIDIAGONAL MATRIX.
!
    call bd_cmp( a, d, e, tauq, taup )
!
!   ON OUTPUT OF bd_cmp:
!
!       a, tauq AND taup CONTAINS THE ELEMENTARY REFLECTORS
!       DEFINING Q AND P IN PACKED FORM.
!
!       d AND e CONTAINS RESPECTIVELY, THE DIAGONAL AND
!       SUBDIAGONAL OF THE BIDIAGONAL MATRIX BD.
!
!   SECOND, CALL ortho_gen_bd TO GENERATE Q AND P.
!
    call ortho_gen_bd( a, tauq, taup, p )
!
!   ON OUTPUT OF ortho_gen_bd, a CONTAINS THE FIRST min(n,m) COLUMNS OF Q
!   AND p CONTAINS THE ORTHOGONAL MATRIX P.
!
!   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 ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION Q**(t)*a - BD*P**(t),
!
        bd(:nm,:nm) = zero
!
        if ( m>=n ) then
!
!           BD IS UPPER BIDIAGONAL.
!
            do l = 1_i4b, nm-1_i4b
                bd(l,l)       = d(l)
                bd(l,l+1_i4b) = e(l+1_i4b)
            end do
!
            bd(nm,nm) = d(nm)
!
        else
!
!           BD IS LOWER BIDIAGONAL.
!
            bd(1_i4b,1_i4b) = d(1_i4b)
!
            do l = 2_i4b, nm
                bd(l,l-1_i4b) = e(l)
                bd(l,l)       = d(l)
            end do
!
        endif
!
        resid(:nm,:n) = matmul( transpose(a(:m,:nm)), a2(:m,:n) )           &
                        - matmul( bd(:nm,:nm), transpose(p(:n,:nm )) )
!
        bd(:nm,1_i4b) = norm( resid(:nm,:n), dim=1_i4b )
        err1 =  maxval( bd(:nm,1_i4b) )/( norm( a2 )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - Q**(t)*Q.
!
        call unit_matrix( a2(:nm,:nm) )
!
        resid(:nm,:nm) = abs( a2(:nm,:nm) - matmul( transpose(a(:m,:nm )), a(:m,:nm ) ) )
        err2 = maxval( resid(:nm,:nm) )/real(m,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - P**(t)*P.
!
        resid(:nm,:nm) = abs( a2(:nm,:nm) - matmul( transpose(p(:n,:nm )), p(:n,:nm ) ) )
        err3 = maxval( resid(:nm,:nm) )/real(n,stnd)
!
        err = max( err1, err2, err3 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a2, bd, resid )
!
    endif
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, p, d, e, tauq, taup )
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) 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,i5,a,i5,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_bd_cmp
! =========================
!
end program ex1_bd_cmp

ex1_bd_cmp2.F90

program ex1_bd_cmp2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine BD_CMP2
!   in module SVD_Procedures .
!                                                                              
! LATEST REVISION : 06/06/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, bd_cmp2,     &
                         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
!
    integer(i4b), parameter :: prtunit=6, m=8000, n=5000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of bd_cmp2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err3, err, eps, elapsed_time
    real(stnd), allocatable, dimension(:)   :: d, e
    real(stnd), allocatable, dimension(:,:) :: a2, resid, bd, a, p
!
    integer(i4b) :: l
!
    integer      :: iok, istart, iend, irate, imax, itime
!
    logical(lgl) :: failure, 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 m-by-n MATRIX (WITH m>=n)
!   USING THE Ralha-Barlow ONE_SIDED ALGORITHM.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
!
    err = zero
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(m,n), p(n,n), d(n), e(n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM DATA MATRIX .
!
    call random_number( a )
!
    if ( do_test ) then
!
        allocate( a2(m,n), bd(n,n), resid(n,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 )
!
!   CALL bd_cmp2 TO REDUCE THE MATRIX a TO BIDIAGONAL FORM
!
!               a = Q*BD*P**(t)
!
!   WHERE Q AND P ARE ORTHOGONAL AND BD IS AN UPPER BIDIAGONAL MATRIX.
!   bd_cmp2 USES THE ONE_SIDED RHALA-BARLOW ALGORITM AND IS FASTER THAN
!   THE STANDARD BIDIAGONALIZATION ALGORITHM USED IN bd_cmp. HOWEVER, A
!   A SLIGHT LOSS OF ORTHOGONALITY CAN BE EXPECTED FOR Q SINCE Q IS
!   COMPUTED FROM A RECURRENCE RELATIONSHIP.
!
    call bd_cmp2( a, d, e, p, failure=failure )
!
!   ON OUTPUT OF bd_cmp2:
!
!       a CONTAINS THE FIRST min(n,m) COLUMNS OF Q
!       AND p CONTAINS THE ORTHOGONAL MATRIX P.
!
!       d AND e CONTAINS RESPECTIVELY, THE DIAGONAL AND
!       SUBDIAGONAL OF THE BIDIAGONAL MATRIX BD.
!
!       failure= false :  INDICATES SUCCESSFUL EXIT.
!       failure= true  :  INDICATES THAT a IS NEARLY SINGULAR AND SOME LOSS
!                         OF ORTHOGONALITY FOR Q CAN BE EXPECTED.
!
!   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 ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION Q**(t)*a - BD*P**(t),
!
        bd(:n,:n) = zero
!
        do l = 1_i4b, n-1_i4b
            bd(l,l)       = d(l)
            bd(l,l+1_i4b) = e(l+1_i4b)
        end do
!
        bd(n,n) = d(n)
!
        resid(:n,:n) = matmul( transpose(a(:m,:n)), a2(:m,:n) )    &
                        - matmul( bd(:n,:n), transpose(p(:n,:n)) )
!
        bd(:n,1_i4b) = norm( resid(:n,:n), dim=2_i4b )
        err1 =  maxval( bd(: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 ), a ) )
        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( transpose( p ), p ) )
        err3 = maxval( resid(:n,:n) )/real(n,stnd)
!
        err = max( err1, err2, err3 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a2, bd, resid )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, p, d, e )
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps ) then
!    if ( err<=eps .and. .not.failure ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) 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,i5,a,i5,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_bd_cmp2
! ==========================
!
end program ex1_bd_cmp2

ex1_bd_cmp3.F90

program ex1_bd_cmp3
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine BD_CMP3
!   in module SVD_Procedures.
!                                                                              
! LATEST REVISION : 10/09/2019
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, bd_cmp3, &
                         bd_svd, 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 MATRIX WHOSE
! SVD MUST BE COMPUTED, m MUST BE GREATER THAN n, OTHERWISE
! bd_cmp3 WILL STOP WITH AN ERROR MESSAGE.
!
    integer(i4b), parameter :: prtunit=6, m=3000, n=1000
!   
    real(stnd), parameter  :: fudge=c50
!
    character, parameter :: sort='d'
!
    character(len=*), parameter :: name_proc='Example 1 of bd_cmp3'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err, eps, elapsed_time
    real(stnd), allocatable, dimension(:)   :: d, e
    real(stnd), allocatable, dimension(:,:) :: a, at, ata, resid
!
    integer :: iok, istart, iend, irate, imax, itime
!
    logical(lgl) :: do_test, failure
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : EIGENDECOMPOSITION OF A REAL SYMMETRIC MATRIX PRODUCT,
!               a**(t)*a, USING THE ONE-SIDED RALHA BIDIAGONALIZATION
!               METHOD APPLIED TO MATRIX a .
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(m,n), d(n), e(n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A m-by-n RANDOM DATA MATRIX a .
!
    call random_number( a )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( ata(n,n), at(n,m), resid(n,n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
        at(:n,:m) = transpose( a(:m,:n) )
!
!       COMPUTE THE SYMMETRIC MATRIX CROSS-PRODUCT a**(t)*a .
!
        ata(:n,:n) = matmul( at(:n,:m), a(:m,:n) )
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   CALL bd_cmp3 TO REDUCE THE MATRIX a TO BIDIAGONAL FORM
!
!                      a = Q*BD*P**(t)
!
!   WHERE P AND Q ARE ORTHOGONAL AND BD IS AN UPPER BIDIAGONAL MATRIX.
!
!   ON ENTRY OF bd_cmp3, a MUST CONTAINS THE INITIAL m-by-n MATRIX.
!   THE ORTHOGONAL MATRIX P IS COMPUTED IF THE LOGICAL ARGUMENT gen_p IS SET TO true.
!   THE ORTHOGONAL MATRIX P IS STORED IN FACTORED FORM IF THE LOGICAL ARGUMENT gen_p IS
!   SET TO false.
!
    call bd_cmp3( a(:m,:n), d(:n), e(:n), gen_p=true, failure=failure )
!
!   ON EXIT OF bd_cmp3:
!
!         ARGUMENTS d AND e CONTAIN, RESPECTIVELY, THE DIAGONAL AND
!         OFF-DIAGONAL ELEMENTS OF THE BIDIAGONAL MATRIX BD.
!
!         IF THE LOGICAL ARGUMENT gen_p IS SET TO false ON ENTRY,
!         THE LEADING n-BY-n LOWER TRIANGULAR PART OF a IS OVERWRITTEN
!         BY THE MATRIX P AS A PRODUCT OF ELEMENTARY REFLECTORS.
!
!         IF THE LOGICAL ARGUMENT gen_p IS SET TO false ON ENTRY,
!         THE LEADING n-BY-n PART OF a IS OVERWRITTEN
!         BY THE MATRIX P.
!
!         Q IS NOT COMPUTED BY bd_cmp3.
!
!   COMPUTE SVD DECOMPOSITION OF MATRIX a WITH SUBROUTINE bd_svd:
!
!                            a = V*D*U**(t)
!
!   WHERE V AND U ARE THE LEFT AND RIGHT SINGULAR VECTORS, RESPECTIVELY, AND
!   D IS A DIAGONAL MATRIX, WITH SINGULAR VALUES ON THE DIAGONAL.
!
    call bd_svd( false, d(:n), e(:n), failure, a(:n,:n), sort=sort )
!
!   ON EXIT OF bd_svd :
!
!         ARGUMENTS d AND a(:n:n) CONTAIN, RESPECTIVELY, THE SINGULAR VALUES AND
!         RIGHT SINGULAR VECTORS OF MATRIX a. LEFT SINGULAR VECTORS ARE NOT COMPUTED
!         WITH THIS CALL OF bd_svd.
!
!   COMPUTE EIGENVALUES OF a**(t)*a FROM THE SINGULAR VALUES OF a .
!
    d(:n) = d(:n)*d(:n)
!
!   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 ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION (a**(t)*a)*U - U*D
!
        resid(:n,:n) = matmul( ata(:n,:n), a(:n,:n)  )    &
                       - a(:n,:n)*spread( d(:n), 1, n )
!
        e(:n) = norm( resid(:n,:n), dim=2_i4b )
        err1 =  maxval( e(:n) )/( norm( ata )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U.
!
        call unit_matrix( ata(:n,:n) )
!
        at(:n,:n) = transpose( a(:n,:n) )
!
        resid(:n,:n) = abs( ata(:n,:n) - matmul( at(:n,:n), a(:n,:n) ) )
        err2 = maxval( resid(:n,:n) )/real(n,stnd)
!
        err = max( err1, err2 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( ata, resid, at )
!
    endif
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, d, e )
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) then
        write (prtunit,*) 
        write (prtunit,*) 'Accuracy of the computed eigendecomposition a**(t)*a = U*D*U**(t) = ', err1
        write (prtunit,*) 'Orthogonality of the computed eigenvectors U**(t)*U - I           = ', err2
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing the eigendecomposition of a ',       &
       n, ' by ', n,' real matrix cross-product is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_bd_cmp3
! ==========================
!
end program ex1_bd_cmp3

ex1_bd_coef.F90

program ex1_bd_coef
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines/functions BD_COEF,
!   FREQ_FUNC and SYMLIN_FILTER in module Time_Series_Procedures.
!                                                                              
! LATEST REVISION : 12/11/2007
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, zero, half, one, two, pi, true, false, merror, allocate_error,   &
                         bd_coef, freq_func, symlin_filter, init_fft, fft, end_fft
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT, n IS THE LENGTH OF THE TIME SERIES .
!
    integer(i4b), parameter :: prtunit=6, n=2001
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                            :: err, tmp, fch, fcl
    real(stnd), dimension(n)              :: y, y2, y3, freqr
    real(stnd), dimension(:), allocatable :: coef
!
    complex(stnd), dimension(n)           :: yc
!
    integer(i4b) :: i, k, k1, k2, pl, ph, nfilt, khalf, kmid
!   
    integer :: iok
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of bd_coef'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A RANDOM REAL NUMBER SEQUENCE OF LENGTH n .
!
    call random_number( y(:n) )
!
!   SAVE THE REAL RANDOM NUMBER ARRAY.
!
    y2(:n) = y(:n)
!
!   pl IS THE MINIMUM PERIOD OF OSCILLATION OF DESIRED COMPONENT.
!   ph IS THE MAXIMUM PERIOD OF OSCILLATION OF DESIRED COMPONENT.
!   pl AND ph ARE EXPRESSED IN NUMBER OF OBSERVATIONS, I.E. pl=6(18) and ph=32(96) SELECT
!   PERIODS BETWEEN 1.5 YRS AND 8 YRS FOR QUARTERLY (MONTHLY) DATA.
!
    pl  = 35
    ph  = 96
!
!   COMPUTE THE CORRESPONDING CUTOFF FREQUENCIES.
!
    fch = one/real( ph, stnd )
    fcl = one/real( pl, stnd )
!
!   NOW SELECT THE OPTIMAL NUMBER OF FILTER COEFFICIENTS k FOR THE LANCZOS FILTER.
!
    k1  = ceiling( one/(half-fcl) )
    k2  = ceiling(  2.6/(fcl-fch) )
    k   = max( k1, k2, ph+1 )
    if ( (k/2)*2==k  ) k = k + 1
!
!   ALLOCATE WORK ARRAY FOR THE FILTER COEFFICIENTS.
!
    allocate( coef(k), stat=iok )
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   FUNCTION bd_coef COMPUTES THE K-TERM LEAST SQUARES APPROXIMATION TO AN
!   -IDEAL- BAND PASS FILTER WITH CUTOFF PERIODS PL AND PH (EG CUTOFF FREQUENCIES 1/PL AND 1/PH).
!
    coef(:k) = bd_coef( PL=pl, PH=ph, K=k )
!
!   SUBROUTINE symlin_filter PERFORMS A SYMMETRIC FILTERING OPERATION ON AN IMPUT
!   TIME SERIES (THE ARGUMENT VEC).
!
!   HERE symlin_filter FILTERS THE TIME SERIES, KEEPING THE PERIODS BETWEEN pl AND ph .
!   NOTE THAT (size(COEF)-1)/2 DATA POINTS WILL BE LOST FROM EACH END OF THE SERIES SO THAT
!   NFILT (NFILT= size(VEC) - size(COEF) + 1) TIME OBSERVATIONS ARE RETURNED IN VEC(:NFILT)
!   AND THE REMAINING OBSERVATIONS ARE SET TO ZERO.
!
    call symlin_filter( VEC=y2(:n), COEF=coef(:k),  NFILT=nfilt )
!
!   NOW COMPUTE THE TRANSFERT FUNCTION freqr(:) OF THE LANCZOS FILTER AT THE FOURIER FREQUENCIES.
!
    call freq_func( NFREQ=n, COEF=coef(:k), FREQR=freqr(:n), FOUR_FREQ=true )
!
!   NOW, APPLY THE FILTER USING THE FFT AND THE CONVOLUTION THEOREM.
!
!   INITIALIZE THE FFT SUBROUTINE.
!
    call init_fft( n )
!
!   TRANSFORM THE TIME SERIES.
!
    yc(1:n) = cmplx( y(1:n), zero, kind=stnd )
!
    call fft( yc(:n), forward=true  )
!
!   MULTIPLY THE FOURIER TRANSFORM OF THE TIME SERIES
!   BY THE TRANSFERT FUNCTION OF THE FILTER.
!
    yc(:n) = yc(:n)*freqr(:n)
!
!   INVERT THE SEQUENCE BACK TO GET THE FILTERED TIME SERIES.
!
    call fft( yc(:n), forward=false )
!
    y3(:n) = real( yc(:n),  kind=stnd )
!
!   DEALLOCATE WORK ARRAYS.
!
    call end_fft()
!
    deallocate( coef )
!
!   TEST THE ACCURACY OF THE FILTERING OPERATION.
!
    kmid  = ( k + 1 )/2
    khalf = ( k - 1 )/2
    k1    = kmid
    k2    = n - khalf
!
    err = maxval(abs(y3(k1:k2)-y2(:nfilt)))/maxval(abs(y(k1:k2)))
!
    if ( err<=sqrt(epsilon(err))  ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex1_bd_coef
! ==========================
!
end program ex1_bd_coef

ex1_bd_coef2.F90

program ex1_bd_coef2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines/functions BD_COEF2
!   and SYMLIN_FILTER2 in module Time_Series_Procedures.
!                                                                              
! LATEST REVISION : 12/11/2007
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, true, merror, allocate_error,   &
                         bd_coef2, symlin_filter2
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT, n IS THE LENGTH OF THE TIME SERIES .
!
    integer(i4b), parameter :: prtunit=6, n=2000
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                            :: err
    real(stnd), dimension(n)              :: y, y2, y3
    real(stnd), dimension(:), allocatable :: coef
!
    integer(i4b) :: k, k1, k2, pl, ph, khalf, kmid
!   
    integer :: iok
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of bd_coef2'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A RANDOM REAL NUMBER SEQUENCE OF LENGTH n .
!
    call random_number( y(:n) )
!
!   SAVE THE REAL RANDOM NUMBER ARRAY.
!
    y2(:n) = y(:n)
    y3(:n) = y(:n)
!
!   pl IS THE MINIMUM PERIOD OF OSCILLATION OF DESIRED COMPONENT.
!   ph IS THE MAXIMUM PERIOD OF OSCILLATION OF DESIRED COMPONENT.
!   pl AND ph ARE EXPRESSED IN NUMBER OF OBSERVATIONS, I.E. pl=6(18) and ph=32(96) SELECT
!   PERIODS BETWEEN 1.5 YRS AND 8 YRS FOR QUARTERLY (MONTHLY) DATA.
!
    pl  = 35
    ph  = 96
!
!   NOW SELECT THE NUMBER OF FILTER COEFFICIENTS k FOR THE HAMMING FILTER.
!
    k = ph + 1
    if ( (k/2)*2==k )  k = k + 1
!
!   ALLOCATE WORK ARRAY FOR THE FILTER COEFFICIENTS.
!
    allocate( coef(k), stat=iok )
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   FUNCTION bd_coef2 COMPUTES THE K-TERM LEAST SQUARES APPROXIMATION TO AN
!   -IDEAL- BAND PASS FILTER WITH CUTOFF PERIODS PL AND PH (EG CUTOFF FREQUENCIES 1/PL AND 1/PH).
!
    coef(:k) = bd_coef2( PL=pl, PH=ph, K=k )
!
!   SUBROUTINE symlin_filter2 PERFORMS A SYMMETRIC FILTERING OPERATION ON AN IMPUT
!   TIME SERIES (THE ARGUMENT VEC).
!
!   HERE symlin_filter2 FILTERS THE TIME SERIES, KEEPING THE PERIODS BETWEEN pl AND ph .
!   NOTE THAT (size(COEF)-1)/2 DATA POINTS WILL BE AFFECTED BY END EFFECTS  FROM EACH END OF THE SERIES.
!
    call symlin_filter2( VEC=y2(:n), COEF=coef(:k) )
!
!   FILTER AGAIN THE TIME SERIES, BUT COMPUTE THE VALUES AT THE ENDS OF THE OUTPUT
!   BY ASSUMING THAT THE INPUT IS PART OF A PERIODIC SEQUENCE OF PERIOD n .
!
    call symlin_filter2( VEC=y3(:n), COEF=coef(:k), USEFFT=true )
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( coef )
!
!   TEST THE ACCURACY OF THE FILTERING OPERATION.
!
    kmid  = ( k + 1 )/2
    khalf = ( k - 1 )/2
!
    k1    = kmid
    k2    = n - khalf
!
    err = maxval(abs(y3(k1:k2)-y2(k1:k2)))/maxval(abs(y(k1:k2)))
!
    if ( err<=sqrt(epsilon(err))  ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex1_bd_coef2
! ===========================
!
end program ex1_bd_coef2

ex1_bd_deflate.F90

program ex1_bd_deflate
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine BD_DEFLATE
!   in module SVD_Procedures .
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine BD_SINGVAL in module SVD_Procedures.
!
! LATEST REVISION : 27/05/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, half, c50, bd_deflate,    &
                         bd_singval, unit_matrix, norm, lamch, 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
!
    integer(i4b), parameter :: prtunit=6, n=3000, nsing=100
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of bd_deflate'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, err3, eps, abstol, normbd, elapsed_time
    real(stnd), allocatable, dimension(:)   :: diag, sup, singval, resid2
    real(stnd), allocatable, dimension(:,:) :: leftvec, rightvec, resid
!
    integer(i4b) :: max_qr_steps, nsing2
    integer      :: iok, istart, iend, irate, imax, itime
!
    logical(lgl) :: failure1, failure2, bd_is_upper, ortho, do_test
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : PARTIAL SVD OF A REAL BIDIAGONAL MATRIX BD USING A BISECTION ALGORITHM
!               FOR SINGULAR VALUES AND THE GODUNOV DEFLATION TECHNIQUE FOR SINGULAR VECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    abstol = sqrt(lamch('s'))
    eps    = fudge*epsilon( err )
    err    = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( diag(n), sup(n), singval(n),                    &
              leftvec(n,nsing), rightvec(n,nsing), stat=iok   )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE AN UPPER BIDIAGONAL MATRIX BD.
!   THE DIAGONAL ELEMENTS ARE STORED IN diag.
!   THE OFF-DIAGONAL ELEMENTS ARE STORED IN sup.
!
    bd_is_upper  = true
!
    sup(1_i4b)   = zero
!
    diag(:n)     = half
    sup(2_i4b:n) = half
!
!    call random_number( diag(:n) )
!    call random_number( sup(2_i4b:n) )
!
!    diag(1_i4b)   = 1._stnd
!    diag(2_i4b:n) = 200._stnd*epsilon( err )
!    sup(2_i4b:n)  = 200._stnd*epsilon( err )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   FIRST COMPUTE THE LARGEST nsing SINGULAR VALUES OF THE BIDIAGONAL MATRIX BD.
!
!   ON ENTRY OF bd_singval :
!
!         diag(:n) MUST CONTAIN THE DIAGONAL ELEMENTS OF THE BIDIAGONAL MATRIX.
!         sup(:n)  MUST CONTAIN THE OFF-DIAGONAL ELEMENTS OF THE BIDIAGONAL MATRIX (sup(1) IS ARBITRARY).
!
!         THE OPTIONAL ARGUMENT abstol OF bd_singval MAY BE USED TO INDICATE THE REQUIRED PRECISION FOR THE
!         SINGULAR VALUES. A SINGULAR VALUE IS CONSIDERED TO BE LOCATED IF IT HAS BEEN DETERMINED TO LIE IN
!         AN INTERVAL WHOSE WIDTH IS EQUAL OR LESS THAN abstol. SINGULAR VALUES WILL BE COMPUTED MOST ACCURATELY
!         WHEN abstol IS SET TO THE SQUARE ROOT OF THE UNDERFLOW THRESHOLD (EG sqrt(LAMCH('S')) ).
!
!         THE OPTIONAL ARGUMENT ls MAY BE USED TO INDICATE THE NUMBER OF SINGULAR VALUES TO BE COMPUTED.
!
    call bd_singval( diag(:n), sup(:n), nsing2, singval(:n), failure=failure1, sort=sort, abstol=abstol, ls=nsing  )
!
!   ON EXIT OF bd_singval :
!
!         failure= false :  INDICATES SUCCESSFUL EXIT.
!         failure= true  :  INDICATES THAT MAXIMUM ACCURACY WAS NOT OBTAIN IN THE BISECTION ALGORITHM.
!
!         THE COMPUTED SINGULAR VALUES ARE STORED IN THE FIRST nsing2 ELEMENTS OF THE ARRAY singval IN
!         DECREASING (sort='d') OR ASCENDING (sort='a') ORDER. NOTE THAT nsing2 MAY BE GREATER THAN
!         ARGUMENT ls IN CASE OF MULTIPLE SINGUAR VALUES.
!
!   NEXT COMPUTE THE FIRST nsing SINGULAR VECTORS OF THE BIDIAGONAL MATRIX BD
!   BY A DEFLATION TECHNIQUE WITH SUBROUTINE bd_deflate.
!
!   ON ENTRY OF bd_deflate:
!
!         bd_is_upper INDICATES IF THE BIDIAGONAL MATRIX IS UPPER OR LOWER BIDIAGONAL.
!
!         diag(:n) MUST CONTAIN THE DIAGONAL ELEMENTS OF THE BIDIAGONAL MATRIX.
!         sup(:n)  MUST CONTAIN THE OFF-DIAGONAL ELEMENTS OF THE BIDIAGONAL MATRIX (sup(1) IS ARBITRARY).
!
!         PARAMETER singval CONTAINS SELECTED SINGULAR VALUES OF THE BIDIAGONAL MATRIX bd.
!         THE SINGULAR VALUES MUST BE GIVEN IN DECREASING ORDER.
!
!         OPTIONAL PARAMETER ortho DETERMINES IF DEFLATION IS APPLIED SEQUENTIALLY TO ALL
!         COMPUTED SINGULAR VECTORS (ortho=true) OR ONLY IN EACH CLUSTER OF SINGULAR VALUES
!         (ortho=false). IN THE LATTER CASE, ORTHOGONALITY OF THE SINGULAR VECTORS MAY BE
!         SLIGHTLY DEGRADED, BUT COMPUTATIONS WILL BE MUCH FASTER.
!
    ortho        = true
    max_qr_steps = 10_i4b
!
    call bd_deflate( bd_is_upper, diag(:n), sup(:n), singval(:nsing), leftvec(:n,:nsing), rightvec(:n,:nsing),  &
                     failure=failure2, ortho=ortho, max_qr_steps=max_qr_steps )
!
!   ON EXIT OF bd_deflate :
!
!         failure= false :  INDICATES SUCCESSFUL EXIT.
!         failure= true  :  INDICATES THAT MAXIMUM ACCURACY WAS NOT OBTAIN IN THE DEFLATION ALGORITHM.
!
!         leftvec AND rightvec CONTAIN, RESPECTIVELY, THE nsing LEFT AND RIGHT
!         SINGULAR VECTORS OF THE BIDIAGONAL MATRIX BD ASSOCIATED WITH THE SINGULAR VALUES singval(:nsing).
!
!         bd_deflate MAY FAIL IF SOME THE SINGULAR VALUES SPECIFIED IN PARAMETER singval ARE NEARLY
!         IDENTICAL FOR SOME PATHOLOGICAL BIDIAGONAL MATRICES.
!
!   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 ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( resid2(nsing), resid(n,nsing), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION BD*rightvec - leftvec*diag(singval(:nsing)),
!       WHERE leftvec AND rightvec ARE THE LEFT AND RIGHT SINGULAR VECTORS OF THE BIDIAGONAL MATRIX BD.
!
        if ( bd_is_upper ) then
!
            resid(:n,:nsing) = spread( diag(:n),        dim=2, ncopies=nsing )*rightvec                 + &
                               eoshift( spread(sup(:n), dim=2,ncopies=nsing)*rightvec, shift=1 )        - &
                               spread( singval(:nsing), dim=1, ncopies=n )*leftvec

        else
!
            resid(:n,:nsing) = spread( diag(:n),        dim=2, ncopies=nsing )*leftvec                   + &
                               eoshift( spread(sup(:n), dim=2,ncopies=nsing)*leftvec, shift=1 )          - &
                               spread( singval(:nsing), dim=1, ncopies=n )*rightvec
!
        end if
!
        resid2(:nsing) = norm( resid(:n,:nsing), dim=2_i4b )
!
        normbd = sum( diag(:n)*diag(:n) + sup(2_i4b:n)*sup(2_i4b:n) )
!
        err1 = maxval( resid2(:nsing) )/( normbd*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - leftvec**(t)*leftvec
!       WHERE leftvec ARE THE LEFT SINGULAR VECTORS OF THE BIDIAGONAL MATRIX bd.
!
        call unit_matrix( resid(:nsing,:nsing) )
!
        resid(:nsing,:nsing) = abs( resid(:nsing,:nsing) - matmul( transpose( leftvec ), leftvec ) )
        err2 = maxval(resid(:nsing,:nsing))/real(n,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - rightvec(t)*rightvec
!       WHERE rightvec ARE THE RIGHT SINGULAR VECTORS OF THE BIDIAGONAL MATRIX bd.
!
        call unit_matrix( resid(:nsing,:nsing) )
!
        resid(:nsing,:nsing) = abs( resid(:nsing,:nsing) - matmul( transpose( rightvec ), rightvec ) )
        err3 = maxval(resid(:nsing,:nsing))/real(n,stnd)
!
        err = max( err1, err2, err3 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( resid, resid2 )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( diag, sup, singval, leftvec, rightvec )
!
!   PRINT RESULTS.
!
    if ( err<=eps .and. .not.failure1 .and. .not.failure2 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', nsing, ' singular values and vectors of a ', &
       n, ' by ', n,' real bidiagonal matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_bd_deflate
! =============================
!
end program ex1_bd_deflate

ex1_bd_deflate2.F90

program ex1_bd_deflate2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine BD_DEFLATE2
!   in module SVD_Procedures.
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutines BD_CMP and BD_SINGVAL2 in module SVD_Procedures.
!                                                                              
! LATEST REVISION : 22/08/2019
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, lamch, bd_cmp, bd_singval2,    &
                         bd_deflate2, norm, unit_matrix, c1_5, 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
!
    integer(i4b), parameter :: prtunit=6, n=3000, m=3000, mn=min(m,n), nsing=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of bd_deflate2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, err3, eps, abstol, elapsed_time
    real(stnd), allocatable, dimension(:)   :: s, d, e, tauq, taup, tauo
    real(stnd), allocatable, dimension(:,:) :: a, a2, leftvec, rightvec, resid, rla
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: ns, max_qr_steps, mnthr
!
    logical(lgl) :: failure1, failure2, ortho, do_test, two_stage
!   
    character    :: sort='d'
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : PARTIAL SVD OF A REAL MATRIX USING A BISECTION ALGORITHM FOR SINGULAR VALUES
!               AND THE GODUNOV DEFLATION TECHNIQUE FOR SINGULAR VECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps    = fudge*epsilon( err )
    abstol = sqrt( lamch('S') )
    err    = zero
!
    do_test = true
!
!   DETERMINE CROSSOVER POINT FOR THE SVD WHEN REDUCING
!   a TO BIDIAGONAL FORM. IF max(n,m) EXCEEDS mnthr ,
!   A QR OR LQ FACTORIZATION IS USED FIRST TO REDUCE THE
!   n-BY-m MATRIX a TO A TRIANGULAR FORM.
!    
    mnthr = int( real( mn, stnd )*c1_5, i4b )
!
    two_stage = max( n, m )>=mnthr
!    two_stage = true
!    two_stage = false
!
!   ALLOCATE WORK ARRAYS.
!
    if ( two_stage ) then
        allocate( a(n,m), leftvec(n,nsing), rightvec(m,nsing), rla(mn,mn),    &
                  s(mn), d(mn), e(mn), tauq(mn), taup(mn), tauo(mn), stat=iok )
    else
        allocate( a(n,m), leftvec(n,nsing), rightvec(m,nsing),      &
                  s(mn), d(mn), e(mn), tauq(mn), taup(mn), stat=iok )
    end if
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM DATA MATRIX a.
!
    call random_number( a )
!
    if ( do_test ) then
!
        allocate( a2(n,m), resid(n,nsing), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       MAKE A COPY OF THE RANDOM DATA MATRIX.
!
        a2(:n,:m) = a(:n,:m)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL n-BY-m MATRIX a
!   IS WRITTEN
!
!                       a = U * S * V**(t)
!
!   WHERE S IS AN n-BY-m MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   min(m,n) DIAGONAL ELEMENTS, U IS AN n-BY-n ORTHOGONAL MATRIX, AND
!   V IS AN m-BY-m 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.
!
!   THIS PROGRAM ILLUSTRATES HOW TO COMPUTE ALL THE SINGULAR VALUES
!   OF a AND nsing LEFT AND RIGHT SINGULAR VECTORS OF a IN THREE STEPS:
!
    if ( two_stage ) then
!
!       STEP1A : REDUCE THE MATRIX a TO BIDIAGONAL FORM BY A TWO-STAGE ALGORITHM WITH SUBROUTINE bd_cmp.
!       THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!       THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM
!       ARE STORED IN mat, tauq, taup, rla AND tauo.
!
        call bd_cmp( a(:n,:m), d(:mn), e(:mn), tauq(:mn), taup(:mn), rla(:mn,:mn), tauo=tauo(:mn) )
!        call bd_cmp( a(:n,:m), d(:mn), e(:mn), tauq(:mn), taup(:mn), rla(:mn,:mn) )
!
    else
!
!       STEP1B : REDUCE THE MATRIX a TO BIDIAGONAL FORM WITHOUT A QR OR LQ FACTORIZATION WITH SUBROUTINE bd_cmp.
!       THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!       THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM
!       ARE STORED IN mat, tauq, taup.
!
        call bd_cmp( a(:n,:m), d(:mn), e(:mn), tauq(:mn), taup(:mn) )
!
    end if
!
!   STEP2 : COMPUTE SINGULAR VALUES OF THE BIDIAGONAL MATRIX (WHICH ARE ALSO THE
!   SINGULAR VALUES OF a) WITH SUBROUTINE bd_singval2 TO HIGH RELATIVE PRECISION.
!   THE SINGULAR VALUES ARE STORED IN s IN DECREASING ORDER (IF sort='d').
!
!   THE OPTIONAL ARGUMENT abstol OF bd_singval2 MAY BE USED TO INDICATE THE REQUIRED
!   PRECISION FOR THE SINGULAR VALUES. A SINGULAR VALUE IS CONSIDERED TO BE LOCATED
!   IF IT HAS BEEN DETERMINED TO LIE IN AN INTERVAL WHOSE WIDTH IS EQUAL OR LESS
!   THAN abstol. SINGULAR VALUES WILL BE COMPUTED MOST ACCURATELY WHEN abstol IS SET
!   TO THE SQUARE ROOT OF THE UNDERFLOW THRESHOLD (EG sqrt(LAMCH('S')) ).
!
    call bd_singval2( d(:mn), e(:mn), ns, s(:mn), failure=failure1, sort=sort, abstol=abstol )
!
!   STEP3 : COMPUTE nsing LEFT AND RIGHT SINGULAR VECTORS OF a BY A DEFLATION TECHNIQUE
!   APPLIED TO THE INTERMEDIATE BIDIAGONAL MATRIX AND BACK-TRANSFORMATION WITH SUBROUTINE
!   bd_deflate2.
!
!   ON ENTRY OF bd_deflate2: PARAMETER s CONTAINS SELECTED SINGULAR VALUES OF THE BIDIAGONAL
!   MATRIX (OR OF a). THE SINGULAR VALUES MUST BE GIVEN IN DECREASING ORDER.
!
!   OPTIONAL PARAMETER ortho DETERMINES IF DEFLATION IS APPLIED SEQUENTIALLY TO ALL
!   COMPUTED SINGULAR VECTORS (ortho=true) OR ONLY IN EACH CLUSTER OF SINGULAR VALUES
!   (ortho=false). IN THE LATTER CASE, ORTHOGONALITY OF THE SINGULAR VECTORS MAY BE
!   SLIGHTLY DEGRADED, BUT COMPUTATIONS WILL BE MUCH FASTER.
!
    ortho = false
    max_qr_steps = 4_i4b
!
    if ( two_stage ) then
!
        call bd_deflate2( a(:n,:m), tauq(:mn), taup(:mn), rla(:mn,:mn), d(:mn), e(:mn), s(:nsing),    &
                          leftvec(:n,:nsing), rightvec(:m,:nsing), failure=failure2, tauo=tauo(:mn),  &
                          ortho=ortho, max_qr_steps=max_qr_steps                       )
!
!        call bd_deflate2( a(:n,:m), tauq(:mn), taup(:mn), rla(:mn,:mn), d(:mn), e(:mn), s(:nsing),   &
!                          leftvec(:n,:nsing), rightvec(:m,:nsing), failure=failure2,                 &
!                          ortho=ortho, max_qr_steps=max_qr_steps                       )
!
    else
!
        call bd_deflate2( a(:n,:m), tauq(:mn), taup(:mn), d(:mn), e(:mn), s(:nsing),   &
                          leftvec(:n,:nsing), rightvec(:m,:nsing), failure=failure2,   &
                          ortho=ortho, max_qr_steps=max_qr_steps                       )
!
    end if
!
!   ON EXIT OF bd_deflate2 :
!
!       failure= false :  INDICATES SUCCESSFUL EXIT.
!       failure= true  :  INDICATES THAT MAXIMUM ACCURACY WAS NOT OBTAIN IN THE
!                         DEFLATION ALGORITHM.

!       leftvec AND rightvec CONTAIN, RESPECTIVELY, THE FIRST nsing LEFT AND RIGHT
!       SINGULAR VECTORS OF a .
!
!   bd_deflate2 MAY FAIL IF SOME THE SINGULAR VALUES SPECIFIED IN PARAMETER s ARE NEARLY
!   IDENTICAL FOR SOME PATHOLOGICAL MATRICES.
!
!   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 ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*V(:m,:nsing) - U(:n,:nsing)*S(:nsing,:nsing),
!       WHERE leftvec AND rightvec ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a.
!
        resid(:n,:nsing) = matmul(a2,rightvec) - leftvec*spread(s(:nsing),dim=1,ncopies=n)
        a2(:nsing,1_i4b) = norm( resid(:n,:nsing), dim=2_i4b )
!
        err1 = maxval( a2(:nsing,1_i4b) )/ ( sum( abs(s(:mn)) )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U(:n,:nsing)**(t)*U(:n,:nsing).
!
        call unit_matrix( a2(:nsing,:nsing) )
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(leftvec), leftvec ) )
!
        err2 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - V(:m,:nsing)**(t)*V(:m,:nsing).
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(rightvec), rightvec ) )
!
        err3 = maxval( resid(:nsing,:nsing) )/real(m,stnd)
!
        err = max( err1, err2, err3 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a2, resid )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( two_stage ) then
!
        deallocate( a, leftvec, rightvec, rla, s, d, e, tauq, taup, tauo )
!
    else
!
        deallocate( a, leftvec, rightvec, s, d, e, tauq, taup )
!
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. .not.failure1 .and. .not.failure2 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing all singular values and ', nsing, ' singular vectors of a ', &
       n, ' by ', m,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_bd_deflate2
! ==============================
!
end program ex1_bd_deflate2

ex1_bd_deflate2_bis.F90

program ex1_bd_deflate2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine BD_DEFLATE2
!   in module SVD_Procedures.
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutines BD_CMP and BD_SINGVAL in module SVD_Procedures.
!                                                                              
! LATEST REVISION : 22/08/2019
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, lamch, bd_cmp, bd_singval,      &
                         bd_deflate2, norm, unit_matrix, c1_5, 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
!
    integer(i4b), parameter :: prtunit=6, n=3000, m=3000, mn=min(m,n), nsing=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of bd_deflate2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, err3, eps, abstol, elapsed_time
    real(stnd), allocatable, dimension(:)   :: s, d, e, tauq, taup, tauo
    real(stnd), allocatable, dimension(:,:) :: a, a2, leftvec, rightvec, resid, rla
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: ns, max_qr_steps, mnthr
!
    logical(lgl) :: failure1, failure2, ortho, do_test, two_stage
!   
    character    :: sort='d'
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : PARTIAL SVD OF A REAL MATRIX USING A BISECTION ALGORITHM FOR SINGULAR VALUES
!               AND THE GODUNOV DEFLATION TECHNIQUE FOR SINGULAR VECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps    = fudge*epsilon( err )
    abstol = sqrt( lamch('S') )
    err    = zero
!
    do_test = true
!
!   DETERMINE CROSSOVER POINT FOR THE SVD WHEN REDUCING
!   a TO BIDIAGONAL FORM. IF max(n,m) EXCEEDS mnthr ,
!   A QR OR LQ FACTORIZATION IS USED FIRST TO REDUCE THE
!   n-BY-m MATRIX a TO A TRIANGULAR FORM.
!    
    mnthr = int( real( mn, stnd )*c1_5, i4b )
!
    two_stage = max( n, m )>=mnthr
!    two_stage = true
!    two_stage = false
!
!   ALLOCATE WORK ARRAYS.
!
    if ( two_stage ) then
        allocate( a(n,m), leftvec(n,nsing), rightvec(m,nsing), rla(mn,mn),    &
                  s(mn), d(mn), e(mn), tauq(mn), taup(mn), tauo(mn), stat=iok )
    else
        allocate( a(n,m), leftvec(n,nsing), rightvec(m,nsing),      &
                  s(mn), d(mn), e(mn), tauq(mn), taup(mn), stat=iok )
    end if
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM DATA MATRIX a.
!
    call random_number( a )
!
    if ( do_test ) then
!
        allocate( a2(n,m), resid(n,nsing), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       MAKE A COPY OF THE RANDOM DATA MATRIX.
!
        a2(:n,:m) = a(:n,:m)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL n-BY-m MATRIX a
!   IS WRITTEN
!
!                       a = U * S * V**(t)
!
!   WHERE S IS AN n-BY-m MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   min(m,n) DIAGONAL ELEMENTS, U IS AN n-BY-n ORTHOGONAL MATRIX, AND
!   V IS AN m-BY-m 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.
!
!   THIS PROGRAM ILLUSTRATES HOW TO COMPUTE ALL THE SINGULAR VALUES
!   OF a AND nsing LEFT AND RIGHT SINGULAR VECTORS OF a IN THREE STEPS:
!
    if ( two_stage ) then
!
!       STEP1A : REDUCE THE MATRIX a TO BIDIAGONAL FORM BY A TWO-STAGE ALGORITHM WITH SUBROUTINE bd_cmp.
!       THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!       THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM
!       ARE STORED IN mat, tauq, taup, rla AND tauo.
!
        call bd_cmp( a(:n,:m), d(:mn), e(:mn), tauq(:mn), taup(:mn), rla(:mn,:mn), tauo=tauo(:mn) )
!        call bd_cmp( a(:n,:m), d(:mn), e(:mn), tauq(:mn), taup(:mn), rla(:mn,:mn) )
!
    else
!
!       STEP1B : REDUCE THE MATRIX a TO BIDIAGONAL FORM WITHOUT A QR OR LQ FACTORIZATION WITH SUBROUTINE bd_cmp.
!       THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!       THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM
!       ARE STORED IN mat, tauq, taup.
!
        call bd_cmp( a(:n,:m), d(:mn), e(:mn), tauq(:mn), taup(:mn) )
!
    end if
!
!   STEP2 : COMPUTE SINGULAR VALUES OF THE BIDIAGONAL MATRIX (WHICH ARE ALSO THE
!   SINGULAR VALUES OF a) WITH SUBROUTINE bd_singval TO HIGH RELATIVE PRECISION.
!   THE SINGULAR VALUES ARE STORED IN s IN DECREASING ORDER (IF sort='d').
!
!   THE OPTIONAL ARGUMENT abstol OF bd_singval MAY BE USED TO INDICATE THE REQUIRED
!   PRECISION FOR THE SINGULAR VALUES. A SINGULAR VALUE IS CONSIDERED TO BE LOCATED
!   IF IT HAS BEEN DETERMINED TO LIE IN AN INTERVAL WHOSE WIDTH IS EQUAL OR LESS
!   THAN abstol. SINGULAR VALUES WILL BE COMPUTED MOST ACCURATELY WHEN abstol IS SET
!   TO THE SQUARE ROOT OF THE UNDERFLOW THRESHOLD (EG sqrt(LAMCH('S')) ).
!
    call bd_singval( d(:mn), e(:mn), ns, s(:mn), failure=failure1, sort=sort, abstol=abstol )
!
!   STEP3 : COMPUTE nsing LEFT AND RIGHT SINGULAR VECTORS OF a BY A DEFLATION TECHNIQUE
!   APPLIED TO THE INTERMEDIATE BIDIAGONAL MATRIX AND BACK-TRANSFORMATION WITH SUBROUTINE
!   bd_deflate2.
!
!   ON ENTRY OF bd_deflate2: PARAMETER s CONTAINS SELECTED SINGULAR VALUES OF THE BIDIAGONAL
!   MATRIX (OR OF a). THE SINGULAR VALUES MUST BE GIVEN IN DECREASING ORDER.
!
!   OPTIONAL PARAMETER ortho DETERMINES IF DEFLATION IS APPLIED SEQUENTIALLY TO ALL
!   COMPUTED SINGULAR VECTORS (ortho=true) OR ONLY IN EACH CLUSTER OF SINGULAR VALUES
!   (ortho=false). IN THE LATTER CASE, ORTHOGONALITY OF THE SINGULAR VECTORS MAY BE
!   SLIGHTLY DEGRADED, BUT COMPUTATIONS WILL BE MUCH FASTER.
!
    ortho = false
    max_qr_steps = 4_i4b
!
    if ( two_stage ) then
!
        call bd_deflate2( a(:n,:m), tauq(:mn), taup(:mn), rla(:mn,:mn), d(:mn), e(:mn), s(:nsing),    &
                          leftvec(:n,:nsing), rightvec(:m,:nsing), failure=failure2, tauo=tauo(:mn),  &
                          ortho=ortho, max_qr_steps=max_qr_steps                       )
!
!        call bd_deflate2( a(:n,:m), tauq(:mn), taup(:mn), rla(:mn,:mn), d(:mn), e(:mn), s(:nsing),   &
!                          leftvec(:n,:nsing), rightvec(:m,:nsing), failure=failure2,                 &
!                          ortho=ortho, max_qr_steps=max_qr_steps                       )
!
    else
!
        call bd_deflate2( a(:n,:m), tauq(:mn), taup(:mn), d(:mn), e(:mn), s(:nsing),   &
                          leftvec(:n,:nsing), rightvec(:m,:nsing), failure=failure2,   &
                          ortho=ortho, max_qr_steps=max_qr_steps                       )
!
    end if
!
!   ON EXIT OF bd_deflate2 :
!
!       failure= false :  INDICATES SUCCESSFUL EXIT.
!       failure= true  :  INDICATES THAT MAXIMUM ACCURACY WAS NOT OBTAIN IN THE
!                         DEFLATION ALGORITHM.

!       leftvec AND rightvec CONTAIN, RESPECTIVELY, THE FIRST nsing LEFT AND RIGHT
!       SINGULAR VECTORS OF a .
!
!   bd_deflate2 MAY FAIL IF SOME THE SINGULAR VALUES SPECIFIED IN PARAMETER s ARE NEARLY
!   IDENTICAL FOR SOME PATHOLOGICAL MATRICES.
!
!   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 ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*V(:m,:nsing) - U(:n,:nsing)*S(:nsing,:nsing),
!       WHERE leftvec AND rightvec ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a.
!
        resid(:n,:nsing) = matmul(a2,rightvec) - leftvec*spread(s(:nsing),dim=1,ncopies=n)
        a2(:nsing,1_i4b) = norm( resid(:n,:nsing), dim=2_i4b )
!
        err1 = maxval( a2(:nsing,1_i4b) )/ ( sum( abs(s(:mn)) )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U(:n,:nsing)**(t)*U(:n,:nsing).
!
        call unit_matrix( a2(:nsing,:nsing) )
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(leftvec), leftvec ) )
!
        err2 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - V(:m,:nsing)**(t)*V(:m,:nsing).
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(rightvec), rightvec ) )
!
        err3 = maxval( resid(:nsing,:nsing) )/real(m,stnd)
!
        err = max( err1, err2, err3 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a2, resid )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( two_stage ) then
!
        deallocate( a, leftvec, rightvec, rla, s, d, e, tauq, taup, tauo )
!
    else
!
        deallocate( a, leftvec, rightvec, s, d, e, tauq, taup )
!
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. .not.failure1 .and. .not.failure2 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing all singular values and ', nsing, ' singular vectors of a ', &
       n, ' by ', m,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_bd_deflate2
! ==============================
!
end program ex1_bd_deflate2

ex1_bd_deflate2_ter.F90

program ex1_bd_deflate2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine BD_DEFLATE2
!   in module SVD_Procedures .
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine SVD_CMP in module SVD_Procedures.
!                                                                              
! LATEST REVISION : 27/05/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, lamch, svd_cmp,            &
                         bd_deflate2, norm, unit_matrix, 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
!
    integer(i4b), parameter :: prtunit=6, n=3000, m=3000, mn=min(m,n), nsing=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of bd_deflate2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, err3, eps, abstol, elapsed_time
    real(stnd), allocatable, dimension(:)   :: s, d, e, tauq, taup
    real(stnd), allocatable, dimension(:,:) :: a, a2, leftvec, rightvec, resid
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: ns, max_qr_steps
!
    logical(lgl) :: failure1, failure2, ortho, do_test
!   
    character    :: sort='d'
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : PARTIAL SVD OF A REAL MATRIX USING THE BIDIAGONAL QR ALGORITHM FOR SINGULAR VALUES
!               AND THE GODUNOV DEFLATION TECHNIQUE FOR SINGULAR VECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps    = fudge*epsilon( err )
    abstol = sqrt( lamch('S') )
    err    = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,m), leftvec(n,nsing), rightvec(m,nsing),      &
              s(mn), d(mn), e(mn), tauq(mn), taup(mn), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM DATA MATRIX a.
!
    call random_number( a )
!
    if ( do_test ) then
!
        allocate( a2(n,m), resid(n,nsing), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       MAKE A COPY OF THE RANDOM DATA MATRIX.
!
        a2(:n,:m) = a(:n,:m)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL n-BY-m MATRIX a
!   IS WRITTEN
!
!                       a = U * S * V**(t)
!
!   WHERE S IS AN n-BY-m MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   min(m,n) DIAGONAL ELEMENTS, U IS AN n-BY-n ORTHOGONAL MATRIX, AND
!   V IS AN m-BY-m 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.
!
!   THIS PROGRAM ILLUSTRATES HOW TO COMPUTE ALL THE SINGULAR VALUES OF a AND
!   ONLY nsing LEFT AND RIGHT SINGULAR VECTORS OF a (EG A PARTIAL SVD DECOMPOSITION
!   OF a) IN TWO STEPS:
!
!   STEP1 : COMPUTE ALL SINGULAR VALUES OF a AND STORE INTERMEDIATE RESULTS WITH SUBROUTINE svd_cmp.
!
    call svd_cmp( a(:n,:m), s(:mn), failure=failure1, sort=sort, d=d(:mn),   &
                  e=e(:mn), tauq=tauq(:mn), taup=taup(:mn)  )
!
!   ON EXIT OF svd_cmp :
!
!         failure= false :  INDICATES SUCCESSFUL EXIT
!         failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                           THAT FULL ACCURACY WAS NOT ATTAINED IN THE BIDIAGONAL
!                           SVD OF AN INTERMEDIATE BIDIAGONAL FORM BD OF a.
!
!         s IS OVERWRITTEN WITH THE SINGULAR VALUES OF a.
!
!         IF SORT = 'a' OR 'A', THE SINGULAR VALUES ARE SORTED INTO ASCENDING ORDER.
!         IF SORT = 'd' OR 'D', THE SINGULAR VALUES ARE SORTED INTO DESCENDING ORDER.
!
!   HERE, SORT = 'd' IS USED. THIS IS REQUIRED FOR THE USE OF bd_inviter2.
!                
!   IF THE PARAMETER v IS ABSENT IN THE CALL OF svd_cmp, svd_cmp COMPUTES ONLY THE            
!   SINGULAR VALUES OF a AND, OPTIONALLY, STORES THE INTERMEDIATE BIDIAGONAL FORM
!   OF a AND THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM.
!
!   THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN THE OPTIONAL ARGUMENTS d AND e.
!   THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM d AND e ARE STORED 
!   IN mat, tauq, taup, WHEN THE OPTIONAL ARGUMENTS tauq AND taup ARE PRESENT.
!
!   STEP2 : COMPUTE nsing LEFT AND RIGHT SINGULAR VECTORS OF a BY A DEFLATION TECHNIQUE
!   APPLIED TO THE INTERMEDIATE BIDIAGONAL MATRIX AND BACK-TRANSFORMATION WITH SUBROUTINE
!   bd_deflate2.
!
!   ON ENTRY OF bd_deflate2: PARAMETER s CONTAINS SELECTED SINGULAR VALUES OF THE BIDIAGONAL
!   MATRIX (OR OF a). THE SINGULAR VALUES MUST BE GIVEN IN DECREASING ORDER.
!
!   OPTIONAL PARAMETER ortho DETERMINES IF DEFLATION IS APPLIED SEQUENTIALLY TO ALL
!   COMPUTED SINGULAR VECTORS (ortho=true) OR ONLY IN EACH CLUSTER OF SINGULAR VALUES
!   (ortho=false). IN THE LATTER CASE, ORTHOGONALITY OF THE SINGULAR VECTORS MAY BE
!   SLIGHTLY DEGRADED, BUT COMPUTATIONS WILL BE MUCH FASTER.
!
    ortho = false
    max_qr_steps = 4_i4b
!
    call bd_deflate2( a(:n,:m), tauq(:mn), taup(:mn), d(:mn), e(:mn), s(:nsing),   &
                      leftvec(:n,:nsing), rightvec(:m,:nsing), failure=failure2,   &
                      ortho=ortho, max_qr_steps=max_qr_steps                       )
!
!   ON EXIT OF bd_deflate2 :
!
!       failure= false :  INDICATES SUCCESSFUL EXIT.
!       failure= true  :  INDICATES THAT MAXIMUM ACCURACY WAS NOT OBTAIN IN THE
!                         DEFLATION ALGORITHM.

!       leftvec AND rightvec CONTAIN, RESPECTIVELY, THE FIRST nsing LEFT AND RIGHT
!       SINGULAR VECTORS OF a .
!
!   bd_deflate2 MAY FAIL IF SOME THE SINGULAR VALUES SPECIFIED IN PARAMETER s ARE NEARLY
!   IDENTICAL FOR SOME PATHOLOGICAL MATRICES.
!
!   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 ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*V(:m,:nsing) - U(:n,:nsing)*S(:nsing,:nsing),
!       WHERE leftvec AND rightvec ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a.
!
        resid(:n,:nsing) = matmul(a2,rightvec) - leftvec*spread(s(:nsing),dim=1,ncopies=n)
        a2(:nsing,1_i4b) = norm( resid(:n,:nsing), dim=2_i4b )
!
        err1 = maxval( a2(:nsing,1_i4b) )/ ( sum( abs(s(:mn)) )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U(:n,:nsing)**(t)*U(:n,:nsing).
!
        call unit_matrix( a2(:nsing,:nsing) )
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(leftvec), leftvec ) )
!
        err2 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - V(:m,:nsing)**(t)*V(:m,:nsing).
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(rightvec), rightvec ) )
!
        err3 = maxval( resid(:nsing,:nsing) )/real(m,stnd)
!
        err = max( err1, err2, err3 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a2, resid )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, leftvec, rightvec, s, d, e, tauq, taup )
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. .not.failure1 .and. .not.failure2 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing all singular values and ', nsing, ' singular vectors of a ', &
       n, ' by ', m,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_bd_deflate2
! ==============================
!
end program ex1_bd_deflate2

ex1_bd_inviter.F90

program ex1_bd_inviter
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine BD_INVITER
!   in module SVD_Procedures .
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine BD_SVD in module SVD_Procedures.
!
! LATEST REVISION : 27/05/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, half, c100, bd_inviter, bd_svd, &
                         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
!
    integer(i4b), parameter :: prtunit=6, n=3000, nsing=3000
!   
    real(stnd), parameter  :: fudge=c100
!
    character(len=*), parameter :: name_proc='Example 1 of bd_inviter'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err3, err, eps, elapsed_time
    real(stnd), allocatable, dimension(:)   :: diag, sup, sup2, singval
    real(stnd), allocatable, dimension(:,:) :: id, resid, leftvec, rightvec
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: maxiter=2
!
    logical(lgl) :: failure1, failure2, bd_is_upper, do_test
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : PARTIAL SVD OF A REAL n-BY-n BIDIAGONAL MATRIX BD USING THE GOLUB-REINSCH ALGORITHM
!               FOR ALL SINGULAR VALUES AND THE INVERSE ITERATION TECHNIQUE FOR SELECTED SINGULAR
!               VECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( diag(n), sup(n), sup2(n), singval(n),           &
              leftvec(n,nsing), rightvec(n,nsing), stat=iok   )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE AN UPPER BIDIAGONAL MATRIX bd.
!   THE DIAGONAL ELEMENTS ARE STORED IN diag .
!   THE OFF-DIAGONAL ELEMENTS ARE STORED IN sup .
!
    bd_is_upper   = true
!
    sup(1_i4b)   = zero
!
!    diag(:n)     = half
!    sup(2_i4b:n) = half
!
    call random_number( diag(:n) )
    call random_number( sup(2_i4b:n) )
!
!    diag(1_i4b)   = 1._stnd
!    diag(2_i4b:n) = 200._stnd*epsilon( err )
!    sup(2_i4b:n)  = 200._stnd*epsilon( err )
!
!   MAKE A COPY OF THE BIDIAGONAL MATRIX.
!
    singval(:n) = diag(:n)
    sup2(:n)    = sup(:n)
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   COMPUTE ALL SINGULAR VALUES OF THE BIDIAGONAL MATRIX BD .
!   THE SINGULAR VALUES ARE STORED IN singval IN DECREASING ORDER (sort='d').
!
    call bd_svd( bd_is_upper, singval(:n), sup2(:n), failure=failure1, sort=sort  )
!
!   ON EXIT OF bd_svd :
!
!         failure= false :  INDICATES SUCCESSFUL EXIT.
!         failure= true  :  INDICATES THAT MAXIMUM ACCURACY WAS NOT OBTAIN IN THE BIDIAGONAL QR ALGORITHM.
!
!   COMPUTE THE FIRST nsing SINGULAR VECTORS OF BD BY maxiter INVERSE ITERATIONS WITH
!   SUBROUTINE bd_inviter. THE SINGULAR VALUES MUST BE GIVEN IN DECREASING ORDER.
!
    call bd_inviter( bd_is_upper, diag(:n), sup(:n), singval(:nsing), leftvec(:n,:nsing), rightvec(:n,:nsing),  &
                     failure=failure2, maxiter=maxiter )
!
!   ON EXIT OF bd_inviter :
!
!         failure= false :  INDICATES SUCCESSFUL EXIT.
!         failure= true  :  INDICATES THAT MAXIMUM ACCURACY WAS NOT OBTAIN IN THE ALGORITHM.
!
!         leftvec AND rightvec CONTAIN, RESPECTIVELY, THE nsing LEFT AND RIGHT SINGULAR
!         VECTORS OF THE BIDIAGONAL MATRIX BD ASSOCIATED WITH THE SINGULAR VALUES singval(:nsing).
!
!   bd_inviter MAY FAIL IF SOME THE SINGULAR VALUES SPECIFIED IN PARAMETER singval ARE NEARLY
!   IDENTICAL FOR SOME PATHOLOGICAL BIDIAGONAL MATRICES.
!
!   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 ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( id(nsing,nsing), resid(n,nsing), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION bd*rightvec - leftvec*diag(singval(:nsing)),
!       WHERE leftvec AND rightvec ARE THE LEFT AND RIGHT SINGULAR VECTORS OF THE BIDIAGONAL MATRIX bd.
!
        if ( bd_is_upper ) then
!
            resid(:n,:nsing) = spread( diag(:n),        dim=2, ncopies=nsing )*rightvec                 + &
                               eoshift( spread(sup(:n), dim=2,ncopies=nsing)*rightvec, shift=1 )        - &
                               spread( singval(:nsing), dim=1, ncopies=n )*leftvec

        else
!
            resid(:n,:nsing) = spread( diag(:n),        dim=2, ncopies=nsing )*leftvec                   + &
                               eoshift( spread(sup(:n), dim=2,ncopies=nsing)*leftvec, shift=1 )          - &
                               spread( singval(:nsing), dim=1, ncopies=n )*rightvec
!
        end if
!
        id(:nsing,1_i4b) = norm( resid(:n,:nsing), dim=2_i4b )
        err1 = maxval( id(:nsing,1_i4b) )/( sum( singval(:nsing) )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - leftvec**(t)*leftvec
!       WHERE leftvec ARE THE LEFT SINGULAR VECTORS OF THE BIDIAGONAL MATRIX bd.
!
        call unit_matrix( id )
!
        resid(:nsing,:nsing) = abs( id - matmul( transpose( leftvec ), leftvec ) )
        err2 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - rightvec**(t)*rightvec
!       WHERE rightvec ARE THE RIGHT SINGULAR VECTORS OF THE BIDIAGONAL MATRIX bd.
!
        resid(:nsing,:nsing) = abs( id - matmul( transpose( rightvec ), rightvec ) )
        err3 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
        err = max( err1, err2, err3 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( id, resid )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( diag, sup, sup2, singval, leftvec, rightvec )
!
    if ( err<=eps .and. .not.failure1 .and. .not.failure2 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing all singular values and ', nsing, ' singular vectors of a ', &
       n, ' by ', n,' real bidiagonal matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_bd_inviter
! =============================
!
end program ex1_bd_inviter

ex1_bd_inviter2.F90

program ex1_bd_inviter2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine BD_INVITER2
!   in module SVD_Procedures .
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutines BD_CMP and BD_SINGVAL2 in module SVD_Procedures.
!                                                                              
! LATEST REVISION : 22/08/2019
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, zero, true, false, lamch, bd_cmp, bd_inviter2, bd_singval2, &
                         norm, unit_matrix, c1_5, 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
!
    integer(i4b), parameter :: prtunit=6, n=3000, m=3000, mn=min(m,n), nsing=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of bd_inviter2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, err3, eps, abstol, elapsed_time
    real(stnd), allocatable, dimension(:)   :: s, d, e, tauq, taup, tauo
    real(stnd), allocatable, dimension(:,:) :: a, a2, leftvec, rightvec, resid, rla
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: ns, maxiter=2, mnthr
!
    logical(lgl) :: failure1, failure2, do_test, two_stage
!   
    character    :: sort='d'
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : ALL SINGULAR VALUES AND nsing SINGULAR VECTORS OF A n-BY-m REAL MATRIX
!               USING THE BIDIAGONAL QR ALGORITHM FOR THE SINGULAR VALUES AND THE INVERSE
!               ITERATION METHOD FOR THE SINGULAR VECTORS (eg PARTIAL SVD DECOMPOSITION).
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps    = fudge*epsilon( err )
    abstol = sqrt( lamch('S') )
    err    = zero
!
    do_test = true
!
!   DETERMINE CROSSOVER POINT FOR THE SVD WHEN REDUCING
!   a TO BIDIAGONAL FORM. IF max(n,m) EXCEEDS mnthr ,
!   A QR OR LQ FACTORIZATION IS USED FIRST TO REDUCE THE
!   n-BY-m MATRIX a TO A TRIANGULAR FORM.
!    
    mnthr = int( real( mn, stnd )*c1_5, i4b )
!
    two_stage = max( n, m )>=mnthr
!    two_stage = true
!    two_stage = false
!
!   ALLOCATE WORK ARRAYS.
!
    if ( two_stage ) then
        allocate( a(n,m), leftvec(n,nsing), rightvec(m,nsing), rla(mn,mn),    &
                  s(mn), d(mn), e(mn), tauq(mn), taup(mn), tauo(mn), stat=iok )
    else
        allocate( a(n,m), leftvec(n,nsing), rightvec(m,nsing),      &
                  s(mn), d(mn), e(mn), tauq(mn), taup(mn), stat=iok )
    end if
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-BY-m RANDOM REAL MATRIX a.
!
    call random_number( a )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( a2(n,m), resid(n,nsing), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       MAKE A COPY OF THE RANDOM DATA MATRIX .
!
        a2(:n,:m) = a(:n,:m)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL n-BY-m MATRIX a
!   IS WRITTEN
!
!                       a = U * S * V**(t)
!
!   WHERE S IS AN n-BY-m MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   min(m,n) DIAGONAL ELEMENTS, U IS AN n-BY-n ORTHOGONAL MATRIX, AND
!   V IS AN m-BY-m 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.
!
!   THIS PROGRAM ILLUSTRATES HOW TO COMPUTE ALL THE SINGULAR VALUES OF a AND
!   ONLY nsing LEFT AND RIGHT SINGULAR VECTORS OF a (EG A PARTIAL SVD DECOMPOSITION
!   OF a) IN THREE STEPS:
!
    if ( two_stage ) then
!
!       STEP1A : REDUCE THE MATRIX a TO BIDIAGONAL FORM BY A TWO-STAGE ALGORITHM WITH SUBROUTINE bd_cmp.
!       THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!       THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM
!       ARE STORED IN mat, tauq, taup, rla AND tauo.
!
        call bd_cmp( a(:n,:m), d(:mn), e(:mn), tauq(:mn), taup(:mn), rla(:mn,:mn), tauo=tauo(:mn) )
!        call bd_cmp( a(:n,:m), d(:mn), e(:mn), tauq(:mn), taup(:mn), rla(:mn,:mn) )
!
    else
!
!       STEP1B : REDUCE THE MATRIX a TO BIDIAGONAL FORM WITHOUT A QR OR LQ FACTORIZATION WITH SUBROUTINE bd_cmp.
!       THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!       THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM
!       ARE STORED IN mat, tauq, taup.
!
        call bd_cmp( a(:n,:m), d(:mn), e(:mn), tauq(:mn), taup(:mn) )
!
    end if
!
!   STEP2 : COMPUTE SINGULAR VALUES OF THE BIDIAGONAL MATRIX (WHICH ARE ALSO THE
!   SINGULAR VALUES OF a) WITH SUBROUTINE bd_singval2 TO HIGH RELATIVE PRECISION.
!   THE SINGULAR VALUES ARE STORED IN s IN DECREASING ORDER (IF sort='d').
!
!   THE OPTIONAL ARGUMENT abstol OF bd_singval2 MAY BE USED TO INDICATE THE REQUIRED
!   PRECISION FOR THE SINGULAR VALUES. A SINGULAR VALUE IS CONSIDERED TO BE LOCATED
!   IF IT HAS BEEN DETERMINED TO LIE IN AN INTERVAL WHOSE WIDTH IS EQUAL OR LESS
!   THAN abstol. SINGULAR VALUES WILL BE COMPUTED MOST ACCURATELY WHEN abstol IS SET
!   TO THE SQUARE ROOT OF THE UNDERFLOW THRESHOLD (EG sqrt(LAMCH('S')) ).
!
    call bd_singval2( d(:mn), e(:mn), ns, s(:mn), failure=failure1, sort=sort, abstol=abstol )
!
!   STEP3 : COMPUTE THE FIRST nsing LEFT AND RIGHT SINGULAR VECTORS OF a BY maxiter
!   INVERSE ITERATIONS ON THE INTERMEDIATE BIDIAGONAL MATRIX AND BACK-TRANSFORMATION
!   WITH SUBROUTINE bd_inviter2 .
!
!   ON ENTRY OF bd_inviter2, PARAMETER s CONTAINS SELECTED SINGULAR VALUES OF THE BIDIAGONAL MATRIX d_e (OR a).
!   THE SINGULAR VALUES MUST BE GIVEN IN DECREASING ORDER.
!
    if ( two_stage ) then
!
        call bd_inviter2( a, tauq, taup, rla, d, e, s(:nsing), leftvec, rightvec, failure=failure2, tauo=tauo, maxiter=maxiter )
!        call bd_inviter2( a, tauq, taup, rla, d, e, s(:nsing), leftvec, rightvec, failure=failure2, maxiter=maxiter )
!
    else
!
        call bd_inviter2( a, tauq, taup, d, e, s(:nsing), leftvec, rightvec, failure=failure2, maxiter=maxiter )
!
    end if
!
!   ON EXIT OF bd_inviter2 :
!
!         failure= false :  INDICATES SUCCESSFUL EXIT.
!         failure= true  :  INDICATES THAT THE ALGORITHM FAILS TO CONVERGE FOR SOME SINGULAR VECTORS.
!
!   THE SINGULAR VECTORS OF THE BIDIAGONAL FORM ARE COMPUTED USING maxiter INVERSE ITERATIONS
!   FOR ALL THE SINGULAR VALUES AT ONE STEP. THE SINGULAR VECTORS OF ARE THEN ORTHOGONALIZED BY 
!   THE MODIFIED GRAM-SCHMIDT ALGORITHM IF NECESSARY. THE SINGULAR VECTORS OF a ARE FINALLY COMPUTED 
!   BY BACK TRANSFORMATIONS. ON EXIT, leftvec AND rightvec CONTAIN THE FIRST nsing LEFT AND RIGHT
!   SINGULAR VECTORS OF a, RESPECTIVELY.
!
!   NOTE THAT bd_inviter2 MAY FAIL IF SOME THE SINGULAR VALUES SPECIFIED IN PARAMETER s ARE NEARLY
!   IDENTICAL FOR SOME PATHOLOGICAL MATRICES.
!
!   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 ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*V(:m,:nsing) - U(:n,:nsing)*S(:nsing,:nsing),
!       WHERE leftvec AND rightvec ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a.
!
        resid(:n,:nsing) = matmul(a2,rightvec) - leftvec*spread(s(:nsing),dim=1,ncopies=n)
        a2(:nsing,1_i4b) = norm( resid(:n,:nsing), dim=2_i4b )
        err1 = maxval( a2(:nsing,1_i4b) )/( sum( abs(s(:mn)) )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U(:n,:nsing)**(t)*U(:n,:nsing).
!
        call unit_matrix( a2(:nsing,:nsing) )
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(leftvec), leftvec ) )
        err2 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - V(:m,:nsing)**(t)*V(:m,:nsing).
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(rightvec), rightvec ) )
        err3 = maxval( resid(:nsing,:nsing) )/real(m,stnd)
!
        err = max( err1, err2, err3 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a2, resid )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( two_stage ) then
!
        deallocate( a, leftvec, rightvec, rla, s, d, e, tauq, taup, tauo )
!
    else
!
        deallocate( a, leftvec, rightvec, s, d, e, tauq, taup )
!
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. .not.failure1 .and. .not.failure2 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing all singular values and ', nsing, ' singular vectors of a ', &
       n, ' by ', m,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_bd_inviter2
! ==============================
!
end program ex1_bd_inviter2

ex1_bd_inviter2_bis.F90

program ex1_bd_inviter2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine BD_INVITER2
!   in module SVD_Procedures .
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutines BD_CMP and BD_SINGVAL in module SVD_Procedures.
!                                                                              
! LATEST REVISION : 22/08/2019
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, zero, true, false, lamch, bd_cmp, bd_inviter2, bd_singval, &
                         norm, unit_matrix, c1_5, 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
!
    integer(i4b), parameter :: prtunit=6, n=3000, m=3000, mn=min(m,n), nsing=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of bd_inviter2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, err3, eps, abstol, elapsed_time
    real(stnd), allocatable, dimension(:)   :: s, d, e, tauq, taup, tauo
    real(stnd), allocatable, dimension(:,:) :: a, a2, leftvec, rightvec, resid, rla
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: ns, maxiter=2, mnthr
!
    logical(lgl) :: failure1, failure2, do_test, two_stage
!   
    character    :: sort='d'
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : ALL SINGULAR VALUES AND nsing SINGULAR VECTORS OF A n-BY-m REAL MATRIX
!               USING THE BIDIAGONAL QR ALGORITHM FOR THE SINGULAR VALUES AND THE INVERSE
!               ITERATION METHOD FOR THE SINGULAR VECTORS (eg PARTIAL SVD DECOMPOSITION).
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps    = fudge*epsilon( err )
    abstol = sqrt( lamch('S') )
    err    = zero
!
    do_test = true
!
!   DETERMINE CROSSOVER POINT FOR THE SVD WHEN REDUCING
!   a TO BIDIAGONAL FORM. IF max(n,m) EXCEEDS mnthr ,
!   A QR OR LQ FACTORIZATION IS USED FIRST TO REDUCE THE
!   n-BY-m MATRIX a TO A TRIANGULAR FORM.
!    
    mnthr = int( real( mn, stnd )*c1_5, i4b )
!
    two_stage = max( n, m )>=mnthr
!    two_stage = true
!    two_stage = false
!
!   ALLOCATE WORK ARRAYS.
!
    if ( two_stage ) then
        allocate( a(n,m), leftvec(n,nsing), rightvec(m,nsing), rla(mn,mn),    &
                  s(mn), d(mn), e(mn), tauq(mn), taup(mn), tauo(mn), stat=iok )
    else
        allocate( a(n,m), leftvec(n,nsing), rightvec(m,nsing),      &
                  s(mn), d(mn), e(mn), tauq(mn), taup(mn), stat=iok )
    end if
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-BY-m RANDOM REAL MATRIX a.
!
    call random_number( a )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( a2(n,m), resid(n,nsing), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       MAKE A COPY OF THE RANDOM DATA MATRIX .
!
        a2(:n,:m) = a(:n,:m)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL n-BY-m MATRIX a
!   IS WRITTEN
!
!                       a = U * S * V**(t)
!
!   WHERE S IS AN n-BY-m MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   min(m,n) DIAGONAL ELEMENTS, U IS AN n-BY-n ORTHOGONAL MATRIX, AND
!   V IS AN m-BY-m 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.
!
!   THIS PROGRAM ILLUSTRATES HOW TO COMPUTE ALL THE SINGULAR VALUES OF a AND
!   ONLY nsing LEFT AND RIGHT SINGULAR VECTORS OF a (EG A PARTIAL SVD DECOMPOSITION
!   OF a) IN THREE STEPS:
!
    if ( two_stage ) then
!
!       STEP1A : REDUCE THE MATRIX a TO BIDIAGONAL FORM BY A TWO-STAGE ALGORITHM WITH SUBROUTINE bd_cmp.
!       THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!       THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM
!       ARE STORED IN mat, tauq, taup, rla AND tauo.
!
        call bd_cmp( a(:n,:m), d(:mn), e(:mn), tauq(:mn), taup(:mn), rla(:mn,:mn), tauo=tauo(:mn) )
!        call bd_cmp( a(:n,:m), d(:mn), e(:mn), tauq(:mn), taup(:mn), rla(:mn,:mn) )
!
    else
!
!       STEP1B : REDUCE THE MATRIX a TO BIDIAGONAL FORM WITHOUT A QR OR LQ FACTORIZATION WITH SUBROUTINE bd_cmp.
!       THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!       THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM
!       ARE STORED IN mat, tauq, taup.
!
        call bd_cmp( a(:n,:m), d(:mn), e(:mn), tauq(:mn), taup(:mn) )
!
    end if
!
!   STEP2 : COMPUTE SINGULAR VALUES OF THE BIDIAGONAL MATRIX (WHICH ARE ALSO THE
!   SINGULAR VALUES OF a) WITH SUBROUTINE bd_singval TO HIGH RELATIVE PRECISION.
!   THE SINGULAR VALUES ARE STORED IN s IN DECREASING ORDER (IF sort='d').
!
!   THE OPTIONAL ARGUMENT abstol OF bd_singval MAY BE USED TO INDICATE THE REQUIRED
!   PRECISION FOR THE SINGULAR VALUES. A SINGULAR VALUE IS CONSIDERED TO BE LOCATED
!   IF IT HAS BEEN DETERMINED TO LIE IN AN INTERVAL WHOSE WIDTH IS EQUAL OR LESS
!   THAN abstol. SINGULAR VALUES WILL BE COMPUTED MOST ACCURATELY WHEN abstol IS SET
!   TO THE SQUARE ROOT OF THE UNDERFLOW THRESHOLD (EG sqrt(LAMCH('S')) ).
!
    call bd_singval( d(:mn), e(:mn), ns, s(:mn), failure=failure1, sort=sort, abstol=abstol )
!
!   STEP3 : COMPUTE THE FIRST nsing LEFT AND RIGHT SINGULAR VECTORS OF a BY maxiter
!   INVERSE ITERATIONS ON THE INTERMEDIATE BIDIAGONAL MATRIX AND BACK-TRANSFORMATION
!   WITH SUBROUTINE bd_inviter2 .
!
!   ON ENTRY OF bd_inviter2, PARAMETER s CONTAINS SELECTED SINGULAR VALUES OF THE BIDIAGONAL MATRIX d_e (OR a).
!   THE SINGULAR VALUES MUST BE GIVEN IN DECREASING ORDER.
!
    if ( two_stage ) then
!
        call bd_inviter2( a, tauq, taup, rla, d, e, s(:nsing), leftvec, rightvec, failure=failure2, tauo=tauo, maxiter=maxiter )
!        call bd_inviter2( a, tauq, taup, rla, d, e, s(:nsing), leftvec, rightvec, failure=failure2, maxiter=maxiter )
!
    else
!
        call bd_inviter2( a, tauq, taup, d, e, s(:nsing), leftvec, rightvec, failure=failure2, maxiter=maxiter )
!
    end if
!
!   ON EXIT OF bd_inviter2 :
!
!         failure= false :  INDICATES SUCCESSFUL EXIT.
!         failure= true  :  INDICATES THAT THE ALGORITHM FAILS TO CONVERGE FOR SOME SINGULAR VECTORS.
!
!   THE SINGULAR VECTORS OF THE BIDIAGONAL FORM ARE COMPUTED USING maxiter INVERSE ITERATIONS
!   FOR ALL THE SINGULAR VALUES AT ONE STEP. THE SINGULAR VECTORS OF ARE THEN ORTHOGONALIZED BY 
!   THE MODIFIED GRAM-SCHMIDT ALGORITHM IF NECESSARY. THE SINGULAR VECTORS OF a ARE FINALLY COMPUTED 
!   BY BACK TRANSFORMATIONS. ON EXIT, leftvec AND rightvec CONTAIN THE FIRST nsing LEFT AND RIGHT
!   SINGULAR VECTORS OF a, RESPECTIVELY.
!
!   NOTE THAT bd_inviter2 MAY FAIL IF SOME THE SINGULAR VALUES SPECIFIED IN PARAMETER s ARE NEARLY
!   IDENTICAL FOR SOME PATHOLOGICAL MATRICES.
!
!   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 ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*V(:m,:nsing) - U(:n,:nsing)*S(:nsing,:nsing),
!       WHERE leftvec AND rightvec ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a.
!
        resid(:n,:nsing) = matmul(a2,rightvec) - leftvec*spread(s(:nsing),dim=1,ncopies=n)
        a2(:nsing,1_i4b) = norm( resid(:n,:nsing), dim=2_i4b )
        err1 = maxval( a2(:nsing,1_i4b) )/( sum( abs(s(:mn)) )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U(:n,:nsing)**(t)*U(:n,:nsing).
!
        call unit_matrix( a2(:nsing,:nsing) )
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(leftvec), leftvec ) )
        err2 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - V(:m,:nsing)**(t)*V(:m,:nsing).
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(rightvec), rightvec ) )
        err3 = maxval( resid(:nsing,:nsing) )/real(m,stnd)
!
        err = max( err1, err2, err3 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a2, resid )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( two_stage ) then
!
        deallocate( a, leftvec, rightvec, rla, s, d, e, tauq, taup, tauo )
!
    else
!
        deallocate( a, leftvec, rightvec, s, d, e, tauq, taup )
!
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. .not.failure1 .and. .not.failure2 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing all singular values and ', nsing, ' singular vectors of a ', &
       n, ' by ', m,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_bd_inviter2
! ==============================
!
end program ex1_bd_inviter2

ex1_bd_singval.F90

program ex1_bd_singval
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine BD_SINGVAL
!   in module SVD_Procedures .
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine BD_INVITER in module SVD_Procedures.
!
! LATEST REVISION : 08/01/2016
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, quarter, one, c50,     &
                         bd_inviter, bd_singval, unit_matrix, norm, geop, lamch,   &
                         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
!
    integer(i4b), parameter :: prtunit=6, n=100, ls=80
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err3, err, eps, abstol, elapsed_time
    real(stnd), allocatable, dimension(:)   :: d, e, s
    real(stnd), allocatable, dimension(:,:) :: id, resid, leftvec, rightvec
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: maxiter=2, nsing
!
    logical(lgl) :: failure1, failure2, a_is_upper, do_test
!   
    character    :: sort='d'
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of bd_singval'
!   
    real(stnd), parameter  :: fudge=c50
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : ls SINGULAR VALUES AND VECTORS OF A n-BY-n REAL BIDIAGONAL MATRIX bd
!               BY THE BISECTION-INVERSE ITERATION METHOD (eg PARTIAL SVD DECOMPOSITION).
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    abstol = sqrt( lamch('S') )
!
    err = zero
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( d(n), e(n), s(n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE AN UPPER BIDIAGONAL GRADED MATRIX bd.
!   THE DIAGONAL ELEMENTS ARE STORED IN d .
!   THE OFF-DIAGONAL ELEMENTS ARE STORED IN e .
!
    a_is_upper   = true
!
    d(:n)      = geop( one, quarter, n )
    e(1_i4b)   = zero
    e(2_i4b:n) = d(:n-1_i4b)
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL n-BY-n BIDIAGONAL MATRIX bd
!   IS WRITTEN
!
!                       bd = u * s * v**(t)
!
!   WHERE s IS AN n-BY-n MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   n DIAGONAL ELEMENTS, u AND v ARE n-BY-n ORTHOGONAL MATRICES.
!   THE DIAGONAL ELEMENTS OF s ARE THE SINGULAR VALUES OF bd; THEY ARE
!   REAL AND NON-NEGATIVE.
!   THE COLUMNS OF u AND v ARE THE LEFT AND RIGHT SINGULAR VECTORS OF bd.
!
!   THIS PROGRAM ILLUSTRATES HOW TO COMPUTE THE ls LARGEST SINGULAR VALUES OF bd AND
!   THE ASSOCIATED LEFT AND RIGHT SINGULAR VECTORS (EG A PARTIAL SVD DECOMPOSITION OF bd)
!   IN TWO STEPS:
!
!   STEP1 : COMPUTE THE ls LARGEST SINGULAR VALUES OF bd BY BISECTION
!   WITH SUBROUTINE bd_singval :
!
    call bd_singval( d(:n), e(:n), nsing, s(:n), failure=failure1, sort=sort, abstol=abstol, ls=ls )
!
!   ON EXIT OF bd_singval :
!
!   failure= false :  INDICATES SUCCESSFUL EXIT
!   failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                      THAT FULL ACCURACY WAS NOT ATTAINED IN THE
!                      COMPUTATION OF THE SINGULAR VALUES OF bd.
!
!   nsing GIVES THE NUMBER OF SINGULAR VALUES REALLY COMPUTED BY bd_singval. nsing MAY BE GREATER
!   THAN ls IF CLUSTERS OF SINGULAR VALUES ARE PRESENT.
!   THE nsing LARGEST SINGULAR VALUES ARE STORED IN THE FIRST nsing POSITIONS OF s IN DECREASING ORDER IF sort='d'.
!
!   STEP2 : COMPUTE THE nsing ASSOCIATED SINGULAR VALUES OF bd BY INVERSE ITERATION WITH SUBROUTINE
!   bd_inviter :
!
    if ( nsing>0 ) then
!
!       ALLOCATE WORK VARIABLES NEEDED TO STORE THE SINGULAR VECTORS.
!
        allocate( leftvec(n,nsing),    &
                  rightvec(n,nsing),   &
                  stat = iok    )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE THE FIRST nsing SINGULAR VECTORS OF a BY maxiter INVERSE ITERATIONS WITH
!       SUBROUTINE bd_inviter .
!
        call bd_inviter( a_is_upper, d(:n), e(:n), s(:nsing), leftvec(:n,:nsing), rightvec(:n,:nsing),  &
                         failure=failure2, maxiter=maxiter )
!
!       ON ENTRY, PARAMETER s CONTAINS SELECTED SINGULAR VALUES OF THE BIDIAGONAL MATRIX bd .
!       THE SINGULAR VALUES MUST BE GIVEN IN DECREASING ORDER.
!
!       ON EXIT OF bd_inviter :
!
!       failure= false :  INDICATES SUCCESSFUL EXIT
!       failure= true  :  INDICATES THAT THE ALGORITHM FAILS TO CONVERGE
!
!       THE SINGULAR VECTORS OF THE BIDIAGONAL MATRIX bd ARE COMPUTED USING maxiter INVERSE ITERATIONS
!       FOR ALL THE SINGULAR VALUES AT ONE STEP. THE SINGULAR VECTORS OF bd ARE THEN ORTHOGONALIZED BY 
!       THE MODIFIED GRAM-SCHMIDT ALGORITHM IF THE SINGULAR VALUES ARE NOT WELL SEPARATED.
!       ON EXIT, leftvec AND rightvec CONTAIN THE FIRST nsing SINGULAR VECTORS OF bd .
!
!       bd_inviter MAY FAIL IF SOME THE SINGULAR VALUES SPECIFIED IN PARAMETER s ARE NEARLY
!       IDENTICAL.
!
    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 ( do_test .and. nsing>0 ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( id(nsing,nsing), resid(n,nsing), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION bd*v - u*singval(:nsing),
!       WHERE u AND v ARE THE LEFT AND RIGHT SINGULAR VECTORS OF bd .
!
        if ( a_is_upper ) then
!
            resid(:n,:nsing) = spread( d(:n),         dim=2, ncopies=nsing )*rightvec                 + &
                               eoshift( spread(e(:n), dim=2,ncopies=nsing)*rightvec, shift=1 )        - &
                               spread( s(:nsing),     dim=1, ncopies=n )*leftvec 

        else
!
            resid(:n,:nsing) = spread( d(:n),         dim=2, ncopies=nsing )*leftvec                   + &
                               eoshift( spread(e(:n), dim=2,ncopies=nsing)*leftvec, shift=1 )          - &
                               spread( s(:nsing),     dim=1, ncopies=n )*rightvec
!
        end if
!
        id(:nsing,1_i4b) = norm( resid(:n,:nsing), dim=2_i4b )
        err1 = maxval( id(:nsing,1_i4b) )/( sum( s(:nsing) )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u**(t)*u
!       WHERE u are LEFT SINGULAR VECTORS OF THE BIDIAGONAL MATRIX a.
!
        call unit_matrix( id )
!
        resid(:nsing,:nsing) = abs( id - matmul( transpose( leftvec ), leftvec ) )
        err2 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - rightvec**(t)*rightvec
!       WHERE rightvec ARE THE RIGHT SINGULAR VECTORS OF THE BIDIAGONAL MATRIX bd.
!
        resid(:nsing,:nsing) = abs( id - matmul( transpose( rightvec ), rightvec ) )
        err3 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
        err = max( err1, err2, err3 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( id, resid )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( nsing>0 ) then
        deallocate( d, e, s, leftvec, rightvec )
    else
        deallocate( d, e, s )
    end if
!
    if ( err<=eps .and. .not.failure1 .and. .not.failure2 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test .and. nsing>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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', nsing, ' singular values and vectors of a ', &
       n, ' by ', n,' real bidiagonal matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_bd_singval
! =============================
!
end program ex1_bd_singval

ex1_bd_singval2.F90

program ex1_bd_singval2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine BD_SINGVAL2
!   in module SVD_Procedures .
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine BD_INVITER in module SVD_Procedures.
!
! LATEST REVISION : 08/01/2016
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, one, two, c50,        &
                         bd_inviter, bd_singval2, unit_matrix, norm, geop, lamch, &
                         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
!
    integer(i4b), parameter :: prtunit=6, n=50, ls=20
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err3, err, eps, abstol, elapsed_time
    real(stnd), allocatable, dimension(:)   :: d, e, s
    real(stnd), allocatable, dimension(:,:) :: id, resid, leftvec, rightvec
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: maxiter=2, nsing
!
    logical(lgl) :: failure1, failure2, a_is_upper, do_test
!   
    character    :: sort='d'
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of bd_singval2'
!   
    real(stnd), parameter  :: fudge=c50
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : ls SINGULAR VALUES AND VECTORS OF A n-BY-n REAL BIDIAGONAL MATRIX bd
!               BY THE BISECTION-INVERSE ITERATION METHOD (eg PARTIAL SVD DECOMPOSITION).
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    abstol = sqrt( lamch('S') )
!
    err = zero
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( d(n), e(n), s(n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE AN UPPER BIDIAGONAL GRADED MATRIX bd.
!   THE DIAGONAL ELEMENTS ARE STORED IN d .
!   THE OFF-DIAGONAL ELEMENTS ARE STORED IN e .
!
    a_is_upper   = true
!
    d(:n)      = geop( one, two, n )
    e(1_i4b)   = zero
    e(2_i4b:n) = d(:n-1_i4b)
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL n-BY-n BIDIAGONAL MATRIX bd
!   IS WRITTEN
!
!                       bd = u * s * v**(t)
!
!   WHERE s IS AN n-BY-n MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   n DIAGONAL ELEMENTS, u AND v ARE n-BY-n ORTHOGONAL MATRICES.
!   THE DIAGONAL ELEMENTS OF s ARE THE SINGULAR VALUES OF bd; THEY ARE
!   REAL AND NON-NEGATIVE.
!   THE COLUMNS OF u AND v ARE THE LEFT AND RIGHT SINGULAR VECTORS OF bd.
!
!   THIS PROGRAM ILLUSTRATES HOW TO COMPUTE THE ls LARGEST SINGULAR VALUES OF bd AND
!   THE ASSOCIATED LEFT AND RIGHT SINGULAR VECTORS (EG A PARTIAL SVD DECOMPOSITION OF bd)
!   IN TWO STEPS:
!
!   STEP1 : COMPUTE THE ls LARGEST SINGULAR VALUES OF bd BY BISECTION
!   WITH SUBROUTINE bd_singval2 :
!
    call bd_singval2( d(:n), e(:n), nsing, s(:n), failure=failure1, sort=sort, abstol=abstol, ls=ls )
!
!   ON EXIT OF bd_singval2 :
!
!   failure= false :  INDICATES SUCCESSFUL EXIT
!   failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                      THAT FULL ACCURACY WAS NOT ATTAINED IN THE
!                      COMPUTATION OF THE SINGULAR VALUES OF bd.
!
!   nsing GIVES THE NUMBER OF SINGULAR VALUES REALLY COMPUTED BY bd_singval2. nsing MAY BE GREATER
!   THAN ls IF CLUSTERS OF SINGULAR VALUES ARE PRESENT.
!   THE nsing LARGEST SINGULAR VALUES ARE STORED IN THE FIRST nsing POSITIONS OF s IN DECREASING ORDER IF sort='d'.
!
!   STEP2 : COMPUTE THE nsing ASSOCIATED SINGULAR VALUES OF bd BY INVERSE ITERATION WITH SUBROUTINE
!   bd_inviter :
!
    if ( nsing>0 ) then
!
!       ALLOCATE WORK VARIABLES NEEDED TO STORE THE SINGULAR VECTORS.
!
        allocate( leftvec(n,nsing),    &
                  rightvec(n,nsing),   &
                  stat = iok    )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE THE FIRST nsing SINGULAR VECTORS OF a BY maxiter INVERSE ITERATIONS WITH
!       SUBROUTINE bd_inviter .
!
        call bd_inviter( a_is_upper, d(:n), e(:n), s(:nsing), leftvec(:n,:nsing), rightvec(:n,:nsing),  &
                         failure=failure2, maxiter=maxiter )
!
!       ON ENTRY, PARAMETER s CONTAINS SELECTED SINGULAR VALUES OF THE BIDIAGONAL MATRIX bd .
!       THE SINGULAR VALUES MUST BE GIVEN IN DECREASING ORDER.
!
!       ON EXIT OF bd_inviter :
!
!       failure= false :  INDICATES SUCCESSFUL EXIT
!       failure= true  :  INDICATES THAT THE ALGORITHM FAILS TO CONVERGE
!
!       THE SINGULAR VECTORS OF THE BIDIAGONAL MATRIX bd ARE COMPUTED USING maxiter INVERSE ITERATIONS
!       FOR ALL THE SINGULAR VALUES AT ONE STEP. THE SINGULAR VECTORS OF bd ARE THEN ORTHOGONALIZED BY 
!       THE MODIFIED GRAM-SCHMIDT ALGORITHM IF THE SINGULAR VALUES ARE NOT WELL SEPARATED.
!       ON EXIT, leftvec AND rightvec CONTAIN THE FIRST nsing SINGULAR VECTORS OF bd .
!
!       bd_inviter MAY FAIL IF SOME THE SINGULAR VALUES SPECIFIED IN PARAMETER s ARE NEARLY
!       IDENTICAL.
!
    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 ( do_test .and. nsing>0 ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( id(nsing,nsing), resid(n,nsing), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION bd*v - u*singval(:nsing),
!       WHERE u AND v ARE THE LEFT AND RIGHT SINGULAR VECTORS OF bd .
!
        if ( a_is_upper ) then
!
            resid(:n,:nsing) = spread( d(:n),         dim=2, ncopies=nsing )*rightvec                 + &
                               eoshift( spread(e(:n), dim=2,ncopies=nsing)*rightvec, shift=1 )        - &
                               spread( s(:nsing),     dim=1, ncopies=n )*leftvec 

        else
!
            resid(:n,:nsing) = spread( d(:n),         dim=2, ncopies=nsing )*leftvec                   + &
                               eoshift( spread(e(:n), dim=2,ncopies=nsing)*leftvec, shift=1 )          - &
                               spread( s(:nsing),     dim=1, ncopies=n )*rightvec
!
        end if
!
        id(:nsing,1_i4b) = norm( resid(:n,:nsing), dim=2_i4b )
        err1 = maxval( id(:nsing,1_i4b) )/( sum( s(:nsing) )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u**(t)*u
!       WHERE u are LEFT SINGULAR VECTORS OF THE BIDIAGONAL MATRIX a.
!
        call unit_matrix( id )
!
        resid(:nsing,:nsing) = abs( id - matmul( transpose( leftvec ), leftvec ) )
        err2 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - rightvec**(t)*rightvec
!       WHERE rightvec ARE THE RIGHT SINGULAR VECTORS OF THE BIDIAGONAL MATRIX bd.
!
        resid(:nsing,:nsing) = abs( id - matmul( transpose( rightvec ), rightvec ) )
        err3 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
        err = max( err1, err2, err3 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( id, resid )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( nsing>0 ) then
        deallocate( d, e, s, leftvec, rightvec )
    else
        deallocate( d, e, s )
    end if
!
    if ( err<=eps .and. .not.failure1 .and. .not.failure2 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test .and. nsing>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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', nsing, ' singular values and vectors of a ', &
       n, ' by ', n,' real bidiagonal matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_bd_singval2
! ==============================
!
end program ex1_bd_singval2

ex1_bd_svd.F90

program ex1_bd_svd
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine BD_SVD
!   in module SVD_Procedures .
!                                                                              
!                                                     
! LATEST REVISION : 23/05/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, half, one, c1_m2, c900, c50, &
                         bd_svd, 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
!
    integer(i4b), parameter :: prtunit=6, n=3000
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of bd_svd'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err3, err, eps, elapsed_time
    real(stnd), allocatable, dimension(:)   :: diag, sup, sup2, singval
    real(stnd), allocatable, dimension(:,:) :: leftvec, rightvec, id, resid
!
    integer      :: iok, istart, iend, irate, imax, itime
!
    logical(lgl) :: failure, bd_is_upper, do_test
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : FULL SVD OF A REAL BIDIAGONAL MATRIX BD USING THE GOLUB-REINSCH ALGORITHM.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( diag(n), sup(n), sup2(n), singval(n),   &
              leftvec(n,n), rightvec(n,n), stat=iok   )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE AN UPPER BIDIAGONAL MATRIX BD.
!   THE DIAGONAL ELEMENTS ARE STORED IN diag .
!   THE OFF-DIAGONAL ELEMENTS ARE STORED IN sup .
!
    bd_is_upper   = true
!
    sup(1_i4b)   = zero
!
!    diag(:n)     = half
!    sup(2_i4b:n) = one
!
!    diag(:n)     = c1_m2
!    sup(2_i4b:n) = c900
!
    call random_number( diag(:n) )
    call random_number( sup(2_i4b:n) )
!
!   MAKE A COPY OF THE BIDIAGONAL MATRIX.
!
    singval(:n) = diag(:n)
    sup2(:n)    = sup(:n)
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   COMPUTE ALL SINGULAR VALUES AND VECTORS OF THE BIDIAGONAL MATRIX BD .
!
!   FIST INITALIZED THE LEFT AND RIGHT SINGULAR VECTORS TO THE IDENTITY MATRIX OF ORDER n.
!
    call unit_matrix( leftvec(:n,:n) )
    call unit_matrix( rightvec(:n,:n) )
!
!   bd_svd COMPUTES THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL
!   n-BY-n (UPPER OR LOWER) BIDIAGONAL MATRIX BD. THE SVD IS WRITTEN
!
!                       BD = U * S * V**(t)
!
!   WHERE S IS AN n-BY-n MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   DIAGONAL ELEMENTS, U IS AN n-BY-n ORTHOGONAL MATRIX, AND
!   V IS AN n-BY-n ORTHOGONAL MATRIX.  THE DIAGONAL ELEMENTS OF S
!   ARE THE SINGULAR VALUES OF BD; THEY ARE REAL AND NON-NEGATIVE.
!   THE COLUMNS OF U AND V ARE THE LEFT AND RIGHT SINGULAR VECTORS OF BD.
!
    call bd_svd( bd_is_upper, singval(:n), sup2(:n), failure, leftvec(:n,:n), &
                 rightvec(:n,:n), sort=sort )
!
!   THE ROUTINE RETURNS THE SINGULAR VALUES, THE LEFT AND RIGHT
!   SINGULAR VECTORS. THE SINGULAR VECTORS ARE RETURNED COLUMNWISE.
!
!   ON EXIT OF bd_svd :
!
!       failure= false :  INDICATES SUCCESSFUL EXIT.
!       failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                         THAT FULL ACCURACY WAS NOT ATTAINED IN THE BIDIAGONAL
!                         SVD OF BD.
!
!       singval  IS OVERWRITTEN WITH THE SINGULAR VALUES OF BD.
!       leftvec  IS OVERWRITTEN WITH THE LEFT SINGULAR VECTORS OF BD  IF leftvec IS THE IDENTITY ON ENTRY.
!       rightvec IS OVERWRITTEN WITH THE RIGHT SINGULAR VECTORS OF BD IF rightvec IS THE IDENTITY ON ENTRY.
!
!   IF SORT = 'a' OR 'A', THE SINGULAR VALUES ARE SORTED INTO ASCENDING ORDER.
!   IF SORT = 'd' OR 'D', THE SINGULAR VALUES ARE SORTED INTO DESCENDING ORDER.
!   THE SINGULAR VECTORS ARE REARRANGED ACCORDINGLY.
!
!   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 ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( id(n,n), resid(n,n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION bd*rightvec - leftvec*singval(:n),
!       WHERE leftvec AND rightvec ARE THE LEFT AND RIGHT SINGULAR VECTORS.
!
        if ( bd_is_upper ) then
!
            resid(:n,:n) = spread( diag(:n),        dim=2, ncopies=n )*rightvec                 + &
                           eoshift( spread(sup(:n), dim=2,ncopies=n)*rightvec, shift=1 )        - &
                           spread( singval(:n), dim=1, ncopies=n )*leftvec 

        else
!
            resid(:n,:n) = spread( diag(:n),        dim=2, ncopies=n )*leftvec                   + &
                           eoshift( spread(sup(:n), dim=2,ncopies=n)*leftvec, shift=1 )          - &
                           spread( singval(:n), dim=1, ncopies=n )*rightvec
!
        end if
!
        id(:n,1_i4b) = norm( resid(:n,:n), dim=2_i4b )
        err1 = maxval( id(:n,1_i4b) )/( sum( singval(:n) )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u**(t)*u
!       WHERE u are LEFT SINGULAR VECTORS OF THE BIDIAGONAL MATRIX bd.
!
        call unit_matrix( id )
!
        resid = abs( id - matmul( transpose( leftvec ), leftvec ) )
        err2 = maxval( resid(:n,:n) )/real(n,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - v**(t)*v
!       WHERE v are RIGHT SINGULAR VECTORS OF THE BIDIAGONAL MATRIX bd.
!
        resid = abs( id - matmul( transpose( rightvec ), rightvec ) )
        err3 = maxval( resid(:n,:n) )/real(n,stnd)
!
        err = max( err1, err2, err3 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( id, resid )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( diag, sup, sup2, singval, leftvec, rightvec )
!
    if ( err<=eps .and. .not.failure ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) 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,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing all singular values and singular vectors of a ', &
       n, ' by ', n,' real bidiagonal matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_bd_svd
! =========================
!
end program ex1_bd_svd

ex1_bd_svd2.F90

program ex1_bd_svd2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine BD_SVD2
!   in module SVD_Procedures .
!                                                                              
!                                                     
! LATEST REVISION : 23/05/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, half, one, c1_m2, c900, c50, &
                         bd_svd2, 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
!
    integer(i4b), parameter :: prtunit=6, n=3000
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of bd_svd2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err3, err, eps, elapsed_time
    real(stnd), allocatable, dimension(:)   :: diag, sup, sup2, singval
    real(stnd), allocatable, dimension(:,:) :: leftvec, rightvec, id, resid
!
    integer      :: iok, istart, iend, irate, imax, itime
!
    logical(lgl) :: failure, bd_is_upper, do_test
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : FULL SVD OF A REAL BIDIAGONAL MATRIX BD USING THE GOLUB-REINSCH ALGORITHM
!               WITH LAPACK STYLE CONVENTION FOR STORING THE SINGULAR VECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( diag(n), sup(n), sup2(n), singval(n),   &
              leftvec(n,n), rightvec(n,n), stat=iok   )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE AN UPPER BIDIAGONAL MATRIX BD.
!   THE DIAGONAL ELEMENTS ARE STORED IN diag .
!   THE OFF-DIAGONAL ELEMENTS ARE STORED IN sup .
!
    bd_is_upper   = true
!
    sup(1_i4b)   = zero
!
!    diag(:n)     = half
!    sup(2_i4b:n) = one
!
!    diag(:n)     = c1_m2
!    sup(2_i4b:n) = c900
!
    call random_number( diag(:n) )
    call random_number( sup(2_i4b:n) )
!
!   MAKE A COPY OF THE BIDIAGONAL MATRIX.
!
    singval(:n) = diag(:n)
    sup2(:n)    = sup(:n)
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   COMPUTE ALL SINGULAR VALUES AND VECTORS OF THE BIDIAGONAL MATRIX BD .
!
!   FIST INITALIZED THE LEFT AND RIGHT SINGULAR VECTORS TO THE IDENTITY MATRIX OF ORDER n.
!
    call unit_matrix( leftvec(:n,:n) )
    call unit_matrix( rightvec(:n,:n) )
!
!   bd_svd2 COMPUTES THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL
!   n-BY-n (UPPER OR LOWER) BIDIAGONAL MATRIX BD. THE SVD IS WRITTEN
!
!                       BD = U * S * V**(t)
!
!   WHERE S IS AN n-BY-n MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   DIAGONAL ELEMENTS, U IS AN n-BY-n ORTHOGONAL MATRIX, AND
!   V IS AN n-BY-n ORTHOGONAL MATRIX.  THE DIAGONAL ELEMENTS OF S
!   ARE THE SINGULAR VALUES OF BD; THEY ARE REAL AND NON-NEGATIVE.
!   THE COLUMNS OF U AND V ARE THE LEFT AND RIGHT SINGULAR VECTORS OF BD.
!
    call bd_svd2( bd_is_upper, singval(:n), sup2(:n), failure, leftvec(:n,:n), &
                  rightvec(:n,:n), sort=sort )
!
!   THE ROUTINE RETURNS THE SINGULAR VALUES, THE LEFT AND RIGHT
!   SINGULAR VECTORS. THE LEFT SINGULAR VECTORS ARE RETURNED COLUMNWISE,
!   BUT THE RIGHT SINGULAR VECTORS ARE RETURNED ROWWISE. THIS IS THE LAPACK
!   CONVENTION AND IS THE ONLY DIFFERENCE BETWEEN bd_svd2 AND bd_svd.
!
!   ON EXIT OF bd_svd2 :
!
!       failure= false :  INDICATES SUCCESSFUL EXIT.
!       failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                         THAT FULL ACCURACY WAS NOT ATTAINED IN THE BIDIAGONAL
!                         SVD OF BD.
!
!       singval  IS OVERWRITTEN WITH THE SINGULAR VALUES OF BD.
!       leftvec  IS OVERWRITTEN WITH THE LEFT SINGULAR VECTORS OF BD  IF leftvec IS THE IDENTITY ON ENTRY.
!       rightvec IS OVERWRITTEN WITH THE RIGHT SINGULAR VECTORS OF BD IF rightvec IS THE IDENTITY ON ENTRY.
!
!   IF SORT = 'a' OR 'A', THE SINGULAR VALUES ARE SORTED INTO ASCENDING ORDER.
!   IF SORT = 'd' OR 'D', THE SINGULAR VALUES ARE SORTED INTO DESCENDING ORDER.
!   THE SINGULAR VECTORS ARE REARRANGED ACCORDINGLY.
!
!   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 ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( id(n,n), resid(n,n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       TRANSPOSE THE RIGHT SINGULAR VECTORS SO THAT THEY ARE STORED COLUMNWISE.
!
        resid(:n,:n) = transpose( rightvec(:n,:n) )
        rightvec(:n,:n) = resid(:n,:n)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION bd*rightvec - leftvec*singval(:n),
!       WHERE leftvec AND rightvec ARE THE LEFT AND RIGHT SINGULAR VECTORS.
!
        if ( bd_is_upper ) then
!
            resid(:n,:n) = spread( diag(:n),        dim=2, ncopies=n )*rightvec                 + &
                           eoshift( spread(sup(:n), dim=2,ncopies=n)*rightvec, shift=1 )        - &
                           spread( singval(:n), dim=1, ncopies=n )*leftvec 

        else
!
            resid(:n,:n) = spread( diag(:n),        dim=2, ncopies=n )*leftvec                   + &
                           eoshift( spread(sup(:n), dim=2,ncopies=n)*leftvec, shift=1 )          - &
                           spread( singval(:n), dim=1, ncopies=n )*rightvec
!
        end if
!
        id(:n,1_i4b) = norm( resid(:n,:n), dim=2_i4b )
        err1 = maxval( id(:n,1_i4b) )/( sum( singval(:n) )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u**(t)*u
!       WHERE u are LEFT SINGULAR VECTORS OF THE BIDIAGONAL MATRIX bd.
!
        call unit_matrix( id )
!
        resid = abs( id - matmul( transpose( leftvec ), leftvec ) )
        err2 = maxval( resid(:n,:n) )/real(n,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - v**(t)*v
!       WHERE v are RIGHT SINGULAR VECTORS OF THE BIDIAGONAL MATRIX bd.
!
        resid = abs( id - matmul( transpose( rightvec ), rightvec ) )
        err3 = maxval( resid(:n,:n) )/real(n,stnd)
!
        err = max( err1, err2, err3 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( id, resid )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( diag, sup, sup2, singval, leftvec, rightvec )
!
    if ( err<=eps .and. .not.failure ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) 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,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing all singular values and singular vectors of a ', &
       n, ' by ', n,' real bidiagonal matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_bd_svd2
! ==========================
!
end program ex1_bd_svd2

ex1_chol_cmp.F90

program ex1_chol_cmp
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines CHOL_CMP and CHOL_SOLVE
!   in module Lin_Procedures. 
!                                                                              
! LATEST REVISION : 18/06/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, zero, true, false, chol_cmp,   &
                         chol_solve, 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
!
    integer(i4b), parameter :: prtunit=6, n=8000, m=n+10
!
    character(len=*), parameter :: name_proc='Example 1 of chol_cmp'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, eps, d1, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, c
    real(stnd), dimension(:),   allocatable :: invdiag, b, x, res
!
    integer :: iok, istart, iend, irate, imax, itime
!
    logical(lgl)   :: do_test, upper
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : SOLVING A LINEAR SYSTEM WITH A REAL n-BY-n SYMMETRIC DEFINITE POSITIVE MATRIX
!               AND ONE RIGHT HAND-SIDE WITH THE CHOLESKY DECOMPOSITION.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = sqrt( epsilon( err ) )
    err = zero
!
    do_test = false
    upper   = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( c(m,n), a(n,n), b(n), x(n), invdiag(n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-by-n RANDOM SYMMETRIC POSITIVE DEFINITE MATRIX a .
!
    call random_number( c )
!
    a = matmul( transpose(c), c )
!
!   GENERATE A n RANDOM SOLUTION VECTOR x .
!
    call random_number( x )
!
!   COMPUTE THE MATRIX-VECTOR 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 VECTOR FOR SYMMETRIC POSITIVE DEFINITE
!   SYSTEM
!
!            a*x = b .
!
!   BY COMPUTING THE CHOLESKY DECOMPOSITION OF MATRIX a .
!   IF ON OUTPUT OF chol_cmp d1 IS DIFFERENT FROM ZERO
!   THEN THE SYMMETRIC LINEAR SYSTEM IS NOT SINGULAR
!   AND CAN BE SOLVED BY SUBROUTINE chol_solve.
!
    call chol_cmp( a, invdiag, d1, upper=upper )
!
    if ( d1==zero ) then
!
!       ANORMAL EXIT IN chol_cmp SUBROUTINE, PRINT A WARNING.
!
        write (prtunit,*) 'Error in exit of CHOL_CMP subroutine, d1=', d1
        write (prtunit,*)
!
    else
!
!       SOLVE THE SYMMETRIC LINEAR SYSTEM.
!
        call chol_solve( a, invdiag, b, upper=upper )
!
    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 ( d1/=zero .and. do_test ) then
!
!       ALLOCATE WORK ARRAY.
!
        allocate( res(n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       CHECK THE RESULTS FOR SMALL RESIDUALS.
!
        res(:n) = b(:n) - x(:n)
        err     = norm(res) /( real(n,stnd)*norm(x) )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, b, c, x, invdiag, res )
!
    else
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, b, c, x, invdiag )
!
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. d1/=zero ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for solving a positive definite symmetric linear system of size ', &
       n, ' by ', n, ' is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_chol_cmp
! ===========================
!
end program ex1_chol_cmp

ex1_chol_cmp2.F90

program ex1_chol_cmp2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine CHOL_CMP2
!   in module Lin_Procedures . 
!                                                                              
! LATEST REVISION : 11/06/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, zero, one, c10, true, false,  &
                         chol_cmp2, 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
!
    integer(i4b), parameter :: prtunit=6, n=4000, m=n+10
!
    real(stnd), parameter :: fudge=c10
!
    character(len=*), parameter :: name_proc='Example 1 of chol_cmp2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, eps, d1, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, a2, ainv, c
    real(stnd), dimension(:),   allocatable :: invdiag
!
    integer(i4b) :: j
    integer      :: iok, istart, iend, irate, imax, itime
!
    logical(lgl) :: do_test, upper
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : COMPUTE THE INVERSE OF A REAL n-BY-n SYMMETRIC POSITIVE DEFINITE
!               MATRIX a BY USING THE CHOLESKY DECOMPOSITION.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*sqrt( epsilon( err ) )
    err = zero
!
    do_test = false
    upper   = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( c(m,n), a(n,n), ainv(n,n), invdiag(n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-by-n RANDOM SYMMETRIC POSITIVE DEFINITE MATRIX a .
!
    call random_number( c )
!
    a = matmul( transpose(c), c )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAY.
!
        allocate( a2(n,n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       MAKE A COPY OF THE SYMMETRIC POSITIVE DEFINITE 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 )
!
!   COMPUTE THE INVERSE OF A SYMMETRIC POSITIVE DEFINITE
!   MATRIX a BY USING THE CHOLESKY DECOMPOSITION OF a.
!
!   IF ON OUTPUT OF chol_cmp2 d1 IS DIFFERENT FROM ZERO
!   THEN THE SYMMETRIC MATRIX IS NOT SINGULAR AND THE
!   SYMMETRIC INVERSE OF a HAS BEEN COMPUTED.
!
    call chol_cmp2( a, invdiag, d1, matinv=ainv, upper=upper, fill=true )
!
!   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 ( d1==zero ) then
!
!       ANORMAL EXIT IN chol_cmp2 SUBROUTINE, PRINT A WARNING.
!
        write (prtunit,*) 'Error in the call to CHOL_CMP2 subroutine, d1=', d1
!
    else if ( do_test ) then
!
!       COMPUTE a TIMES ITS INVERSE - IDENTITY.
!
        c(:n,:n) = matmul( a2, ainv )
!
        do j = 1_i4b, n
!
            c(j,j) = c(j,j) - one
!
        end do
!
!       CHECK THE RESULTS FOR SMALL RESIDUALS.
!
        err = norm( c(:n,:n) ) /( real(n,stnd)*norm(a2(:n,:n)) )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( do_test ) then
        deallocate( a, ainv, c, invdiag, a2 )
    else
        deallocate( a, ainv, c, invdiag )
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. d1/=zero ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing the inverse of a positive definite symmetric matrix of size ', &
       n, ' by ', n, ' is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_chol_cmp2
! ============================
!
end program ex1_chol_cmp2

ex1_comp_cor.F90

program ex1_comp_cor
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine COMP_COR
!   in module Mul_Stat_Procedures .
!                                                                              
! LATEST REVISION : 26/06/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, lgl, true, comp_cor
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=26, m=20, p=50
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                      :: err_xstat, err_ystat, err_cor, xyn, eps
    real(stnd), dimension(n,m)      :: xycor1, xycor2
    real(stnd), dimension(2)        :: ystat1, ystat2
    real(stnd), dimension(n,m,2)    :: xstat1, xstat2
    real(stnd), dimension(n,m,p)    :: x
    real(stnd), dimension(p)        :: y
!
    integer(i4b) :: i
!
    logical(lgl) :: first, last
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of comp_cor'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
    eps = sqrt( epsilon(eps) )
!
!   GENERATE A RANDOM TRIDIMENSIONAL OBSERVATION ARRAY x .
!
    call random_number( x(:n,:m,:p) )
!
!   GENERATE A RANDOM OBSERVATION VECTOR y .
!
    call random_number( y(:p) )
!
!   COMPUTE THE CORRELATIONS BETWEEN x AND y
!   FOR THE p OBSERVATIONS .
!
    first = true
    last  = true
    call comp_cor( x(:n,:m,:p), y(:p), first, last,                    &
                   xstat1(:n,:m,:2), ystat1(:2), xycor1(:n,:m), xyn )
!
!   ON EXIT OF COMP_COR WHEN last=true :
!
!      xstat1(i,j,1) CONTAINS THE MEAN VALUES OF THE ARRAY SECTION x(i,j,:p).
!
!      xstat1(i,j,2) CONTAINS THE VARIANCES OF THE ARRAY SECTION x(i,j,:p).
!
!      ystat1(1)     CONTAINS THE MEAN VALUE OF THE DATA VECTOR y(:p).
!
!      ystat1(2)     CONTAINS THE VARIANCE OF THE DATA VECTOR y(:p).
!
!      xycor1(i,j)   CONTAINS THE CORRELATION COEFFICIENT
!                    BETWEEN x(i,j,:p) AND y(:p).
!
!      xyn           CONTAINS THE NUMBER OF OBSERVATIONS IN THE DATA ARRAY
!                    x(:n,:m,:p) AND THE DATA VECTOR y(:p) (xyn=real(p,stnd) ).
!
!   COMPUTE CORRELATIONS BETWEEN x AND y,
!   ITERATIVELY  FOR THE p OBSERVATIONS .
!
    do i = 1, p
!
        first = i==1
        last  = i==p
!
        call comp_cor( x(:n,:m,i:i), y(i:i), first, last,                    &
                       xstat2(:n,:m,:2), ystat2(:2), xycor2(:n,:m), xyn )
    end do
!
!   CHECK THAT THE TWO SETS OF STATISTICS AGREE.
!
    err_xstat = maxval( abs( ( xstat1-xstat2)/xstat1 ) )
    err_ystat = maxval( abs( ( ystat1-ystat2)/ystat1 ) )
    err_cor   = maxval( abs( xycor1-xycor2 ) )
!
    if ( max(err_xstat, err_ystat, err_cor )<=eps ) then
        write (prtunit,*) 'Example 1 of COMP_COR is correct'
    else
        write (prtunit,*) 'Example 1 of COMP_COR is incorrect'
    end if
!
!
! END OF PROGRAM ex1_comp_cor
! ===========================
!
end program ex1_comp_cor

ex1_comp_cor_miss.F90

program ex1_comp_cor_miss
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine COMP_COR_MISS
!   in module Mul_Stat_Procedures .
!                                                                              
! LATEST REVISION : 26/06/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, lgl, true, comp_cor_miss
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT.
!
    integer(i4b), parameter :: prtunit=6, n=26, m=20, p=50
!
! miss IS THE MISSING INDICATOR.
!
    real(stnd), parameter :: miss=-999.99_stnd
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                      :: err_xstat, err_ystat, err_cor, eps
    real(stnd), dimension(n,m,4)    :: xycor1, xycor2
    real(stnd), dimension(4)        :: ystat1, ystat2
    real(stnd), dimension(n,m,4)    :: xstat1, xstat2
    real(stnd), dimension(n,m,p)    :: x
    real(stnd), dimension(p)        :: y
!
    integer(i4b) :: i
!
    logical(lgl) :: first, last
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of comp_cor_miss'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
    eps = sqrt( epsilon(eps) )
!
!   GENERATE A RANDOM TRIDIMENSIONAL OBSERVATION ARRAY x WITH MISSING VALUES.
!
    call random_number( x(:n,:m,:p) )
    where ( x(:n,:m,:p)<=0.05_stnd ) x(:n,:m,:p) = miss
!
!   GENERATE A RANDOM OBSERVATION VECTOR y WITH MISSING VALUES.
!
    call random_number( y(:p) )
    where ( y(:p)<=0.05_stnd ) y(:p) = miss
!
!   COMPUTE THE CORRELATIONS BETWEEN x AND y
!   FOR THE p OBSERVATIONS .
!
    first = true
    last  = true
    call comp_cor_miss( x(:n,:m,:p), y(:p), first, last, xstat1(:n,:m,:4),               &
                        ystat1(:4), xycor1(:n,:m,:4), xymiss=miss )
!
!   ON EXIT OF COMP_COR_MISS WHEN last=true :
!
!      xstat1(i,j,1) CONTAINS THE MEAN VALUES OF THE ARRAY SECTION x(i,j,:p).
!
!      xstat1(i,j,2) CONTAINS THE VARIANCES OF THE ARRAY SECTION x(i,j,:p).
!
!      xstat1(i,j,3) CONTAINS THE NUMBER OF NON-MISSING OBSERVATIONS
!                    IN THE ARRAY SECTION x(i,j,:p).
!
!      ystat1(1)     CONTAINS THE MEAN VALUE OF THE DATA VECTOR y(:p).
!
!      ystat1(2)     CONTAINS THE VARIANCE OF THE DATA VECTOR y(:p).
!
!      ystat1(3)     CONTAINS THE NUMBER OF NON-MISSING OBSERVATIONS
!                    IN THE DATA VECTOR y(:p).
!
!      xycor1(i,j,1) CONTAINS THE CORRELATION COEFFICIENT BETWEEN x(i,j,:p) AND y(:p)
!                    COMPUTED WITH THE ABOVE UNIVARIATE STATISTICS.
!
!      xycor1(i,j,2) CONTAINS THE INCIDENCE VALUE BETWEEN x(i,j,:p) AND y(:p).
!                    xycor1(i,j,2) INDICATES THE NUMBER OF VALID PAIRS OF OBSERVATIONS
!                    WHICH WHERE USED IN THE CALCULATION OF xycor1(i,j,1) .
!
!   xstat1(:,:,4), ystat1(4) AND xycor1(:,:,3:4) ARE USED AS WORKSPACE AND CONTAIN NO USEFUL
!   INFORMATION ON OUTPUT OF comp_cor_miss.
!
!   COMPUTE CORRELATIONS BETWEEN x AND y,
!   ITERATIVELY  FOR THE p OBSERVATIONS .
!
    do i = 1, p
!
        first = i==1
        last  = i==p
!
        call comp_cor_miss( x(:n,:m,i:i), y(i:i), first, last, xstat2(:n,:m,:4),       &
                            ystat2(:4), xycor2(:n,:m,:4), xymiss=miss )
    end do
!
!   CHECK THAT THE TWO SETS OF STATISTICS AGREE.
!
    err_xstat = maxval( abs( ( xstat1(:n,:m,:3)-xstat2(:n,:m,:3))/xstat1(:n,:m,:3) ) )
    err_ystat = maxval( abs( ( ystat1(:3)-ystat2(:3))/ystat1(:3) ) )
    err_cor   = maxval( abs( xycor1(:n,:m,:2)-xycor2(:n,:m,:2) ) )
!
    if ( max(err_xstat, err_ystat, err_cor )<=eps ) then
        write (prtunit,*) 'Example 1 of COMP_COR_MISS is correct'
    else
        write (prtunit,*) 'Example 1 of COMP_COR_MISS is incorrect'
    end if
!
!
! END OF PROGRAM ex1_comp_cor_miss
! ================================
!
end program ex1_comp_cor_miss

ex1_comp_cor_miss2.F90

program ex1_comp_cor_miss2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine COMP_COR_MISS2
!   in module Mul_Stat_Procedures .
!                                                                              
! LATEST REVISION : 26/06/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, lgl, true, comp_cor_miss2
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT.
!
    integer(i4b), parameter :: prtunit=6, n=26, m=20, p=50
!
! miss IS THE MISSING INDICATOR.
!
    real(stnd), parameter :: miss=-999.99_stnd
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                    :: err_xstat, err_ystat, err_cor, eps
    real(stnd), dimension(n,m)    :: xycor1, xycor2, xyn
    real(stnd), dimension(n,m,2)  :: xstat1, xstat2, ystat1, ystat2
    real(stnd), dimension(n,m,p)  :: x
    real(stnd), dimension(p)      :: y
!
    integer(i4b) :: i
!
    logical(lgl) :: first, last
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of comp_cor_miss2'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
    eps = sqrt( epsilon(eps) )
!
!   GENERATE A RANDOM TRIDIMENSIONAL OBSERVATION ARRAY x WITH MISSING VALUES.
!
    call random_number( x(:n,:m,:p) )
    where ( x(:n,:m,:p)<=0.05_stnd ) x(:n,:m,:p) = miss
!
!   GENERATE A RANDOM OBSERVATION VECTOR y WITH MISSING VALUES.
!
    call random_number( y(:p) )
    where ( y(:p)<=0.05_stnd ) y(:p) = miss
!
!   COMPUTE THE CORRELATIONS BETWEEN x AND y
!   FOR THE p OBSERVATIONS .
!
    first = true
    last  = true
    call comp_cor_miss2( x(:n,:m,:p), y(:p), first, last, xstat1(:n,:m,:2),               &
                        ystat1(:n,:m,:2), xycor1(:n,:m), xyn(:n,:m), xymiss=miss )
!
!   ON EXIT OF COMP_COR_MISS2 WHEN last=true :
!
!      xstat1(i,j,1) CONTAINS THE MEAN VALUES OF THE ARRAY SECTION x(i,j,:p),
!                    COMPUTED FROM VALID PAIRS OF OBSERVATIONS FOR  x(i,j,:p) AND y(:p).
!
!      xstat1(i,j,2) CONTAINS THE VARIANCES OF THE ARRAY SECTION x(i,j,:p),
!                    COMPUTED FROM VALID PAIRS OF OBSERVATIONS FOR  x(i,j,:p) AND y(:p).
!
!      ystat1(i,j,1) CONTAINS THE MEAN VALUE OF THE DATA VECTOR y(:p),
!                    COMPUTED FROM VALID PAIRS OF OBSERVATIONS FOR  x(i,j,:p) AND y(:p).
!
!      ystat1(i,j,2) CONTAINS THE VARIANCE OF THE DATA VECTOR y(:p),
!                    COMPUTED FROM VALID PAIRS OF OBSERVATIONS FOR  x(i,j,:p) AND y(:p).
!
!      xycor1(i,j)   CONTAINS THE CORRELATION COEFFICIENT BETWEEN x(i,j,:p) AND y(:p)
!                    COMPUTED WITH THE ABOVE UNIVARIATE STATISTICS.
!
!      xyn(i,j)      CONTAINS THE INCIDENCE VALUE BETWEEN x(i,j,:p) AND y(:p).
!                    xycor1(i,j) INDICATES THE NUMBER OF VALID PAIRS OF OBSERVATIONS
!                    WHICH WHERE USED IN THE CALCULATION OF ALL THE ABOVE STATISTICS .
!
!
!   COMPUTE CORRELATIONS BETWEEN x AND y,
!   ITERATIVELY  FOR THE p OBSERVATIONS .
!
    do i = 1, p
!
        first = i==1
        last  = i==p
!
        call comp_cor_miss2( x(:n,:m,i:i), y(i:i), first, last, xstat2(:n,:m,:2),        &
                            ystat2(:n,:m,:2), xycor2(:n,:m), xyn(:n,:m), xymiss=miss )
    end do
!
!   CHECK THAT THE TWO SETS OF STATISTICS AGREE.
!
    err_xstat = maxval( abs( ( xstat1(:n,:m,:2)-xstat2(:n,:m,:2))/xstat1(:n,:m,:2) ) )
    err_ystat = maxval( abs( ( ystat1(:n,:m,:2)-ystat2(:n,:m,:2))/ystat1(:n,:m,:2) ) )
    err_cor   = maxval( abs( xycor1(:n,:m)-xycor2(:n,:m) ) )
!
    if ( max(err_xstat, err_ystat, err_cor )<=eps ) then
        write (prtunit,*) 'Example 1 of COMP_COR_MISS2 is correct'
    else
        write (prtunit,*) 'Example 1 of COMP_COR_MISS2 is incorrect'
    end if
!
!
! END OF PROGRAM ex1_comp_cor_miss2
! =================================
!
end program ex1_comp_cor_miss2

ex1_comp_cormat.F90

program ex1_comp_cormat
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine COMP_CORMAT
!   in module Mul_Stat_Procedures .
!                                                                              
! LATEST REVISION : 26/06/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, lgl, true, false, comp_cormat
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, m=20, p=500
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                         :: err_mean, err_std, err_cor, eps, xn
    real(stnd), dimension(m,m)         :: cor1, cor2
    real(stnd), dimension(m,p)         :: x
    real(stnd), dimension(m)           :: mean1, mean2, std1, std2
!
    integer(i4b) :: i
!
    logical(lgl) :: first, last, cov, fill
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of comp_cormat'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
    eps = sqrt( epsilon(eps) )
!
!   GENERATE A RANDOM OBSERVATION ARRAY x .
!
    call random_number( x )
!
    cov  = false
    fill = true
!
!   COMPUTE THE MEANS, STANDARD-DEVIATIONS AND CORRELATION MATRIX
!   OF x FOR THE p OBSERVATIONS .
!
    first = true
    last  = true
    call comp_cormat( x(:m,:p), first, last, mean1(:m), cor1(:m,:m), xn,    &
                      xstd=std1(:m), cov=cov, fill=fill )
!
!   ON EXIT, WHEN last=true :
!
!     mean1(:m) CONTAINS THE VARIABLE MEANS COMPUTED FROM ALL OBSERVATIONS 
!     IN THE DATA MATRIX x.
!
!     cor1(:m,:m) CONTAINS THE UPPER TRIANGLE OF THE SYMETRIC CORRELATION
!     OR VARIANCE-COVARIANCE MATRIX AS CONTROLLED BY THE cov ARGUMENT.
!     IF THE OPTIONAL ARGUMENT fill IS PRESENT AND EQUAL TO true,
!     THE LOWER TRIANGLE OF cor1 IS ALSO FILLED. OTHERWISE, THE LOWER TRIANGLE
!     OF cor1 IS NOT MODIFIED.
!
!     xn INDICATES THE NUMBERS OF OBSERVATIONS WHICH WERE 
!     USED IN THE CALCULATION OF cor1
!
!     IF THE OPTIONAL ARGUMENT xstd IS PRESENT, xstd CONTAINS THE VARIABLE 
!     STANDARD-DEVIATIONS.
!
!   COMPUTE THE MEANS, STANDARD-DEVIATIONS AND CORRELATION MATRIX
!   OF x, ITERATIVELY  FOR THE p OBSERVATIONS .
!
    do i = 1, p
!
        first = i==1
        last  = i==p
!
        call comp_cormat( x(:m,i:i), first, last, mean2(:m), cor2(:m,:m), xn,    &
                         xstd=std2(:m), cov=cov, fill=fill )
    end do
!
!   CHECK THAT THE TWO SETS OF STATISTICS AGREE.
!
    err_mean = maxval( abs( ( mean1-mean2)/mean1 ) )
    err_std  = maxval( abs( ( std1-std2)/std1    ) )
    err_cor  = maxval( abs( cor1-cor2 ) )
!
    if ( max(err_mean, err_std, err_cor )<=eps ) then
        write (prtunit,*) 'Example 1 of COMP_CORMAT is correct'
    else
        write (prtunit,*) 'Example 1 of COMP_CORMAT is incorrect'
    end if
!
!
! END OF PROGRAM ex1_comp_cormat
! ==============================
!
end program ex1_comp_cormat

ex1_comp_cormat_miss.F90

program ex1_comp_cormat_miss
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine COMP_CORMAT_MISS
!   in module Mul_Stat_Procedures .
!                                                                              
! LATEST REVISION : 26/06/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, lgl, true, false, comp_cormat_miss
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, m=20, p=500, n=(m*(m+1))/2
!
! miss IS THE MISSING INDICATOR.
!
    real(stnd), parameter :: miss=-999.99_stnd
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                         :: err_mean, err_std, err_cor, eps
    real(stnd), dimension(m,m)         :: cor1, cor2
    real(stnd), dimension(m,p)         :: x
    real(stnd), dimension(n,3)         :: xn
    real(stnd), dimension(m,2)         :: mean1, mean2
    real(stnd), dimension(m)           :: std1, std2
!
    integer(i4b) :: i
!
    logical(lgl) :: first, last, cov, fill
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of comp_cormat_miss'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
    eps = sqrt( epsilon(eps) )
!
!   GENERATE A RANDOM OBSERVATION ARRAY x WITH MISSING VALUES.
!
    call random_number( x(:m,:p) )
    where ( x(:m,:p)<=0.05_stnd ) x(:m,:p) = miss
!
    cov  = false
    fill = true
!
!   COMPUTE THE MEANS, STANDARD-DEVIATIONS AND CORRELATION MATRIX
!   OF x FOR THE p OBSERVATIONS .
!
    first = true
    last  = true
    call comp_cormat_miss( x(:m,:p), first, last, mean1(:m,:2), cor1(:m,:m), xn(:n,:3), miss,   &
                           xstd=std1(:m), cov=cov, fill=fill )
!
!   ON EXIT, WHEN last=true :
!
!     mean1(:m,1) CONTAINS THE VARIABLE MEANS COMPUTED FROM ALL NON-MISSING OBSERVATIONS 
!     IN THE DATA MATRIX x. mean1(:m,2) IS USED AS WORKSPACE.
!
!     cor1(:m,:m) CONTAINS THE UPPER TRIANGLE OF THE SYMETRIC CORRELATION
!     OR VARIANCE-COVARIANCE MATRIX AS CONTROLLED BY THE cov ARGUMENT.
!     IF THE OPTIONAL ARGUMENT fill IS PRESENT AND EQUAL TO true,
!     THE LOWER TRIANGLE OF cor1 IS ALSO FILLED. OTHERWISE, THE LOWER TRIANGLE
!     OF cor1 IS NOT MODIFIED.
!
!     xn(:n,1) CONTAINS THE UPPER TRIANGLE OF THE MATRIX OF THE INCIDENCE VALUES
!     BETWEEN EACH PAIR OF VARIABLES, PACKED COLUMNWISE, IN A LINEAR ARRAY. 
!     xn(i + (j-1)*j/2,1) INDICATES THE NUMBERS OF NON-MISSING PAIRS WHICH WERE 
!     USED IN THE CALCULATION OF cor1(i,j) for 1<=i<=j .
!     xn(:n,2:3) IS USED AS WORKSPACE.
!
!     IF THE OPTIONAL ARGUMENT xstd IS PRESENT, xstd CONTAINS THE VARIABLE 
!     STANDARD-DEVIATIONS COMPUTED FROM ALL NON-MISSING OBSERVATIONS.
!
!   COMPUTE THE MEANS, STANDARD-DEVIATIONS AND CORRELATION MATRIX
!   OF x, ITERATIVELY  FOR THE p OBSERVATIONS .
!
    do i = 1, p
!
        first = i==1
        last  = i==p
!
        call comp_cormat_miss( x(:m,i:i), first, last, mean2(:m,:2), cor2(:m,:m), xn(:n,:3), miss,   &
                               xstd=std2(:m), cov=cov, fill=fill )
    end do
!
!   CHECK THAT THE TWO SETS OF STATISTICS AGREE.
!
    err_mean = maxval( abs( ( mean1(:m,1)-mean2(:m,1))/mean1(:m,1) ) )
    err_std  = maxval( abs( ( std1(:m)-std2(:m))/std1(:m)    ) )
    err_cor  = maxval( abs( cor1(:m,:m)-cor2(:m,:m) ) )
!
    if ( max(err_mean, err_std, err_cor )<=eps ) then
        write (prtunit,*) 'Example 1 of COMP_CORMAT_MISS is correct'
    else
        write (prtunit,*) 'Example 1 of COMP_CORMAT_MISS is incorrect'
    end if
!
!
! END OF PROGRAM ex1_comp_cormat_miss
! ===================================
!
end program ex1_comp_cormat_miss

ex1_comp_det.F90

program ex1_comp_det
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine COMP_DET
!   in module Lin_Procedures .
!                                                                              
! LATEST REVISION : 04/10/2014
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, lgl, stnd, true, false, zero, one, comp_det, inv, merror, allocate_error
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=500
!
    character(len=*), parameter :: name_proc='Example 1 of comp_det'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: adet, ainvdet, err, eps, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, ainv
!
    integer        :: iok, istart, iend, irate
!
    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 : COMPUTE THE DETERMINANT OF A REAL MATRIX.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = sqrt( epsilon( err ) )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,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 )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAY .
!
        allocate( ainv(n,n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE THE MATRIX INVERSE OF a.
!
        ainv = inv( a ) 
!
!       COMPUTE THE DETERMINANT OF MATRIX INVERSE .
!
        call comp_det( ainv, ainvdet )
!
!       DEALLOCATE WORK ARRAY.
!
        deallocate( ainv )
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count=istart, count_rate=irate )
!
!   COMPUTE THE DETERMINANT OF THE DATA MATRIX WITH SUBROUTINE comp_det.
!
    call comp_det( a, adet )
!
!   STOP THE TIMER.
!
    call system_clock( count=iend )
!
    elapsed_time = real( iend - istart, stnd )/real( irate, stnd )
!
    if ( do_test ) then
!
!       CHECK det(a**-1)*det(a)**-1 = 1.
!
        err = abs(adet*ainvdet - one) / max( abs(adet), abs(ainvdet) )
!
    end if
!
!   DEALLOCATE WORK ARRAY.
!
    deallocate( a )
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    write (prtunit,*)
    write (*,'(a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing the determinant of a real matrix of size ', &
       n, ' is', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_comp_det
! ===========================
!
end program ex1_comp_det

ex1_comp_eof.F90

program ex1_comp_eof
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines COMP_EOF
!   and COMP_PC_EOF in module Mul_Stat_Procedures .
!                                                                              
! LATEST REVISION : 26/06/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, lgl, true, false, one, comp_eof, comp_pc_eof
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, m=20, p=50
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                         :: err_pc, xn
    real(stnd), dimension(m,m)         :: eigvec
    real(stnd), dimension(m)           :: mean, std, eigval, eigvar, singval
    real(stnd), dimension(m,p)         :: x, x_std
    real(stnd), dimension(p,m)         :: pc
!
    logical(lgl) :: first, last, failure
!
    character    :: sort = 'd'
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of comp_eof'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A RANDOM OBSERVATION MATRIX x(:m,:p) WITH m VARIABLES
!   AND p OBSERVATIONS.
!
    call random_number( x )
!
!   COMPUTE EOFs FROM THE CORRELATION MATRIX .
!
    first = true
    last  = true
!
    call comp_eof( x(:m,:p), first, last, eigval(:m), eigvec(:m,:m), xn, failure,   &
                   sort=sort, xmean=mean(:m), xstd=std(:m), xeigvar=eigvar(:m)      )
!
!   ON EXIT OF COMP_EOF WHEN last=true :
!
!      eigval(:m)       CONTAINS THE EIGENVALUES.
!
!      eigvec(:m,:m)    CONTAINS THE EIGENVECTORS STORED COLUMNWISE IN THE ORDER
!                       OF THE EIGENVALUES STORED IN eigval.
!
!      xn               CONTAINS THE NUMBER OF OBSERVATIONS IN THE DATA ARRAY x,
!                       xn = real(p,stnd) .
!
!      failure = false  INDICATES SUCCESSFUL EXIT.
!      failure = true   INDICATES THAT FEWER THAN TWO VALID OBSERVATIONS
!                       WERE PRESENT OR THAT THE OBSERVATIONS ON SOME
!                       VARIABLE WERE CONSTANT AND THE CORRELATIONS
!                       WERE REQUESTED OR THAT MAXIMUM ACCURACY WAS NOT
!                       ACHIEVED WHEN COMPUTING THE EIGENVECTORS AND THE
!                       EIGENVALUES.
!
!      mean(:m)         CONTAINS THE MEAN VALUES OF THE m VARIABLES.
!
!      std(:m)          CONTAINS THE STANDARD-DEVIATIONS OF THE m VARIABLES.
!
!      eigvar(:m)       CONTAINS PERCENTAGES OF TOTAL VARIANCE ASSOCIATED 
!                       WITH THE EIGENVECTORS IN THE ORDER OF THE EIGENVALUES
!                       STORED IN eigval.
!
!
!   COMPUTE THE PRINCIPAL COMPONENTS FROM THE DATA AND THE EIGENVECTORS.
!
!   IN ORDER TO COMPUTE NORMALIZED PCs, SET singval(:m) = sqrt(eigval(:m)),
!   OTHERWISE SET singval(:) = one .
!
    singval(:) = one
!
!   THE OPTIONAL PARAMETERS xmean AND xstd ARE REQUIRED IF THE EIGENVECTORS
!   HAVE BEEN COMPUTED FROM THE CORRRELATION MATRIX.
!
    call comp_pc_eof( x(:m,:p), eigvec(:m,:m), singval(:m), pc(:p,:m),   &
                      xmean=mean(:m), xstd=std(:m)                       )
!
!   ON EXIT OF COMP_PC_EOF  :
!
!      pc(:p,:m) CONTAINS THE PRINCIPAL COMPONENTS STORED COLUMNWISE.
!
!
!   CHECK FOR SMALL RESIDUALS OF THE EXPRESSION x_std**t*eigvec - pc
!   WHERE eigvec ARE THE EIGENVECTORS, x_std THE STANDARDIZED DATA
!   AND pc THE UNNORMALIZED PRINCIPAL COMPONENTS.
!
    x_std(:m,:p) = x(:m,:p) - spread( mean(:m) ,      dim=2, ncopies=p )
    x_std(:m,:p) = x_std(:m,:p)*spread( one/std(:m) , dim=2, ncopies=p ) 
!
    err_pc =  sum( abs(matmul(transpose(x_std),eigvec)-pc) )/sum( eigval )
!
!   PRINT THE RESULT OF THE TEST.
!
    if ( err_pc<=sqrt( epsilon(err_pc) ) ) then
        write (prtunit,*) 'Example 1 of COMP_EOF is correct'
    else
        write (prtunit,*) 'Example 1 of COMP_EOF is incorrect'
    end if
!
!
! END OF PROGRAM ex1_comp_eof
! ===========================
!
end program ex1_comp_eof

ex1_comp_eof2.F90

program ex1_comp_eof2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines COMP_EOF2
!   and COMP_PC_EOF in module Mul_Stat_Procedures .
!                                                                              
! LATEST REVISION : 26/06/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, lgl, true, false, one, comp_eof2, comp_pc_eof
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, m=20, mm=(m*(m+1))/2, p=50, neig=3
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                         :: err_pc, xn
    real(stnd), dimension(m)           :: mean, std, eigval, eigvar, singval
    real(stnd), dimension(mm)          :: corp
    real(stnd), dimension(m,p)         :: x, x_std
    real(stnd), dimension(m,neig)      :: eigvec
    real(stnd), dimension(p,neig)      :: pc
!
    integer(i4b) :: maxiter=4
!
    logical(lgl) :: first, last, failure
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of comp_eof2'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A RANDOM OBSERVATION MATRIX x(:m,:p) WITH m VARIABLES
!   AND p OBSERVATIONS.
!
    call random_number( x )
!
!   COMPUTE neig EOFs FROM THE CORRELATION MATRIX BY INVERSE ITERATION.
!
    first = true
    last  = true
!
    call comp_eof2( x(:m,:p), first, last, eigval(:m), corp(:mm), xn, failure,   &
                    maxiter=maxiter, xmean=mean(:m), xstd=std(:m),               &
                    xeigvar=eigvar(:m), xeigvec=eigvec(:m,:neig)                 )
!
!   ON EXIT OF COMP_EOF2 WHEN last=true :
!
!      eigval(:m)       CONTAINS THE EIGENVALUES.
!
!      failure = false  INDICATES SUCCESSFUL EXIT.
!      failure = true   INDICATES THAT FEWER THAN TWO VALID OBSERVATIONS
!                       WERE PRESENT OR THAT THE OBSERVATIONS ON SOME
!                       VARIABLE WERE CONSTANT AND THE CORRELATIONS
!                       WERE REQUESTED OR THAT MAXIMUM ACCURACY WAS NOT
!                       ACHIEVED WHEN COMPUTING THE EIGENVALUES OR THAT
!                       SOME EIGENVECTORS FAILED TO CONVERGE WITH maxiter
!                       INVERSE ITERATIONS.
!
!      xn               CONTAINS THE NUMBER OF OBSERVATIONS IN THE DATA ARRAY x,
!                       xn = real(p,stnd) .
!
!      mean(:m)         CONTAINS THE MEAN VALUES OF THE m VARIABLES.
!
!      std(:m)          CONTAINS THE STANDARD-DEVIATIONS OF THE m VARIABLES.
!
!      eigvar(:m)       CONTAINS PERCENTAGES OF TOTAL VARIANCE ASSOCIATED 
!                       WITH THE EIGENVECTORS IN THE ORDER OF THE EIGENVALUES
!                       STORED IN eigval.
!
!      eigvec(:m,:neig) CONTAINS THE FIRST neig EIGENVECTORS STORED COLUMNWISE
!                       IN THE ORDER OF THE EIGENVALUES STORED IN eigval.
!
!
!   COMPUTE THE PRINCIPAL COMPONENTS FROM THE DATA AND THE EIGENVECTORS.
!
!   IN ORDER TO COMPUTE NORMALIZED PCs, SET singval(:m) = sqrt(eigval(:m)),
!   OTHERWISE SET singval(:) = one .
!
    singval(:) = one
!
!   THE OPTIONAL PARAMETERS xmean AND xstd ARE REQUIRED IF THE EIGENVECTORS
!   HAVE BEEN COMPUTED FROM THE CORRRELATION MATRIX.
!
    call comp_pc_eof( x(:m,:p), eigvec(:m,:neig), singval(:neig), pc(:p,:neig),   &
                      xmean=mean(:m), xstd=std(:m)                                )
!
!   ON EXIT OF COMP_PC_EOF  :
!
!      pc(:p,:neig) CONTAINS THE FIRST neig PRINCIPAL COMPONENTS STORED COLUMNWISE.
!
!
!   CHECK FOR SMALL RESIDUALS OF THE EXPRESSION x_std**t*eigvec - pc
!   WHERE eigvec ARE THE EIGENVECTORS, x_std THE STANDARDIZED DATA
!   AND pc THE UNNORMALIZED PRINCIPAL COMPONENTS.
!
    x_std(:m,:p) = x(:m,:p) - spread( mean(:m) ,      dim=2, ncopies=p )
    x_std(:m,:p) = x_std(:m,:p)*spread( one/std(:m) , dim=2, ncopies=p ) 
!
    err_pc =  sum( abs(matmul(transpose(x_std),eigvec)-pc) )/sum( eigval(:neig) )
!
!   PRINT THE RESULT OF THE TEST.
!
    if ( err_pc<=sqrt( epsilon(err_pc) ) ) then
        write (prtunit,*) 'Example 1 of COMP_EOF2 is correct'
    else
        write (prtunit,*) 'Example 1 of COMP_EOF2 is incorrect'
    end if
!
!
! END OF PROGRAM ex1_comp_eof2
! ============================
!
end program ex1_comp_eof2

ex1_comp_ginv.F90

program ex1_comp_ginv
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine COMP_GINV
!   in module SVD_Procedures. 
!                                                                              
! LATEST REVISION : 18/06/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, comp_ginv, norm, &
                         c10, 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
!
    integer(i4b), parameter :: prtunit=6, m=4000, n=2000, k=min(m,n)
!   
    real(stnd), parameter  :: fudge=c10
!
    character(len=*), parameter :: name_proc='Example 1 of comp_ginv'
!   
!   
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: eps, err, err1, err2, err3, err4, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, a2, ainv, ainv2, a_by_ainv, ainv_by_a
!
    integer :: iok, istart, iend, irate, imax, itime
!
    logical(lgl)   :: failure, 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 : COMPUTING THE GENERALIZED INVERSE OF A m-BY-n REAL MATRIX USING
!               THE SINGULAR VALUE DECOMPOSITION (SVD) OF THE MATRIX. THE SVD IS COMPUTED
!               BY THE BIDIAGONAL QR IMPLICIT METHOD WITH A WAVE-FRONT ALGORITHM FOR
!               APPLYING GIVENS ROTATIONS IN THE BIDIAGONAL QR ALGORITHM AND,
!               OPTIONALLY, A PERFECT SHIFT FOR THE SINGULAR VECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*sqrt( epsilon(eps) )
    err = zero
!
    do_test = false
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(m,n), ainv(n,m), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM DATA MATRIX.
!
    call random_number( a )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( a2(m,n), ainv2(n,m), a_by_ainv(m,m),   &
                  ainv_by_a(n,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 GENERALIZED INVERSE OF a(:m,:n) WITH SUBROUTINE comp_ginv.
!   THE GENERALIZED INVERSE IS COMPUTED WITH THE HELP OF THE SINGULAR
!   VALUE DECOMPOSITION (SVD) OF a(:m,:n).
!
    call comp_ginv( a, failure, ainv )
!
!   THE ROUTINE RETURNS THE GENERALIZED INVERSE OF a(:m,:n).
!
!   ON EXIT OF comp_ginv :
!
!       failure= false :  INDICATES SUCCESSFUL EXIT.
!       failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                         THAT FULL ACCURACY WAS NOT ATTAINED IN THE BIDIAGONAL
!                         SVD OF AN INTERMEDIATE BIDIAGONAL FORM B OF a.
!
!   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 ( do_test ) then
!
!       COMPUTE ainv*a AND a*ainv*a .
!
        ainv_by_a = matmul( ainv, a2 )
        a = matmul( a2, ainv_by_a )
!
!       COMPUTE a*ainv AND ainv*a*ainv .
!
        a_by_ainv = matmul( a2, ainv )
        ainv2 = matmul( ainv, a_by_ainv )
!
!       CHECK THE Moore-Penrose EQUATIONS :
!
!             a*ainv*a = a            (1)
!          ainv*a*ainv = ainv         (2)
!            (a*ainv)' = a*ainv       (3)
!            (ainv*a)' = ainv*a       (4)
!
        err1 = norm( a - a2 )
        err2 = norm( ainv - ainv2 )
        err3 = norm( a_by_ainv - transpose(a_by_ainv) )
        err4 = norm( ainv_by_a - transpose(ainv_by_a) )
!
        err = max( err1, err2, err3, err4 )/ ( real(k,stnd)*norm(a) )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a2, ainv2, a_by_ainv, ainv_by_a )        
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, ainv )
!
    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 (*,'(a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing the generalized inverse of a ', &
       m, ' by ', n,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_comp_ginv
! ============================
!
end program ex1_comp_ginv

ex1_comp_inv.F90

program ex1_comp_inv
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine COMP_INV
!   in module Lin_Procedures . 
!                                                                              
! LATEST REVISION : 18/06/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    USE Statpack, ONLY : lgl, i4b, stnd, true, false, zero, one, comp_inv,   &
                         norm, merror, allocate_error
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=4000
!
    character(len=*), parameter :: name_proc='Example 1 of comp_inv'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, eps, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, ainv, res
!
    integer(i4b) :: j
    integer      :: iok, istart, iend, irate, imax, itime
!
    logical(lgl) :: do_test, failure
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : COMPUTE IN PLACE THE INVERSE OF A REAL n-BY-n MATRIX.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = sqrt( epsilon( err ) )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAY.
!
    allocate( ainv(n,n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
! 
!   GENERATE A RANDOM REAL MATRIX.
!
    call random_number( ainv )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAY.
!
        allocate( a(n,n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
! 
!       SAVE THE RANDOM REAL MATRIX.
!
        a(:n,:n) = ainv(:n,:n)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   COMPUTE THE MATRIX INVERSE WITH SUBROUTINE comp_inv.
!   INPUT ARGUMENT OVERWRITTEN.
!
    call comp_inv( ainv, failure )
!
!   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 ( failure ) then
!
!       ANORMAL EXIT FROM comp_inv SUBROUTINE, PRINT A WARNING.
!
        write (prtunit,*) 'Error in exit of COMP_INV subroutine, failure=', failure
        write (prtunit,*)
!
    else if ( do_test ) then
!
!       ALLOCATE WORK ARRAY.
!
        allocate( res(n,n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE a TIMES ITS INVERSE - IDENTITY.
!
        res = matmul( a, ainv )
!
        do j = 1_i4b, n
            res(j,j) = res(j,j) - one
        end do
!
        err = norm( res(:n,:n) ) /( real(n,stnd)*norm(a(:n,:n)) )
!
!       DEALLOCATE WORK ARRAY.
!
        deallocate( res )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( allocated(a) ) then
        deallocate( ainv, a )
    else
        deallocate( ainv )
    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 (*,'(a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing in place the inverse of a real matrix of size ', &
       n, ' by ', n, ' is', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_comp_inv
! ===========================
!
end program ex1_comp_inv

ex1_comp_mca.F90

program ex1_comp_mca
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines COMP_MCA
!   and COMP_PC_MCA in module Mul_Stat_Procedures .
!                                                                              
! LATEST REVISION : 26/06/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, lgl, true, false, one, comp_mca, comp_pc_mca
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, mx=20, my=10, m=min(mx,my), p=50, mm=(m*(m+1))/2
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                         :: err_xpc, err_ypc, xyn
    real(stnd), dimension(mx,my)       :: xsingvec
    real(stnd), dimension(my,m)        :: ysingvec
    real(stnd), dimension(mx,2)        :: xstat
    real(stnd), dimension(my,2)        :: ystat
    real(stnd), dimension(m)           :: xysingval, xysingvar
    real(stnd), dimension(mm)          :: pccorp_x, pccorp_y
    real(stnd), dimension(mx,m)        :: xpccor
    real(stnd), dimension(my,m)        :: ypccor
    real(stnd), dimension(p,m)         :: xpc, ypc
    real(stnd), dimension(mx,p)        :: x, x_std
    real(stnd), dimension(my,p)        :: y, y_std
!
    logical(lgl) :: first, last, failure
!
    character    :: sort = 'd'
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of comp_mca'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A RANDOM OBSERVATION MATRIX x(:mx,:p) WITH mx VARIABLES
!   AND p OBSERVATIONS.
!
    call random_number( x )
!
!   GENERATE A RANDOM OBSERVATION MATRIX y(:my,:p) WITH my VARIABLES
!   AND p OBSERVATIONS.
!
    call random_number( y )
!
!   COMPUTE LEFT AND RIGHT SINGULAR VECTORS OF THE CORRELATION MATRIX .
!
    first = true
    last  = true
!
    call comp_mca( x, y, first, last, xstat, ystat, xysingval, xsingvec, failure,    &
                   sort=sort, ysingvec=ysingvec, xysingvar=xysingvar  )
!
!   ON EXIT OF COMP_MCA WHEN last=true :
!
!   xstat CONTAINS THE FOLLOWING STATISTICS ON ALL VARIABLES FROM THE x MATRIX:
!            
!       xstat(:,1) CONTAINS THE MEAN VALUES OF THE "LEFT" DATA MATRIX x.
!       xstat(:,2) CONTAINS THE STANDARD-DEVIATIONS OF THE "LEFT" DATA MATRIX x.
!
!   ystat CONTAINS THE FOLLOWING STATISTICS ON ALL VARIABLES FROM THE y MATRIX:
!            
!       ystat(:,1) CONTAINS THE MEAN VALUES OF THE "RIGHT" DATA MATRIX y.
!       ystat(:,2) CONTAINS THE STANDARD-DEVIATIONS OF THE "RIGHT" DATA MATRIX y.
!            
!   xysingval CONTAINS THE m SINGULAR VALUES OF THE CORRELATION
!   (OR COVARIANCE) MATRIX BETWEEN THE DATA MATRICES x AND y.
!
!   xsingvec IS OVERWRITTEN WITH THE FIRST m LEFT SINGULAR VECTORS
!   OF THE CORRELATION (OR COVARIANCE) MATRIX BETWEEN x AND y.
!
!   failure = FALSE :  INDICATES SUCCESSFUL EXIT.
!   failure = TRUE  :  INDICATES THAT FEWER THAN TWO VALID OBSERVATIONS
!                      WERE PRESENT OR THAT MAXIMUM ACCURACY WAS NOT
!                      ACHIEVED WHEN COMPUTING THE SVD OF THE COVARIANCE
!                      (OR CORRELATION) MATRIX BETWEEN THE DATA MATRICES x AND y .
!
!   ysingvec CONTAINS THE FIRST m RIGHT SINGULAR VECTORS OF THE CORRELATION
!            (OR COVARIANCE) MATRIX BETWEEN x AND y.
!
!   xysingvar CONTAINS THE PERCENTAGES OF TOTAL SQUARED COVARIANCE ASSOCIATED 
!             WITH THE LEFT AND RIGHT SINGULAR VECTORS IN ORDER OF THE 
!             SINGULAR VALUES STORED IN xysingval.
!
!
!   NOW, COMPUTE THE LEFT SINGULAR VARIABLES FROM THE DATA AND THE LEFT SINGULAR VECTORS.
!
!   THE OPTIONAL PARAMETERS xmean AND xstd ARE REQUIRED IF THE SINGULAR VECTORS
!   HAVE BEEN COMPUTED FROM THE CORRRELATION MATRIX.
!
    first = true
    last  = true
!
    call comp_pc_mca( x(:mx,:p), xsingvec(:mx,:m), first, last,            &
                      xpccor(:mx,:m), pccorp_x(:mm), xpc(:p,:m), xyn,      &
                      xmean=xstat(:mx,1), xstd=xstat(:mx,2)                )
!
!   ON EXIT OF COMP_PC_MCA WHEN last=true :
!
!     xpccor  CONTAINS :
!                 - THE CORRELATIONS BETWEEN THE DATA MATRIX x
!                   AND THE SINGULAR VARIABLES IF THE OPTIONAL
!                   ARGUMENTS xmean AND xstd ARE PRESENT.
!                 - THE COVARIANCES BETWEEN THE DATA MATRIX x
!                   AND THE NORMALIZED SINGULAR VARIABLES IF ONLY
!                   THE OPTIONAL ARGUMENT xmean IS PRESENT.
!
!     pccorp_x CONTAINS THE CORRELATION MATRIX COR BETWEEN THE SINGULAR VARIABLES
!              STORED IN ARGUMENT xpc. COR IS STORED IN SYMMETRIC STORAGE MODE.
!              MORE PRECISELY, THE J-TH COLUMN OF THIS MATRIX COR IS STORED IN THE 
!              ARRAY pccorp_x AS FOLLOWS:
!
!                         pccorp_x(i + (j-1)*j/2) = COR(i,j) for 1<=i<=j;
!
!     xpc      CONTAINS THE UNNORMALIZED SINGULAR VARIABLES DERIVED
!              FROM x AND xsingvec.
!
!   NOW, COMPUTE THE RIGHT SINGULAR VARIABLES FROM THE DATA AND THE RIGHT SINGULAR VECTORS.
!
    call comp_pc_mca( y, ysingvec(:my,:m), first, last, ypccor, pccorp_y, ypc(:p,:m), xyn,  &
                      xmean=ystat(:my,1), xstd=ystat(:my,2)                                 )
!
!   CHECK FOR SMALL RESIDUALS OF THE EXPRESSION x_std**t*xsingvec - xpc
!   WHERE xsingvec ARE THE LEFT SINGULAR VECTORS, x_std THE STANDARDIZED LEFT DATA
!   AND xpc THE UNNORMALIZED LEFT SINGULAR VARIABLES.
!
    x_std(:mx,:p) = x(:mx,:p) - spread( xstat(:mx,1) ,   dim=2, ncopies=p )
    x_std(:mx,:p) = x_std(:mx,:p)*spread( one/xstat(:mx,2) , dim=2, ncopies=p ) 
!
    err_xpc = sum( abs(matmul(transpose(x_std),xsingvec)-xpc) )/sum( abs(x_std) )
!
!   CHECK FOR SMALL RESIDUALS OF THE EXPRESSION y_std**t*ysingvec - ypc
!   WHERE ysingvec ARE THE RIGHT SINGULAR VECTORS, y_std THE STANDARDIZED RIGHT DATA
!   AND ypc THE UNNORMALIZED RIGHT SINGULAR VARIABLES.
!
    y_std(:my,:p) = y(:my,:p) - spread( ystat(:my,1) ,   dim=2, ncopies=p )
    y_std(:my,:p) = y_std(:my,:p)*spread( one/ystat(:my,2) , dim=2, ncopies=p ) 
!
    err_ypc = sum( abs(matmul(transpose(y_std),ysingvec)-ypc) )/sum( abs(y_std) )
!
!   PRINT THE RESULT OF THE TESTS.
!
    if ( max(err_xpc, err_ypc)<=sqrt( epsilon(err_ypc) ) ) then
        write (prtunit,*) 'Example 1 of COMP_MCA is correct'
    else
        write (prtunit,*) 'Example 1 of COMP_MCA is incorrect'
    end if
!
!
! END OF PROGRAM ex1_comp_mca
! ===========================
!
end program ex1_comp_mca

ex1_comp_mca2.F90

program ex1_comp_mca2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines COMP_MCA2
!   and COMP_PC_MCA in module Mul_Stat_Procedures .
!                                                                              
! LATEST REVISION : 26/06/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, lgl, true, false, one, comp_mca2, comp_pc_mca
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, mx=20, my=10, m=min(mx,my), mxy=mx+my, p=50,   &
                               nsvd=3, nsingp=(nsvd*(nsvd+1))/2
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                         :: err_xpc, err_ypc, xyn
    real(stnd), dimension(mx,my)       :: xycor
    real(stnd), dimension(mxy,nsvd)    :: xysingvec
    real(stnd), dimension(mx,2)        :: xstat
    real(stnd), dimension(my,2)        :: ystat
    real(stnd), dimension(m)           :: xysingval, xysingvar
    real(stnd), dimension(nsingp)      :: pccorp_x, pccorp_y
    real(stnd), dimension(mx,nsvd)     :: xpccor
    real(stnd), dimension(my,nsvd)     :: ypccor
    real(stnd), dimension(p,nsvd)      :: xpc, ypc
    real(stnd), dimension(mx,p)        :: x, x_std
    real(stnd), dimension(my,p)        :: y, y_std
!
    integer(i4b) :: maxiter=3
!
    logical(lgl) :: first, last, failure
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of comp_mca2'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A RANDOM OBSERVATION MATRIX x(:mx,:p) WITH mx VARIABLES
!   AND p OBSERVATIONS.
!
    call random_number( x )
!
!   GENERATE A RANDOM OBSERVATION MATRIX y(:my,:p) WITH my VARIABLES
!   AND p OBSERVATIONS.
!
    call random_number( y )
!
!   COMPUTE the first nsvd LEFT AND RIGHT SINGULAR VECTORS OF THE CORRELATION MATRIX .
!
    first = true
    last  = true
!
    call comp_mca2( x, y, first, last, xstat, ystat, xysingval, xycor, failure,    &
                    maxiter=maxiter, xysingvec=xysingvec, xysingvar=xysingvar  )
!
!   ON EXIT OF COMP_MCA2 WHEN last=true :
!
!   xstat CONTAINS THE FOLLOWING STATISTICS ON ALL VARIABLES FROM THE x MATRIX:
!            
!       xstat(:,1) CONTAINS THE MEAN VALUES OF THE "LEFT" DATA MATRIX x.
!       xstat(:,2) CONTAINS THE STANDARD-DEVIATIONS OF THE "LEFT" DATA MATRIX x.
!
!   ystat CONTAINS THE FOLLOWING STATISTICS ON ALL VARIABLES FROM THE y MATRIX:
!            
!       ystat(:,1) CONTAINS THE MEAN VALUES OF THE "RIGHT" DATA MATRIX y.
!       ystat(:,2) CONTAINS THE STANDARD-DEVIATIONS OF THE "RIGHT" DATA MATRIX y.
!            
!   xysingval CONTAINS THE m SINGULAR VALUES OF THE CORRELATION
!   (OR COVARIANCE) MATRIX BETWEEN THE DATA MATRICES x AND y.
!
!   WHEN OPTIONAL ARGUMENT savecor IS PRESENT AND savecor=TRUE, xycor CONTAINS
!
!       THE CORRELATION OR VARIANCE-COVARIANCE MATRIX AS CONTROLLED BY THE COV ARGUMENT.
!       IN THIS CASE xycor(i,j) CONTAINS THE CORRELATION (OR COVARIANCE) COEFFICIENT
!       BETWEEN x(i,:) AND y(j,:) ( x(:,i) AND y(:,j) IF dimvarx=2 AND
!       dimvary=2 ).
!
!   IF savecor=FALSE OR IS ABSENT, THE CORRELATION (OR COVARIANCE) MATRIX IS NOT SAVED ON EXIT.
!   IN THIS CASE, xycor DOES NOT CONTAIN USEFUL INFORMATION.
!
!   failure = FALSE :  INDICATES SUCCESSFUL EXIT.
!   failure = TRUE  :  INDICATES THAT FEWER THAN TWO VALID OBSERVATIONS
!                      WERE PRESENT OR THAT MAXIMUM ACCURACY WAS NOT
!                      ACHIEVED WHEN COMPUTING THE SVD OF THE COVARIANCE
!                      (OR CORRELATION) MATRIX BETWEEN THE DATA MATRICES x AND y .
!
!   xysingvec CONTAINS THE FIRST nsvd RIGHT SINGULAR VECTORS OF THE CORRELATION
!             (OR COVARIANCE) MATRIX BETWEEN x AND y IN xysingvec(1:mx,:nsvd)
!             AND THE FIRST nsvd LEFT SINGULAR VECTORS IN xysingvec(mx+1:mxy,:nsvd)
!
!   xysingvar CONTAINS THE PERCENTAGES OF TOTAL SQUARED COVARIANCE ASSOCIATED 
!             WITH THE LEFT AND RIGHT SINGULAR VECTORS IN ORDER OF THE 
!             SINGULAR VALUES STORED IN xysingval.
!
!
!   NOW, COMPUTE THE FIRST nsvd LEFT SINGULAR VARIABLES FROM THE DATA AND THE LEFT SINGULAR VECTORS.
!
!   THE OPTIONAL PARAMETERS xmean AND xstd ARE REQUIRED IF THE SINGULAR VECTORS
!   HAVE BEEN COMPUTED FROM THE CORRRELATION MATRIX.
!
    first = true
    last  = true
!
    call comp_pc_mca( x(:mx,:p), xysingvec(:mx,:nsvd), first, last,                  &
                      xpccor(:mx,:nsvd), pccorp_x(:nsingp), xpc(:p,:nsvd), xyn,      &
                      xmean=xstat(:mx,1), xstd=xstat(:mx,2)                          )
!
!   ON EXIT OF COMP_PC_MCA WHEN last=true :
!
!     xpccor  CONTAINS :
!                 - THE CORRELATIONS BETWEEN THE DATA MATRIX x
!                   AND THE SINGULAR VARIABLES IF THE OPTIONAL
!                   ARGUMENTS xmean AND xstd ARE PRESENT.
!                 - THE COVARIANCES BETWEEN THE DATA MATRIX x
!                   AND THE NORMALIZED SINGULAR VARIABLES IF ONLY
!                   THE OPTIONAL ARGUMENT xmean IS PRESENT.
!
!     pccorp_x CONTAINS THE CORRELATION MATRIX COR BETWEEN THE SINGULAR VARIABLES
!              STORED IN ARGUMENT xpc. COR IS STORED IN SYMMETRIC STORAGE MODE.
!              MORE PRECISELY, THE J-TH COLUMN OF THIS MATRIX COR IS STORED IN THE 
!              ARRAY pccorp_x AS FOLLOWS:
!
!                         pccorp_x(i + (j-1)*j/2) = COR(i,j) for 1<=i<=j;
!
!     xpc      CONTAINS THE UNNORMALIZED SINGULAR VARIABLES DERIVED
!              FROM x AND xsingvec.
!
!   NOW, COMPUTE THE FIRST nsvd RIGHT SINGULAR VARIABLES FROM THE DATA AND THE RIGHT SINGULAR VECTORS.
!
    call comp_pc_mca( y(:my,:p), xysingvec(mx+1:mxy,:nsvd), first, last,             &
                      ypccor(:my,:nsvd), pccorp_y(:nsingp), ypc(:p,:nsvd), xyn,      &
                      xmean=ystat(:my,1), xstd=ystat(:my,2)                          )
!
!   CHECK FOR SMALL RESIDUALS OF THE EXPRESSION x_std**t*xsingvec - xpc
!   WHERE xsingvec ARE THE LEFT SINGULAR VECTORS, x_std THE STANDARDIZED LEFT DATA
!   AND xpc THE UNNORMALIZED LEFT SINGULAR VARIABLES.
!
    x_std(:mx,:p) = x(:mx,:p) - spread( xstat(:mx,1) , dim=2, ncopies=p )
    x_std(:mx,:p) = x_std(:mx,:p)*spread( one/xstat(:mx,2) , dim=2, ncopies=p ) 
!
    err_xpc = sum( abs(matmul(transpose(x_std),xysingvec(:mx,:nsvd))-xpc) )/sum( abs(x_std) )
!
!   CHECK FOR SMALL RESIDUALS OF THE EXPRESSION y_std**t*ysingvec - ypc
!   WHERE ysingvec ARE THE RIGHT SINGULAR VECTORS, y_std THE STANDARDIZED RIGHT DATA
!   AND ypc THE UNNORMALIZED RIGHT SINGULAR VARIABLES.
!
    y_std(:my,:p) = y(:my,:p) - spread( ystat(:my,1) , dim=2, ncopies=p )
    y_std(:my,:p) = y_std(:my,:p)*spread( one/ystat(:my,2) , dim=2, ncopies=p ) 
!
    err_ypc = sum( abs(matmul(transpose(y_std),xysingvec(mx+1:mxy,:nsvd))-ypc) )/sum( abs(y_std) )
!
!   PRINT THE RESULT OF THE TESTS.
!
    if ( max(err_xpc, err_ypc)<=sqrt( epsilon(err_xpc) ) ) then
        write (prtunit,*) 'Example 1 of COMP_MCA2 is correct'
    else
        write (prtunit,*) 'Example 1 of COMP_MCA2 is incorrect'
    end if
!
!
! END OF PROGRAM ex1_comp_mca2
! ============================
!
end program ex1_comp_mca2

ex1_comp_mvs.F90

program ex1_comp_mvs
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine COMP_MVS
!   in module Stat_Procedures .
!                                                                              
! LATEST REVISION : 26/06/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, lgl, true, false, comp_mvs
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=26, m=20, p=250
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                      :: err_mean, err_std, err_var, eps
    real(stnd), dimension(n,m)      :: xmean1, xmean2, xstd1, xstd2, xvar1, xvar2
    real(stnd), dimension(n,m,p)    :: x
!
    integer(i4b) :: i
!
    logical(lgl) :: first, last
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of comp_mvs'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
    eps = sqrt( epsilon(eps) )
!
!   GENERATE A RANDOM OBSERVATION ARRAY x .
!
    call random_number( x )
!
!   COMPUTE THE MEANS, VARIANCES AND STANDARD-DEVIATIONS OF x FOR THE p OBSERVATIONS .
!
    first = true
    last  = true
!
    call comp_mvs( x(:,:,:), first, last, xmean1(:,:), xvar1(:,:), xstd1(:,:) )
!
!   COMPUTE THE MEANS, VARIANCES AND STANDARD-DEVIATIONS OF x, ITERATIVELY FOR THE p OBSERVATIONS  .
!
    do i = 1, p
!
        first = i==1
        last  = i==p
!
        call comp_mvs( x(:,:,i:i), first, last, xmean2(:,:), xvar2(:,:), xstd2(:,:) )
    end do
!
!   CHECK THAT THE TWO SETS OF STATISTICS AGREE.
!
    err_mean = maxval( abs( ( xmean1-xmean2)/xmean1 ) )
    err_var  = maxval( abs( ( xvar1-xvar2)/xvar1    ) )
    err_std  = maxval( abs( ( xstd1-xstd2)/xstd1    ) )
!
    if ( max(err_mean, err_var, err_std )<=eps ) then
        write (prtunit,*) 'Example 1 of COMP_MVS is correct'
    else
        write (prtunit,*) 'Example 1 of COMP_MVS is incorrect'
    end if
!
!
! END OF PROGRAM ex1_comp_mvs
! ===========================
!
end program ex1_comp_mvs

ex1_comp_sym_ginv.F90

program ex1_comp_sym_ginv
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine COMP_SYM_GINV
!   in module Lin_Procedures . 
!                                                                              
! LATEST REVISION : 23/09/2014
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    USE Statpack, ONLY : lgl, i4b, stnd, true, false, zero, one, c10, comp_sym_ginv, merror, allocate_error
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=1000, m=n-10_i4b
!
    real(stnd), parameter :: fudge=c10
!
    character(len=*), parameter :: name_proc='Example 1 of comp_sym_ginv'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, eps, tol, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, ata, atainv, res
!
    integer(i4b) :: j, krank
    integer      :: iok, istart, iend, irate
!
    logical(lgl) :: do_test, upper, failure
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : GENERALIZED INVERSE OF A REAL SYMMETRIC DEFINITE POSITIVE MATRIX .
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    tol = sqrt( epsilon( err ) )
    eps = fudge*tol
    err = zero
!
    do_test = true
    upper   = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(m,n), ata(n,n), atainv(n,n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
! 
!   GENERATE A RANDOM DATA MATRIX a .
!
    call random_number( a )
!
!   GENERATE A n-BY-n SYMMETRIC POSITIVE SEMIDEFINITE MATRIX From a .
!
    ata = matmul( transpose(a), a )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count=istart, count_rate=irate )
!
!   COMPUTE A GENERALIZED INVERSE OF ata WITH SUBROUTINE comp_sym_ginv.
!   INPUT ARGUMENT ata IS NOT OVERWRITTEN.
!
    call comp_sym_ginv( ata, failure, krank, atainv, upper=upper, tol=tol )
!
!   STOP THE TIMER.
!
    call system_clock( count=iend )
!
    elapsed_time = real( iend - istart, stnd )/real( irate, stnd )
!
    if ( failure ) then
!
!       ANORMAL EXIT FROM comp_sym_ginv SUBROUTINE, PRINT A WARNING.
!
        write (prtunit,*) 'Error in the call to COMP_SYM_GINV subroutine, failure=', failure
!
    else if ( do_test ) then
!
!       ALLOCATE WORK ARRAY .
!
        allocate( res(n,n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       CHECK THE IDENTITIES ata*atainv*ata = a AND  atainv*ata*atainv = atainv,
!       WHICH DEFINE THE GENERALIZED INVERSE OF ata.
!
        res = matmul(ata, matmul(atainv,ata)) - ata
        err = sum( abs(res) ) / sum( abs(ata) )
!
        res = matmul(atainv, matmul(ata,atainv)) - atainv
        err = max( sum( abs(res) ) / sum( abs(atainv) ), err )
!
!       CHECK THE RESULTS FOR SMALL RESIDUALS.
!
        err = sum( abs(res) ) / sum( abs(ata) )
!
!       DEALLOCATE WORK ARRAY.
!
        deallocate( res )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, ata, atainv )
!
    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 (*,'(a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing the generalized inverse of a positive semidefinite symmetric matrix of size ', &
       n, ' is', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_comp_sym_ginv
! ================================
!
end program ex1_comp_sym_ginv

ex1_comp_sym_inv.F90

program ex1_comp_sym_inv
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine COMP_SYM_INV
!   in module Lin_Procedures . 
!                                                                              
! LATEST REVISION : 05/04/2015
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    USE Statpack, only : lgl, i4b, stnd, true, false, zero, one, comp_sym_inv, 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
!
    integer(i4b), parameter :: prtunit=6, n=4000, m=4000
!
    character(len=*), parameter :: name_proc='Example 1 of comp_sym_inv'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, eps, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, ata, atainv, res
!
    integer(i4b) :: j
    integer      :: iok, istart, iend, irate
!
    logical(lgl) :: do_test, upper, failure
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : INVERSE OF A REAL SYMMETRIC DEFINITE POSITIVE MATRIX .
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = sqrt( epsilon( err ) )
    err = zero
!
    do_test = true
    upper   = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(m,n), ata(n,n), atainv(n,n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
! 
!   GENERATE A RANDOM DATA MATRIX a .
!
    call random_number( a )
!
!   GENERATE A n-BY-n SYMMETRIC POSITIVE DEFINITE MATRIX From a .
!
    ata = matmul( transpose(a), a )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count=istart, count_rate=irate )
!
!   COMPUTE THE MATRIX INVERSE OF ata WITH SUBROUTINE comp_sym_inv.
!   INPUT ARGUMENT ata IS NOT OVERWRITTEN.
!
    call comp_sym_inv( ata, failure, atainv, upper=upper )
!
!   STOP THE TIMER.
!
    call system_clock( count=iend )
!
    elapsed_time = real( iend - istart, stnd )/real( irate, stnd )
!
    if ( failure ) then
!
!       ANORMAL EXIT FROM comp_sym_inv SUBROUTINE, PRINT A WARNING.
!
        write (prtunit,*) 'Error in the call to COMP_SYM_INV subroutine, failure=', failure
!
    else if ( do_test ) then
!
!       ALLOCATE WORK ARRAY .
!
        allocate( res(n,n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE ata TIMES ITS INVERSE - IDENTITY.
!
        res = matmul( ata, atainv )
!
        do j = 1_i4b, n
            res(j,j) = res(j,j) - one
        end do
!
!       CHECK THE RESULTS FOR SMALL RESIDUALS.
!
        err = sum( abs(res) ) / sum( abs(ata) )
!
!       DEALLOCATE WORK ARRAY.
!
        deallocate( res )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, ata, atainv )
!
    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 (*,'(a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing the inverse of a positive definite symmetric matrix of size ', &
       n, ' is', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_comp_sym_inv
! ===============================
!
end program ex1_comp_sym_inv

ex1_comp_triang_inv.F90

program ex1_comp_triang_inv
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine COMP_TRIANG_INV
!   in module Lin_Procedures . 
!                                                                              
! LATEST REVISION : 18/06/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, zero, one, true, false, allocate_error,   &
                         triangle, norm, comp_triang_inv, merror
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=4000, p=n*(n+1)/2
!
    character(len=*), parameter :: name_proc='Example 1 of comp_triang_inv'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, eps, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, ainv, res
    real(stnd), dimension(:),   allocatable :: ap
!
    integer(i4b) :: j
    integer      :: iok, istart, iend, irate, imax, itime
!
    logical(lgl) :: do_test, upper
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : COMPUTE THE INVERSE OF A REAL n-BY-n TRIANGULAR MATRIX.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = sqrt( epsilon( err ) )
    err = zero
!
    do_test = true
    upper   = false
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), ainv(n,n), ap(p), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM TRIANGULAR MATRIX IN PACKED FORM ap .
!
    call random_number( ap )
!
!   MAKE SURE THAT TRIANGULAR MATRIX IS NOT SINGULAR.
!
    ap = ap + real( n, stnd )
!
!   UNPACK THE TRIANGULAR MATRIX a .
!
    a = unpack( ap, mask=triangle(upper,n,n,extra=1_i4b), field=zero )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   COMPUTE IN PLACE THE INVERSE OF a WITH SUBROUTINE comp_triang_inv.
!   THE INPUT ARGUMENT IS OVERWRITTEN.
!
    call comp_triang_inv( a, ainv, upper=upper )
!
!   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 ( do_test ) then
!
!       ALLOCATE WORK ARRAY.
!
        allocate( res(n,n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
        if ( upper ) then
!
            do j = 1_i4b, n-1_i4b
                ainv(j+1_i4b:n,j) = zero
            end do
!
        else
!
            do j = 2_i4b, n
                ainv(1_i4b:j-1_i4b,j) = zero
            end do
!
        end if
!
!       COMPUTE a TIMES ITS INVERSE - IDENTITY.
!
        res(:n,:n) = matmul( a(:n,:n), ainv(:n,:n) )
!
        do j = 1_i4b, n
            res(j,j) = res(j,j) - one
        end do
!
        err = norm( res(:n,:n) ) /( real(n,stnd)*norm(a(:n,:n)) )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, ainv, ap, res )
!
    else
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, ainv, ap )
!
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    write (prtunit,*)
    write (*,'(a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing the inverse of a real triangular matrix of size ', &
       n, ' by ', n, ' is', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_comp_triang_inv
! ==================================
!
end program ex1_comp_triang_inv

ex1_comp_unistat.F90

program ex1_comp_unistat
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine COMP_UNISTAT
!   in module Stat_Procedures .
!                                                                              
! LATEST REVISION : 26/06/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, lgl, true, comp_unistat
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=26, m=20, p=250
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                      :: err1, err2, eps
    real(stnd), dimension(n,m,7)    :: xstat1, xstat2
    real(stnd), dimension(n,m,p)    :: x
!
    integer(i4b) :: i
!
    logical(lgl) :: first, last
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of comp_unistat'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
    eps = sqrt( epsilon(eps) )
!
!   GENERATE A RANDOM OBSERVATION ARRAY x .
!
    call random_number( x )
!
!   COMPUTE THE STATISTICS OF x FOR THE p OBSERVATIONS .
!
    first = true
    last  = true
!
    call comp_unistat( x(:n,:m,:p), first, last, xstat1(:n,:m,:7) )
!
!   ON EXIT, WHEN last=true, xstat1 CONTAINS THE FOLLOWING
!   STATISTICS ON ALL VARIABLES :
!
!        xstat1(:,:,1) CONTAINS THE MEAN VALUES.
!        xstat1(:,:,2) CONTAINS THE VARIANCES.
!        xstat1(:,:,3) CONTAINS THE STANDARD DEVIATIONS.
!        xstat1(:,:,4) CONTAINS THE COEFFICIENTS OF SKEWNESS.
!        xstat1(:,:,5) CONTAINS THE COEFFICIENTS OF KURTOSIS.
!        xstat1(:,:,6) CONTAINS THE MINIMA.
!        xstat1(:,:,7) CONTAINS THE MAXIMA.
!
!   COMPUTE THE STATISTICS OF x, ITERATIVELY FOR THE p OBSERVATIONS  .
!
    do i = 1, p
!
        first = i==1
        last  = i==p
!
        call comp_unistat( x(:n,:m,i:i), first, last, xstat2(:n,:m,:7) )
    end do
!
!   CHECK THAT THE TWO SETS OF STATISTICS AGREE.
!
    err1 = maxval( abs( (xstat2(:,:,1:3)-xstat1(:,:,1:3))/xstat1(:,:,1:3) ) )
    err2 = maxval( abs( xstat2(:,:,4:7)-xstat1(:,:,4:7) ) )
!
    if ( max(err1, err2)<=eps ) then
        write (prtunit,*) 'Example 1 of COMP_UNISTAT is correct'
    else
        write (prtunit,*) 'Example 1 of COMP_UNISTAT is incorrect'
    end if
!
!
! END OF PROGRAM ex1_comp_unistat
! ===============================
!
end program ex1_comp_unistat

ex1_cpusecs.F90

program ex1_cpusecs
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of function CPUSECS
!   in module Time_Procedures .
!                                                                              
! LATEST REVISION : 26/06/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, extd, cpusecs
!   
!
! STRONG TYPING IMPOSED
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT.
!
    integer(i4b), parameter :: prtunit=6
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(extd)   :: tim1, tim2
!
    integer(i4b) :: i, j
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of cpusecs'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   FUNCTION cpusecs OBTAINS, FROM THE INTRINSIC ROUTINE SYSTEM_CLOCK,
!   THE CURRENT VALUE OF THE SYSTEM CPU USAGE CLOCK. THIS VALUE
!   IS THEN CONVERTED TO SECONDS AND RETURNED AS AN EXTENDED PRECISION
!   REAL VALUE.
!
!   THIS FUNCTIONS ASSUMES THAT THE NUMBER OF CPU CYCLES (CLOCK COUNTS) BETWEEN
!   TWO CALLS IS LESS THAN COUNT_MAX, THE MAXIMUM POSSIBLE VALUE OF CLOCK COUNTS
!   AS RETURNED BY THE INTRINSIC ROUTINE SYSTEM_CLOCK.
!
!   THIS FUNCTION WILL NOT WORK PROPERLY WITH OPENMP.
!
!   A TYPICAL USE OF THIS FUNCTION IS AS FOLLOWS :
!
    tim1 = cpusecs()
    j = 0
    do i=1, 2000000000
        j = j + 1
    end do
    tim2 = cpusecs()
!
!   PRINT THE RESULT.
!
    write (prtunit, *)  " CPU Time(s): ", tim2-tim1 ,' seconds'
!
!
! END OF PROGRAM ex1_cpusecs
! ==========================
!
end program ex1_cpusecs

ex1_daynum_to_dayweek.F90

program ex1_daynum_to_dayweek
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of function DAYNUM_TO_DAYWEEK
!   in module Time_Procedures .
!                                                                              
!   See also program ex1_ymd_to_daynum.f90.                 
!                                                                              
! LATEST REVISION : 26/06/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, ymd_to_daynum, daynum_to_dayweek, get_date, days
!   
!
! STRONG TYPING IMPOSED
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT.
!
    integer(i4b), parameter :: prtunit=6
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    integer(i4b) :: iyr, imon, iday, idaynum, idayweek
!
    character(len=11) :: date
!
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of daynum_to_dayweek'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A DATE.
!
    iyr  = 1999
    imon = 7
    iday = 28
!
!   CONVERTS GREGORIAN YEAR (iyr), MONTH (imon) AND DAY (iday) TO JULIAN DAY
!   NUMBER (idaynum).
!
    idaynum = ymd_to_daynum( iyr, imon, iday )
!
!   DETERMINE THE DAY OF THE WEEK FROM JULIAN DAY NUMBER (idaynum).
!   MONTH (imon) AND DAY (iday).
!
    idayweek = daynum_to_dayweek( idaynum )
!
!   FUNCTION daynum_to_dayweek RETURNS THE DAY OF THE WEEK (E.G., MON, TUE,...) AS AN
!   INTEGER INDEX (MON=1 TO SUN=7) FOR THE GIVEN JULIAN DAY NUMBER idaynum STARTING WITH
!   idaynum=1 ON FRIDAY, 15 OCTOBER 1582.
!
!   PRINT THE RESULT.
!
    call get_date( iyr, imon, iday, date )
!
    write (prtunit,*) 'The date ' // date // ' is a ' // days(idayweek)
!
!
! END OF PROGRAM ex1_daynum_to_dayweek
! ====================================
!
end program ex1_daynum_to_dayweek

ex1_daynum_to_ymd.F90

program ex1_daynum_to_ymd
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of function YMD_TO_DAYNUM and
!   subroutine DAYNUM_TO_YMD in module Time_Procedures .
!                                                                              
!   See also program ex1_ymd_to_daynum.f90 .   
!                                                                              
! LATEST REVISION : 26/06/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, ymd_to_daynum, daynum_to_ymd
!   
!
! STRONG TYPING IMPOSED
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT.
!
    integer(i4b), parameter :: prtunit=6
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    integer(i4b) :: iyr, imon, iday, iyr2, imon2, iday2, idaynum
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of daynum_to_ymd'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A DATE.
!
    iyr  = 1902
    imon = 11
    iday = 15
!
!   CONVERTS GREGORIAN YEAR (iyr), MONTH (imon) AND DAY (iday) TO JULIAN DAY
!   NUMBER (idaynum).
!
    idaynum = ymd_to_daynum( iyr, imon, iday )
!
!   FUNCTION ymd_to_daynum CONVERTS THE THREE INTEGERS iyr, imon AND iday STANDING FOR
!   YEAR, MONTH, DAY IN THE GREGORIAN CALENDAR PROMULGATED BY GREGORY XIII ON
!   FRIDAY, 15 OCTOBER 1582, IN THE CORRESPONDING JULIAN DAY NUMBER STARTING
!   WITH ymd_to_daynum=1 ON FRIDAY, 15 OCTOBER 1582.
!
!   NOTE THE GREGORIAN CALENDAR WAS ADOPTED IN OCT. 15, 1582, AND HENCE
!   THIS FUNCTION WILL NOT WORK PROPERLY FOR DATES EARLY THAN 10-15-1582.
!   
!   CONVERTS A JULIAN DAY NUMBER (idaynum) TO GREGORIAN YEAR (iyr2), MONTH (imon2)
!   AND DAY (iday2).
!
    call daynum_to_ymd( idaynum, iyr2, imon2, iday2 )
!
!   SUBROUTINE daynum_to_ymd CONVERTS THE INTEGER idaynum TO THREE INTEGERS iyr2, imon2 AND
!   iday2 STANDING FOR YEAR, MONTH, DAY IN THE GREGORIAN CALENDAR PROMULGATED BY 
!   GREGORY XIII STARTING WITH idaynum=1 ON FRIDAY, 15 OCTOBER 1582.
!
!   TO KEEP POPE GREGORY'S CALENDAR SYNCHRONIZED WITH THE SEASONS FOR THE NEXT 
!   16000 YEARS OR SO, A SMALL CORRECTION HAS BEEN INTRODUCED; MILLENNIAL YEARS
!   DIVISIBLE BY 4000 ARE NOT CONSIDERED LEAP-YEARS.
!
!   NOTE THE GREGORIAN CALENDAR WAS ADOPTED IN OCT. 15, 1582, AND HENCE
!   THIS SUBROUTINE WILL NOT WORK PROPERLY FOR DATES EARLY THAN 10-15-1582,
!   EG. IF idaynum < 1.
!
!   CHECK THE COMPUTATIONS.
!
    if ( iyr==iyr2 .and. imon==imon2 .and. iday==iday2  ) then
        write (prtunit,*) 'Example 1 of DAYNUM_TO_YMD is correct'
    else
        write (prtunit,*) 'Example 1 of DAYNUM_TO_YMD is incorrect'
    end if
!
!
! END OF PROGRAM ex1_daynum_to_ymd
! ================================
!
end program ex1_daynum_to_ymd

ex1_det.F90

program ex1_det
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of function DET
!   in module Lin_Procedures .
!                                                                              
! LATEST REVISION : 04/10/2014
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, lgl, stnd, true, false, zero, one, det, inv, merror, allocate_error
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=500
!
    character(len=*), parameter :: name_proc='Example 1 of det'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: adet, ainvdet, err, eps, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, ainv
!
    integer        :: iok, istart, iend, irate
!
    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 : COMPUTE THE DETERMINANT OF A REAL MATRIX.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = sqrt( epsilon( err ) )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,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 )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count=istart, count_rate=irate )
!
!   COMPUTE THE DETERMINANT OF THE DATA MATRIX WITH FUNCTION det.
!
    adet = det( a )
!
!   STOP THE TIMER.
!
    call system_clock( count=iend )
!
    elapsed_time = real( iend - istart, stnd )/real( irate, stnd )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAY .
!
        allocate( ainv(n,n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE THE MATRIX INVERSE OF a.
!
        ainv = inv( a ) 
!
!       COMPUTE THE DETERMINANT OF MATRIX INVERSE .
!
        ainvdet = det( ainv )
!
!       CHECK det(a**-1)*det(a)**-1 = 1.
!
        err = abs(adet*ainvdet - one) / max( abs(adet), abs(ainvdet) )
!
!       DEALLOCATE WORK ARRAY.
!
        deallocate( ainv )
!
    end if
!
!   DEALLOCATE WORK ARRAY.
!
    deallocate( a )
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing the determinant of a real matrix of size ', &
       n, ' is', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_det
! ======================
!
end program ex1_det

ex1_do_index.F90

program ex1_do_index
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines DO_INDEX and REORDER
!   in module Sort_Procedures.
!                                                                              
! LATEST REVISION : 26/06/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, false, arth, do_index, reorder
!   
!
! STRONG TYPING IMPOSED
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=100
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd), dimension(n) :: x
!
    integer(i4b)               :: i, j, k, i1, i2
    integer(i4b), dimension(n) :: y, indexx, indexy
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of do_index'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE RANDOM REAL DATA TO SORT.
!
    call random_number( x )
!
!   INITIALIZE PERMUTATION TO THE IDENTITY.
!
    y = arth( 1_i4b, 1_i4b, n ) 
!    
!   GENERATE A RANDOM ORDERING OF THE INTEGERS 1 TO n.
!   STARTING AT THE END, SWAP THE CURRENT LAST INDICATOR WITH ONE
!   RANDOMLY CHOSEN FROM THOSE PRECEEDING IT.

    do i = n, 2, -1
        j = 1 + i * x(i)
        if (j < i) then
            k = y(i)
            y(i) = y(j)
            y(j) = k
        end if
    end do
!
!   COMPUTE INDEX FOR EACH ARRAY.
!
    call do_index( x, indexx )
    call do_index( y, indexy )
!
!   EXAMPLE 1 : SORT THE REAL DATA IN ASCENDING ORDER 
!               BY MEANS OF THE INDEX .
!
    call reorder( indexx, x  )
!
!   CHECK THAT THE SORTED ARRAY IS NON-DECREASING.
!
    i1 = count( x(1:n-1) > x(2:n) )
!
!   EXAMPLE 2 : SORT THE INTEGER DATA IN DECREASING ORDER
!            BY MEANS OF THE INDEX .
!
    call reorder( indexy, y, ascending=false )
!
!   CHECK THAT THE SORTED ARRAY IS NON-INCREASING.
!
    i2 = count( y(1:n-1) < y(2:n) )
!
!   PRINT THE RESULT OF THE TESTS.
!
    if ( i1==0 .and. i2==0 ) then
        write (prtunit,*) 'Example 1 of DO_INDEX is correct'
    else
        write (prtunit,*) 'Example 1 of DO_INDEX is incorrect'
    end if
!
!
! END OF PROGRAM ex1_do_index
! ===========================
!
end program ex1_do_index

ex1_drawsample.F90

program ex1_drawsample
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines COMP_COR and DRAWSAMPLE
!   in modules Mul_Stat_Procedures and Random, respectively.
!                                                                              
! LATEST REVISION : 26/06/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    USE Statpack, ONLY : i4b, stnd, lgl, true, comp_cor, drawsample, random_seed_, random_number_
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
! p       IS THE NUMBER OF OBSERVATIONS OF THE RANDOM VECTORS
! nrep    IS THE NUMBER OF SHUFFLES FOR THE PERMUTATION TEST
!
    INTEGER(i4b), PARAMETER :: prtunit=6, p=50, p1=26, p2=p, p3=p2-p1+1, nrep=999, nsample=2
!
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                        :: xyn
    REAL(stnd), DIMENSION(nsample)    :: xycor, prob, xycor2
    real(stnd), dimension(nsample,2)  :: xstat
    real(stnd), dimension(2)          :: ystat
    real(stnd), dimension(nsample,p)  :: x
    real(stnd), dimension(nsample,p3) :: x2
    real(stnd), dimension(p)          :: y
    real(stnd), dimension(p3)         :: y2
!
    integer(i4b)                     :: i
    integer(i4b), dimension(p)       :: pop
    integer(i4b), dimension(nsample) :: nge
!
    logical(lgl) :: first, last
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of drawsample'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   INITIALIZE THE RANDOM GENERATOR.
!
    call random_seed_()
!
!   GENERATE A RANDOM UNIFORM OBSERVATION VECTOR y .
!
    call random_number_( y(:p) )
!
!   GENERATE A RANDOM UNIFORM OBSERVATION ARRAY x .
!
    call random_number_( x(:nsample,:p) )
!
!   COMPUTE THE CORRELATIONS BETWEEN x AND y
!   FOR THE p2-p1+1 LAST  OBSERVATIONS .
!
    first = true
    last  = true
!
    call comp_cor( x(:nsample,p1:p2), y(p1:p2), first, last, xstat(:nsample,:2), ystat(:2),    &
                   xycor(:nsample), xyn )
!
!   ON EXIT OF COMP_COR WHEN last=true :
!
!      xstat(:nsample,1)     CONTAINS THE MEAN VALUES OF THE OBSERVATION ARRAY x(:nsample,p1:p2).
!
!      xstat(:nsample,2)     CONTAINS THE VARIANCES OF THE OBSERVATION ARRAY x(:nsample,p1:p2).
!
!      ystat(1)              CONTAINS THE MEAN VALUE OF THE OBSERVATION VECTOR  y(p1:p2).
!
!      ystat(2)              CONTAINS THE VARIANCE OF THE OBSERVATION VECTOR  y(p1:p2).
!
!      xycor(:nsample)       CONTAINS THE CORRELATION COEFFICIENTS BETWEEN x(:nsample,p1:p2) AND y(p1:p2).
!
!      xyn                   CONTAINS THE NUMBER OF OBSERVATIONS IN THE DATA ARRAYS
!                            x(:nsample,p1:p2) AND  y(p1:p2) (xyn=real(p2-p1+1,stnd) ).
!
!
!   NOW COMPUTE A PERMUTATION TEST OF THE CORRELATION BETWEEN x AND y WITH
!   SUBROUTINES drawsample  AND comp_cor WITH nrep SHUFFLES .
!
    nge(:nsample) = 1
!
    do i=1, nrep
!
        call drawsample( p3, pop )
!
        x2(:nsample,:p3) = x(:nsample,pop(:p3))
        y2(:p3)          = y(pop(:p3))
!
        call comp_cor( x2(:nsample,:p3), y2(:p3), first, last, xstat(:nsample,:2), ystat(:2),    &
                       xycor2(:nsample), xyn )
!
        where( abs( xycor2(:nsample) )>= abs( xycor(:nsample) ) ) nge(:nsample) = nge(:nsample) + 1
!
    end do 
!
!   COMPUTE THE SIGNIFICANCE LEVELS.
!
    prob(:nsample) = real( nge(:nsample), stnd )/real( nrep+1, stnd )
!
    WRITE (prtunit,*) 'Correlations  = ', xycor(:nsample)
    WRITE (prtunit,*) 'Probabilities = ', prob(:nsample)
!
!
!
! END OF PROGRAM ex1_drawsample
! ==============================
!
end program ex1_drawsample

ex1_eig_cmp.F90

program ex1_eig_cmp
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine EIG_CMP
!   in module Eig_Procedures .
!                                                                            
! LATEST REVISION : 01/06/2017
!
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, merror,   &
                         allocate_error, unit_matrix, eig_cmp
#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
!
    integer(i4b), parameter :: prtunit=6, n=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of eig_cmp'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, eps, elapsed_time
    real(stnd), dimension(:),   allocatable :: d, resid2
    real(stnd), dimension(:,:), allocatable :: a, a2, resid
!
    integer        :: iok, istart, iend, irate, imax, itime
!
    logical(lgl)   :: do_test, failure
!   
    character    :: sort='a'
!   
!   
! 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 TRIDIAGONAL QR METHOD.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), d(n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM DATA MATRIX AND FROM IT
!   A SELF-ADJOINT MATRIX a .
!
    call random_number( a )
    a = a + transpose( a ) 
!
    if ( do_test ) then
!
        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 )
!
!   COMPUTE EIGENVALUES AND EIGENVECTORS OF THE SELF-ADJOINT MATRIX a
!   WITH SUBROUTINE eig_cmp.
!   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 eig_cmp( a, d, failure, sort=sort )
!
!   THE ROUTINE RETURNS THE EIGENVALUES AND THE EIGENVECTORS OF a.
!
!   ON EXIT OF eig_cmp:
!
!       failure= false :  INDICATES SUCCESSFUL EXIT.
!       failure= true  :  INDICATES THAT THE TRIDIAGONAL QR ALGORITHM DID NOT CONVERGE AND
!                         THAT FULL ACCURACY WAS NOT ATTAINED IN THE EIGENDECOMPOSITION 
!                         OF AN 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.
!
!   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 ( 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 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, a2, d, resid, resid2 )
!
    else
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, d )
!
    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
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', n, ' eigenvalues and eigenvectors of a ', &
       n, ' by ', n,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_eig_cmp
! ==========================
!
end program ex1_eig_cmp

ex1_eig_cmp2.F90

program ex1_eig_cmp2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine EIG_CMP2
!   in module Eig_Procedures .
!                                                                            
! LATEST REVISION : 01/06/2017
!
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, merror,   &
                         allocate_error, unit_matrix, eig_cmp2
#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
!
    integer(i4b), parameter :: prtunit=6, n=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of eig_cmp2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, eps, elapsed_time
    real(stnd), dimension(:),   allocatable :: d, resid2
    real(stnd), dimension(:,:), allocatable :: a, a2, resid
!
    integer        :: iok, istart, iend, irate, imax, itime
!
    logical(lgl)   :: do_test, failure
!   
    character    :: sort='a'
!   
!   
! 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, A PERFECT SHIFT
!               STRATEGY FOR THE EIGENVECTORS AND A WAVE-FRONT ALGORITHM
!               FOR APPLYING GIVENS ROTATIONS IN THE TRIDIAGONAL QR
!               ALGORITHM.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), d(n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM DATA MATRIX AND FROM IT
!   A SELF-ADJOINT MATRIX a .
!
    call random_number( a )
    a = a + transpose( a ) 
!
    if ( do_test ) then
!
        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 )
!
!   COMPUTE EIGENVALUES AND EIGENVECTORS OF THE SELF-ADJOINT MATRIX a
!   WITH SUBROUTINE eig_cmp2.
!   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 eig_cmp2( a, d, failure, sort=sort, max_francis_steps=20_i4b )
!
!   THE ROUTINE RETURNS THE EIGENVALUES AND THE EIGENVECTORS OF a.
!
!   ON EXIT OF eig_cmp2:
!
!       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 AN 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.
!
!   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 ( 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 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, a2, d, resid, resid2 )
!
    else
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, d )
!
    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
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', n, ' eigenvalues and eigenvectors of a ', &
       n, ' by ', n,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_eig_cmp2
! ===========================
!
end program ex1_eig_cmp2

ex1_eig_cmp3.F90

program ex1_eig_cmp3
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine EIG_CMP3
!   in module Eig_Procedures .
!                                                                            
! LATEST REVISION : 01/06/2017
!
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, merror,   &
                         allocate_error, unit_matrix, eig_cmp3
#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
!
    integer(i4b), parameter :: prtunit=6, n=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of eig_cmp3'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, eps, elapsed_time
    real(stnd), dimension(:),   allocatable :: d, resid2
    real(stnd), dimension(:,:), allocatable :: a, a2, resid
!
    integer        :: iok, istart, iend, irate, imax, itime
!
    logical(lgl)   :: do_test, failure
!   
    character    :: sort='a'
!   
!   
! 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 AND A WAVE-FRONT ALGORITHM
!               FOR APPLYING GIVENS ROTATIONS IN THE TRIDIAGONAL QR
!               ALGORITHM.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), d(n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM DATA MATRIX AND FROM IT
!   A SELF-ADJOINT MATRIX a .
!
    call random_number( a )
    a = a + transpose( a ) 
!
    if ( do_test ) then
!
        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 )
!
!   COMPUTE EIGENVALUES AND EIGENVECTORS OF THE SELF-ADJOINT MATRIX a
!   WITH SUBROUTINE eig_cmp3.
!   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 eig_cmp3( a, d, failure, sort=sort )
!
!   THE ROUTINE RETURNS THE EIGENVALUES AND THE EIGENVECTORS OF a.
!
!   ON EXIT OF eig_cmp3:
!
!       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 AN 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.
!
!   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 ( 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 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, a2, d, resid, resid2 )
!
    else
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, d )
!
    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
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', n, ' eigenvalues and eigenvectors of a ', &
       n, ' by ', n,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_eig_cmp3
! ===========================
!
end program ex1_eig_cmp3

ex1_eigval_cmp.F90

program ex1_eigval_cmp
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine EIGVAL_CMP
!   in module Eig_Procedures.
!                                                                              
! LATEST REVISION : 20/01/2020
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, trid_inviter,  &
                         eigval_cmp, 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, neig IS THE NUMBER OF THE WANTED EIGENVECTORS
!
    integer(i4b), parameter :: prtunit=6, n=3000, neig=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of eigval_cmp'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, eps, elapsed_time
    real(stnd), dimension(:),   allocatable :: d, res
    real(stnd), dimension(:,:), allocatable :: a, a2, eigvec, d_e
!
    integer(i4b) :: maxiter=2
    integer      :: iok, istart, iend, irate, imax, itime
!
    logical(lgl) :: failure, failure2, 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 : PARTIAL EIGENVALUES/EIGENVECTORS DECOMPOSITION OF A n-BY-n REAL
!               SYMMETRIC MATRIX USING THE FAST PAL-WALKER-KAHAN VARIANT OF THE QR METHOD
!               FOR EIGENVALUES AND THE INVERSE ITERATION TECHNIQUE FOR SELECTED EIGENVECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
!
    err = zero
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), d(n), d_e(n,2), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM DATA MATRIX AND FROM IT
!   A SELF-ADJOINT MATRIX a .
!
    call random_number( a )
    a = a + transpose( a ) 
!
    if ( do_test ) then
!
        allocate( a2(n,n), res(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 )
!
!   COMPUTE ALL EIGENVALUES OF THE SELF-ADJOINT MATRIX a AND SAVE
!   THE INTERMEDIATE TRIDIAGONAL MATRIX IN PARAMETER d_e .
!
    call eigval_cmp( a, d, failure, sort=sort, d_e=d_e )
!
!   THE ROUTINE RETURNS THE EIGENVALUES OF a.
!
!   ON EXIT OF eigval_cmp:
!
!       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 AN INTERMEDIATE TRIDIAGONAL FORM TRID OF a.
!
!       a IS OVERWRITTEN BY THE ORTHOGONAL MATRIX USED TO TRANSFORM a IN TRIDIAGONAL FORM IF
!         THE OPTIONAL ARGUMENT d_e IS SPECIFIED.
!         THE MATRIX Q IS STORED IN FACTORED FORM IN THE UPPER TRIANGLE OF a AND THE STRICTLY
!         LOWER TRIANGLE OF a IS NOT REFERENCED
!
!       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.
!
    if ( .not. failure .and. neig>0  ) then
!
!       ALLOCATE WORK ARRAY NEEDED TO STORE THE EIGENVECTORS.
!
        allocate( eigvec(n,neig), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE THE FIRST neig EIGENVECTORS OF THE SELF-ADJOINT MATRIX a BY
!       maxiter INVERSE ITERATIONS ON THE INTERMEDIATE TRIDIAGONAL MATRIX
!       d_e AND BACK-TRANSFORMATION.
!
        call trid_inviter( d_e(:n,1_i4b), d_e(:n,2_i4b), d(:neig), eigvec, failure2, &
                           mat=a, maxiter=maxiter )
!
    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 ( do_test .and. .not.failure .and. neig>0 ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*eigvec - eigvec*d
!       WHERE d ARE THE EIGENVALUES AND eigvec THE EIGENVECTORS OF a.
!
        a(:n,:neig) = matmul( a2(:n,:n), eigvec(:n,:neig)) - eigvec(:n,:neig)*spread( d(:neig), dim=1, ncopies=n)
        res(:neig)  = norm( a(:n,:neig), dim=2_i4b )
!
        err1 = maxval( res(:neig) )/( norm( a2 )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - eigvec**(t)*eigvec.
!
        call unit_matrix( a(:neig,:neig) )
!
        a2(:neig,:neig) = abs( a(:neig,:neig) - matmul( transpose(eigvec(:n,:neig)), eigvec(:n,:neig) ) )
!
        err2 = maxval( a2(:neig,:neig) )/real(n,stnd)
!
        err = max( err1, err2 )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( do_test ) then
!
        deallocate( a, d_e, d, a2, res )
!
    else
!
        deallocate( a, d_e, d )
!
    end if
!
    if ( allocated( eigvec ) )  deallocate( eigvec )
!
!   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
!
    if ( do_test  .and. .not.failure .and. neig>0 ) then
        write (prtunit,*) 
        write (prtunit,*) 'Accuracy of the computed eigenvalues/eigenvectors couplets = ', err1
        write (prtunit,*) 'Orthogonality of the computed eigenvectors                 = ', err2
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing all the eigenvalues and ', neig, ' eigenvectors of a ', &
       n, ' by ', n,' real symmetric matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_eigval_cmp
! =============================
!
end program ex1_eigval_cmp

ex1_eigval_cmp2.F90

program ex1_eigval_cmp2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine EIGVAL_CMP2
!   in module Eig_Procedures.
!                                                                              
! LATEST REVISION : 20/01/2020
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, trid_inviter,  &
                         eigval_cmp2, 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, neig IS THE NUMBER OF THE WANTED EIGENVECTORS
!
    integer(i4b), parameter :: prtunit=6, n=3000, neig=100
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of eigval_cmp2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, eps, elapsed_time
    real(stnd), dimension(:),   allocatable :: d, res
    real(stnd), dimension(:,:), allocatable :: a, a2, eigvec, d_e
!
    integer(i4b) :: maxiter=2
    integer      :: iok, istart, iend, irate, imax, itime
!
    logical(lgl) :: failure, failure2, 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 : PARTIAL EIGENVALUES/EIGENVECTORS DECOMPOSITION OF A n-BY-n REAL
!               SYMMETRIC MATRIX USING THE FAST PAL-WALKER-KAHAN VARIANT OF THE QR METHOD
!               FOR EIGENVALUES AND THE INVERSE ITERATION TECHNIQUE FOR SELECTED EIGENVECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
!
    err = zero
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), d(n), d_e(n,2), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM DATA MATRIX AND FROM IT
!   A SELF-ADJOINT MATRIX a .
!
    call random_number( a )
    a = a + transpose( a ) 
!
    if ( do_test ) then
!
        allocate( a2(n,n), res(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 )
!
!   COMPUTE ALL EIGENVALUES OF THE SELF-ADJOINT MATRIX a AND SAVE
!   THE INTERMEDIATE TRIDIAGONAL MATRIX IN PARAMETER d_e .
!
    call eigval_cmp2( a, d, failure, sort=sort, d_e=d_e )
!
!   THE ROUTINE RETURNS THE EIGENVALUES OF a.
!
!   ON EXIT OF eigval_cmp2:
!
!       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 AN INTERMEDIATE TRIDIAGONAL FORM TRID OF a.
!
!       a IS OVERWRITTEN BY THE ORTHOGONAL MATRIX USED TO TRANSFORM a IN TRIDIAGONAL FORM IF
!         THE OPTIONAL ARGUMENT d_e IS SPECIFIED.
!         THE MATRIX Q IS STORED IN FACTORED FORM IN THE UPPER TRIANGLE OF a AND THE STRICTLY
!         LOWER TRIANGLE OF a IS NOT REFERENCED
!
!       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.
!
    if ( .not. failure .and. neig>0  ) then
!
!       ALLOCATE WORK ARRAY NEEDED TO STORE THE EIGENVECTORS.
!
        allocate( eigvec(n,neig), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE THE FIRST neig EIGENVECTORS OF THE SELF-ADJOINT MATRIX a BY
!       maxiter INVERSE ITERATIONS ON THE INTERMEDIATE TRIDIAGONAL MATRIX
!       d_e AND BACK-TRANSFORMATION.
!
        call trid_inviter( d_e(:n,1_i4b), d_e(:n,2_i4b), d(:neig), eigvec, failure2, &
                           mat=a, maxiter=maxiter )
!
    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 ( do_test .and. .not.failure .and. neig>0 ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*eigvec - eigvec*d
!       WHERE d ARE THE EIGENVALUES AND eigvec THE EIGENVECTORS OF a.
!
        a(:n,:neig) = matmul( a2(:n,:n), eigvec(:n,:neig)) - eigvec(:n,:neig)*spread( d(:neig), dim=1, ncopies=n)
        res(:neig)  = norm( a(:n,:neig), dim=2_i4b )
!
        err1 = maxval( res(:neig) )/( norm( a2 )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - eigvec**(t)*eigvec.
!
        call unit_matrix( a(:neig,:neig) )
!
        a2(:neig,:neig) = abs( a(:neig,:neig) - matmul( transpose(eigvec(:n,:neig)), eigvec(:n,:neig) ) )
!
        err2 = maxval( a2(:neig,:neig) )/real(n,stnd)
!
        err = max( err1, err2 )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( do_test ) then
!
        deallocate( a, d_e, d, a2, res )
!
    else
!
        deallocate( a, d_e, d )
!
    end if
!
    if ( allocated( eigvec ) )  deallocate( eigvec )
!
!   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
!
    if ( do_test  .and. .not.failure .and. neig>0 ) then
        write (prtunit,*) 
        write (prtunit,*) 'Accuracy of the computed eigenvalues/eigenvectors couplets = ', err1
        write (prtunit,*) 'Orthogonality of the computed eigenvectors                 = ', err2
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing all the eigenvalues and ', neig, ' eigenvectors of a ', &
       n, ' by ', n,' real symmetric matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_eigval_cmp2
! ==============================
!
end program ex1_eigval_cmp2

ex1_eigval_cmp3.F90

program ex1_eigval_cmp3
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine EIGVAL_CMP3
!   in module Eig_Procedures.
!                                                                              
! LATEST REVISION : 20/01/2020
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, trid_inviter,  &
                         eigval_cmp3, 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, neig IS THE NUMBER OF THE WANTED EIGENVECTORS
!
    integer(i4b), parameter :: prtunit=6, n=3000, neig=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of eigval_cmp3'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, eps, elapsed_time
    real(stnd), dimension(:),   allocatable :: d, res
    real(stnd), dimension(:,:), allocatable :: a, a2, eigvec, d_e
!
    integer(i4b) :: maxiter=2
    integer      :: iok, istart, iend, irate, imax, itime
!
    logical(lgl) :: failure, failure2, 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 : PARTIAL EIGENVALUES/EIGENVECTORS DECOMPOSITION OF A n-BY-n REAL
!               SYMMETRIC MATRIX USING THE QR METHOD FOR EIGENVALUES AND 
!               THE INVERSE ITERATION TECHNIQUE FOR SELECTED EIGENVECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
!
    err = zero
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), d(n), d_e(n,2), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM DATA MATRIX AND FROM IT
!   A SELF-ADJOINT MATRIX a .
!
    call random_number( a )
    a = a + transpose( a ) 
!
    if ( do_test ) then
!
        allocate( a2(n,n), res(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 )
!
!   COMPUTE ALL EIGENVALUES OF THE SELF-ADJOINT MATRIX a AND SAVE
!   THE INTERMEDIATE TRIDIAGONAL MATRIX IN PARAMETER d_e .
!
    call eigval_cmp3( a, d, failure, sort=sort, d_e=d_e )
!
!   THE ROUTINE RETURNS THE EIGENVALUES OF a.
!
!   ON EXIT OF eigval_cmp3:
!
!       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 AN INTERMEDIATE TRIDIAGONAL FORM TRID OF a.
!
!       a IS OVERWRITTEN BY THE ORTHOGONAL MATRIX USED TO TRANSFORM a IN TRIDIAGONAL FORM IF
!         THE OPTIONAL ARGUMENT d_e IS SPECIFIED.
!         THE MATRIX Q IS STORED IN FACTORED FORM IN THE UPPER TRIANGLE OF a AND THE STRICTLY
!         LOWER TRIANGLE OF a IS NOT REFERENCED
!
!       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.
!
    if ( .not. failure .and. neig>0  ) then
!
!       ALLOCATE WORK ARRAY NEEDED TO STORE THE EIGENVECTORS.
!
        allocate( eigvec(n,neig), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE THE FIRST neig EIGENVECTORS OF THE SELF-ADJOINT MATRIX a BY
!       maxiter INVERSE ITERATIONS ON THE INTERMEDIATE TRIDIAGONAL MATRIX
!       d_e AND BACK-TRANSFORMATION.
!
        call trid_inviter( d_e(:n,1_i4b), d_e(:n,2_i4b), d(:neig), eigvec, failure2, &
                           mat=a, maxiter=maxiter )
!
    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 ( do_test .and. .not.failure .and. neig>0 ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*eigvec - eigvec*d
!       WHERE d ARE THE EIGENVALUES AND eigvec THE EIGENVECTORS OF a.
!
        a(:n,:neig) = matmul( a2(:n,:n), eigvec(:n,:neig)) - eigvec(:n,:neig)*spread( d(:neig), dim=1, ncopies=n)
        res(:neig)  = norm( a(:n,:neig), dim=2_i4b )
!
        err1 = maxval( res(:neig) )/( norm( a2 )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - eigvec**(t)*eigvec.
!
        call unit_matrix( a(:neig,:neig) )
!
        a2(:neig,:neig) = abs( a(:neig,:neig) - matmul( transpose(eigvec(:n,:neig)), eigvec(:n,:neig) ) )
!
        err2 = maxval( a2(:neig,:neig) )/real(n,stnd)
!
        err = max( err1, err2 )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( do_test ) then
!
        deallocate( a, d_e, d, a2, res )
!
    else
!
        deallocate( a, d_e, d )
!
    end if
!
    if ( allocated( eigvec ) )  deallocate( eigvec )
!
!   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
!
    if ( do_test  .and. .not.failure .and. neig>0 ) then
        write (prtunit,*) 
        write (prtunit,*) 'Accuracy of the computed eigenvalues/eigenvectors couplets = ', err1
        write (prtunit,*) 'Orthogonality of the computed eigenvectors                 = ', err2
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing all the eigenvalues and ', neig, ' eigenvectors of a ', &
       n, ' by ', n,' real symmetric matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_eigval_cmp3
! ==============================
!
end program ex1_eigval_cmp3

ex1_eigvalues.F90

program ex1_eigvalues
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of function EIGVALUES 
!   in module Eig_Procedures .
!                                                                              
! LATEST REVISION : 26/06/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, svd_cmp, eigvalues, eigval_sort
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=1000
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)        :: a(n,n), a2(n,n), d(n), s(n)
!
    integer(i4b)      :: i
!
    logical(lgl)      :: failure
!   
    character         :: sort='d'
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter  :: name_proc='Example 1 of eigvalues'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A RANDOM DATA MATRIX AND FROM IT
!   A SELF-ADJOINT MATRIX.
!
    call random_number( a2 )
    a = a2 + transpose( a2 )
!
!   COMPUTE THE EIGENVALUES OF THE SELF-ADJOINT MATRIX.
!
    d = eigvalues( a )
!
!   SORT ABSOLUTE VALUES OF EIGENVALUES .
!
    d = abs( d )
    call eigval_sort( sort, d )
!
!   FOR COMPARISON, COMPUTE THE SINGULAR VALUES.
!
    call svd_cmp( a, s, failure, sort=sort )
!
!   CHECK THE RESULTS: MAGNITUDE OF EIGENVALUES SHOULD EQUAL THE SINGULAR VALUES.
!
    if ( .not. failure ) then
        if ( sum(abs(d-s))<=sqrt(epsilon(s))*maxval(abs(s)) ) then
            write (prtunit,*) 'Example 1 of EIGVALUES is correct'
        else
            write (prtunit,*) 'Example 1 of EIGVALUES is incorrect'
        end if
    else
        write (prtunit,*) 'Example 1 of EIGVALUES is not done'
    end if
!
!
! END OF PROGRAM ex1_eigvalues
! ============================
!
end program ex1_eigvalues

ex1_elapsed_time.F90

program ex1_elapsed_time
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of functions ELAPSED_TIME
!   in module Time_Procedures .
!                                                                              
! LATEST REVISION : 26/06/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, elapsed_time
!   
!
! STRONG TYPING IMPOSED
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT.
!
    integer(i4b), parameter :: prtunit=6
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    integer,      dimension(7) :: t1, t0
    integer(i4b)               :: i, j
!
    character(len=13) :: string
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of elapsed_time'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   FUNCTION elapsed_time COMPUTES ELAPSED TIME BETWEEN TWO INVOCATIONS OF THE INTRINSIC
!   FUNCTION DATE_AND_TIME. elapsed_time( T1, T0 ) RETURNS THE TIME IN SECONDS THAT HAS
!   ELAPSED BETWEEN THE VECTORS T0 AND T1. EACH VECTOR MUST HAVE AT LEAST SEVEN ELEMENTS
!   IN THE FORMAT RETURNED BY DATE_AND_TIME FOR THE OPTIONAL ARGUMENT VALUES; NAMELY
!
!           T = (/ year, month, day, x, hour, minute, second /)
!
!   THIS FUNCTION WORKS ACROSS MONTH AND YEAR BOUNDARIES BUT DOES NOT CHECK
!   THE VALIDITY OF ITS ARGUMENTS, WHICH ARE EXPECTED TO BE OBTAINED AS IN
!   THE FOLLOWING EXAMPLE THAT SHOWS HOW TO TIME SOME OPERATION BY USING ELAPSED_TIME.
!
!   THIS ROUTINE WORKS ALSO PROPERLY WITH OPENMP .
!
    call date_and_time( values=t0(:) )
    j = 0
    do i=1, 2000000000
        j = j + 1
    end do
    call date_and_time( values=t1(:) )
!
!   PRINT THE RESULT.
!
    write (prtunit, *)  'Elapsed Time (s): ', elapsed_time( t1(:), t0(:) )
!
!
! END OF PROGRAM ex1_elapsed_time
! ===============================
!
end program ex1_elapsed_time

ex1_fastgivens_mat_left.F90

program ex1_fastgivens_mat_left
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine FASTGIVENS_MAT_LEFT 
!   in module Giv_Procedures . 
!                                                                              
! LATEST REVISION : 26/06/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, one, fastgivens_mat_left
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, m=1000, n=500, np1=n+1
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)               :: err
    real(stnd), dimension(m) :: a(m,n), syst(m,np1), x(n), b, res, d
!
    integer(i4b) :: i
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of fastgivens_mat_left'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A RANDOM COEFFICIENT MATRIX a .
!
    call random_number( a )
!
!   GENERATE A RANDOM RIGHT HAND-SIDE VECTOR b .
!
    call random_number( b )
!
!   MAKE A COPY OF COEFFICIENT MATRIX a(:m,:n) .
!
    syst(:m,:n) = a(:m,:n)
!
!   MAKE A COPY OF RIGHT HAND-SIDE VECTOR b(:m) .
!
    syst(:m,np1) = b(:m)
!
!   EXAMPLE : LINEAR LEAST SQUARES SYSTEM.
!
!   COMPUTE SOLUTION VECTOR FOR LINEAR LEAST SQUARES SYSTEM
!
!             a(:m,:n)*x(:n)=b(:m) .
!
    d(:m) = one
!
!   TRANSFORM THE MATRIX a TO UPPER TRAPEZOIDAL FORM BY APPLYING 
!   A SERIE OF FAST GIVENS PLANE ROTATIONS ON THE ROWS OF a AND APPLY
!   THE ROTATIONS TO b .
!
    call fastgivens_mat_left( syst(:m,:np1), d(:m) )
!    
!   SOLVE THE n BY n UPPER TRIANGULAR SYSTEM.
!    
    do i = n, 1, -1
        x(i) = syst(i,np1)/syst(i,i)
        syst(1:i-1,np1) = syst(1:i-1,np1) - x(i)*syst(1:i-1,i)
    end do
!
!   CHECK THAT THE RESIDUALS ARE ORTHOGONAL TO THE COLUMN VECTORS OF a .
!
    res(:m) = b(:m) - matmul( a(:m,:n), x(:n) )
    err = sum(abs(matmul(res(:m)  ,a(:m,:n))) )/ sum( abs(a(:m,:n)) )
!
!   PRINT THE RESULT OF THE TEST.
!
    if ( err<=sqrt(epsilon(err)) ) then
        write (prtunit,*) 'Example 1 of FASTGIVENS_MAT_LEFT is correct'
    else
        write (prtunit,*) 'Example 1 of FASTGIVENS_MAT_LEFT is incorrect'
    end if
!
!
! END OF PROGRAM ex1_fastgivens_mat_left
! ======================================
!
end program ex1_fastgivens_mat_left

ex1_fastgivens_mat_right.F90

program ex1_fastgivens_mat_right
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine FASTGIVENS_MAT_RIGHT 
!   in module Giv_Procedures . 
!                                                                              
! LATEST REVISION : 26/06/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, one, fastgivens_mat_right
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, m=1000, n=500, np1=n+1
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)               :: err
    REAL(stnd), DIMENSION(m) :: a(n,m), syst(np1,m), x(n), b, res, d
!
    integer(i4b) :: i
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of fastgivens_mat_right'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A RANDOM COEFFICIENT MATRIX a .
!
    call random_number( a )
!
!   GENERATE A RANDOM RIGHT HAND-SIDE VECTOR b .
!
    call random_number( b )
!
!   MAKE A COPY OF COEFFICIENT MATRIX a(:n,:m) .
!
    syst(:n,:m) = a(:n,:m)
!
!   MAKE A COPY OF RIGHT HAND-SIDE VECTOR b(:m) .
!
    syst(np1,:m) = b(:m)
!
!   EXAMPLE : LINEAR LEAST SQUARES SYSTEM.
!
!   COMPUTE SOLUTION VECTOR FOR LINEAR LEAST SQUARES SYSTEM
!
!             x(:n)*a(:n,:m)*=b(:m) .
!
    d(:m) = one
!
!   TRANSFORM THE MATRIX a TO UPPER TRAPEZOIDAL FORM BY APPLYING 
!   A SERIE OF FAST GIVENS PLANE ROTATIONS ON THE ROWS OF a AND APPLY
!   THE ROTATIONS TO b .
!
    call fastgivens_mat_right( syst(:np1,:m), d(:m) )
!    
!   SOLVE THE n BY n LOWER TRIANGULAR SYSTEM.
!    
    do i = n, 1, -1
        x(i) = ( syst(np1,i) - dot_product(syst(i+1:n,i),x(i+1:n)) )/syst(i,i)
    end do
!
!   CHECK THAT THE RESIDUALS ARE ORTHOGONAL TO THE COLUMN VECTORS OF a .
!
    res(:m) = b(:m) - matmul( x(:n), a(:n,:m) )
    err = sum(abs(matmul(a(:n,:m),res(:m))) )/ sum( abs(a(:n,:m)) )
!
!   PRINT THE RESULT OF THE TEST.
!
    if ( err<=sqrt(epsilon(err)) ) then
        write (prtunit,*) 'Example 1 of FASTGIVENS_MAT_RIGHT is correct'
    else
        write (prtunit,*) 'Example 1 of FASTGIVENS_MAT_RIGHT is incorrect'
    end if
!
!
! END OF PROGRAM ex1_fastgivens_mat_right
! =======================================
!
end program ex1_fastgivens_mat_right

ex1_fft.F90

program ex1_fft
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine FFT
!   in module FFT_Procedures .
!                                                                              
! LATEST REVISION : 15/06/2018
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, one, true, false, init_fft, fft, end_fft,  &
                              merror, allocate_error
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=1000024
!
    character(len=*), parameter :: name_proc='Example 1 of fft'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    integer      :: iok, istart, iend, irate, imax, itime
!
    real(stnd)                            :: err, eps, elapsed_time
    real(stnd), dimension(:), allocatable :: y
!
    complex(stnd), dimension(:), allocatable :: a, c
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : FORWARD AND BACKWARD FFTS OF A COMPLEX SEQUENCE.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = sqrt( epsilon( err ) )
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( y(2_i4b*n), a(n), c(n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM NUMBER COMPLEX SEQUENCE.
!
    call random_number(y)
!
    a(:) = cmplx( y(1_i4b:n), y(n+1_i4b:2_i4b*n), kind=stnd)
!
!   SAVE THE COMPLEX SEQUENCE.
!
    c(:) = a(:)
!
!   INITIALIZE THE FFT SUBROUTINE.
!
    call init_fft( n )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   TRANSFORM AND THEN INVERT THE SEQUENCE BACK.
!
    call fft( a(:), forward=true  )
    call fft( a(:), forward=false )
!
!   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 )
!
    call end_fft()
!
!   CHECK THAT INVERSE(TRANSFORM(SEQUENCE)) = SEQUENCE.
!
    err = maxval(abs(c(:)-a(:)))/maxval(abs(c(:)))
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( y, a, c )
!
    if ( err<=eps  ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    write (prtunit,*)
    write (*,'(a,i8,a,0pd12.4,a)')    &
      'The elapsed time for computing the forward and backward FFTs of a complex sequence of size ', &
       n, ' is', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_fft
! ======================
!
end program ex1_fft

ex1_fft_row.F90

program ex1_fft_row
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine FFT_ROW
!   in module FFT_Procedures.
!                                                                              
! LATEST REVISION : 15/06/2018
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, one, true, false, init_fft, fft_row, end_fft, merror, allocate_error
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6,  n=1000024
!
    character(len=*), parameter :: name_proc='Example 1 of fft_row'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    integer :: iok, istart, iend, irate, imax, itime
!
    real(stnd)                            :: err, eps, elapsed_time
    real(stnd), dimension(:), allocatable :: y
!
    complex(stnd), dimension(:), allocatable :: a, c
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : FORWARD AND BACKWARD FFTS OF A COMPLEX SEQUENCE.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = sqrt( epsilon( err ) )
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( y(2_i4b*n), a(n), c(n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM NUMBER COMPLEX SEQUENCE.
!
    call random_number(y)
!
    a(:) = cmplx( y(1:n), y(n+1_i4b:2_i4b*n), kind=stnd)
!
!   SAVE THE COMPLEX SEQUENCE.
!
    c(:) = a(:)
!
!   INITIALIZE THE FFT SUBROUTINE.
!
    call init_fft( n )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   TRANSFORM AND THEN INVERT THE SEQUENCE BACK.
!
    call fft_row( a(:), forward=true  )
    call fft_row( a(:), forward=false )
!
!   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 )
!
    call end_fft()
!
!   CHECK THAT INVERSE(TRANSFORM(SEQUENCE)) = SEQUENCE.
!
    err = maxval(abs(c(:)-a(:)))/maxval(abs(c(:)))
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( y, a, c )
!
    if ( err<=eps  ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    write (prtunit,*)
    write (*,'(a,i8,a,0pd12.4,a)')    &
      'The elapsed time for computing the forward and backward FFTs of a complex sequence of size ', &
       n, ' is', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_fft_row
! ==========================
!
end program ex1_fft_row

ex1_fftxy.F90

program ex1_fftxy
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine FFTXY
!   in module FFT_Procedures.
!                                                                              
! LATEST REVISION : 15/06/2016
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, one, true, false, init_fft, fft, fftxy, &
                         end_fft, merror, allocate_error
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=1000024
!
    character(len=*), parameter :: name_proc='Example 1 of fftxy'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    integer :: iok, istart, iend, irate, imax, itime
!
    real(stnd)                            :: errx, erry, eps, elapsed_time
    real(stnd), dimension(:), allocatable :: x, y, x2, y2
!
    complex(stnd), dimension(:), allocatable :: fftx, ffty
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TESTS.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : FORWARD FFTS OF TWO REAL SEQUENCES.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = sqrt( epsilon( errx ) )
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( x(n), y(n), x2(n), y2(n), fftx(n), ffty(n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE TWO RANDOM NUMBER REAL SEQUENCES.
!
    call random_number( x(:n) )
    call random_number( y(:n) )
!
!   SAVE THE REAL SEQUENCES.
!
    x2(:n) = x(:n)
    y2(:n) = y(:n)
!
!   INITIALIZE THE FFT SUBROUTINE.
!
    call init_fft( n )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   TRANSFORM AND THEN INVERT THE TWO REAL SEQUENCES BACK.
!
    call fftxy( x(:n), y(:n), fftx(:n), ffty(:n)  )
!
!   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 )
!
    call fft( fftx(:n), forward=false  )
    x(:n) = real( fftx(:n) )
!
    call fft( ffty(:n), forward=false )
    y(:n) = real( ffty(:n) )
!
    call end_fft()
!
!   CHECK THAT INVERSE(TRANSFORM(SEQUENCE)) = SEQUENCE.
!
    errx = maxval(abs(x2(:n)-x(:n)))/maxval(abs(x2(:n)))
    erry = maxval(abs(y2(:n)-y(:n)))/maxval(abs(y2(:n)))
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( x, y, x2, y2, fftx, ffty )
!
!   PRINT RESULT OF THE TEST.
!
    if (max(errx,erry)<=eps  ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    write (prtunit,*)
    write (*,'(a,i8,a,0pd12.4,a)')    &
      'The elapsed time for computing the forward FFTs of two real sequences of size ', &
       n, ' is', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_fftxy
! ========================
!
end program ex1_fftxy

ex1_freq_func.F90

program ex1_freq_func
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of functions/subroutines BD_COEF
!   and FREQ_FUNC in module Time_Series_Procedures.
!                                                                              
! LATEST REVISION : 28/11/2007
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, zero, half, one, true, merror, allocate_error,   &
                         bd_coef, freq_func, init_fft, fft, end_fft
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT, n IS THE LENGTH OF THE TIME SERIES .
!
    integer(i4b), parameter :: prtunit=6, n=200
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                            :: err, fch, fcl
    real(stnd), dimension(n)              :: freqr, freqr2, coef2
    real(stnd), dimension(:), allocatable :: coef
!
    complex(stnd), dimension(n)           :: coefc
!
    integer(i4b) :: k, k1, k2, pl, ph, khalf, kmid
!   
    integer :: iok
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of freq_func'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   pl IS THE MINIMUM PERIOD OF OSCILLATION OF DESIRED COMPONENT.
!   ph IS THE MAXIMUM PERIOD OF OSCILLATION OF DESIRED COMPONENT.
!   pl AND ph ARE EXPRESSED IN NUMBER OF OBSERVATIONS, I.E. pl=6(18) and ph=32(96) SELECT
!   PERIODS BETWEEN 1.5 YRS AND 8 YRS FOR QUARTERLY (MONTHLY) DATA.
!
    pl  = 18
    ph  = 96
!
!   COMPUTE THE CORRESPONDING CUTOFF FREQUENCIES.
!
    fch = one/real( ph, stnd )
    fcl = one/real( pl, stnd )
!
!   NOW SELECT THE OPTIMAL NUMBER OF FILTER COEFFICIENTS k FOR THE LANCZOS FILTER.
!
    k1  = ceiling( one/(half-fcl) )
    k2  = ceiling(  2.6/(fcl-fch) )
    k   = max( k1, k2, ph+1 )
!
!   CHECK IF k IS ODD.
!
    if ( (k/2)*2==k  ) k = k + 1
!
!   ALLOCATE WORK ARRAY FOR THE FILTER COEFFICIENTS.
!
    allocate( coef(k), stat=iok )
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   FUNCTION bd_coef COMPUTES THE K-TERM LEAST SQUARES APPROXIMATION TO AN
!   -IDEAL- BAND PASS FILTER WITH CUTOFF PERIODS PL AND PH (EG CUTOFF FREQUENCIES 1/PL AND 1/PH).
!
    coef(:k) = bd_coef( PL=pl, PH=ph, K=k )
!
!   NOW COMPUTE THE TRANSFERT FUNCTION freqr(:) OF THE LANCZOS FILTER AT THE FOURIER FREQUENCIES.
!
    call freq_func( NFREQ=n, COEF=coef(:k), FREQR=freqr(:n), FOUR_FREQ=true )
!
!   NOW, COMPUTE THE TRANSFERT FUNCTION DIRECTLY WITH THE FFT.
!
    kmid  = ( k + 1 )/2
    khalf = ( k - 1 )/2
!
    coef2(:n)          = zero
    coef2(:kmid)       = coef(kmid:k)
    coef2(n-khalf+1:n) = coef(1:khalf)
!
!   FIRST INITIALIZE THE FFT SUBROUTINE.
!
    call init_fft( n )
!
!   TRANSFORM THE TIME SERIES.
!
    coefc(:n) = cmplx( coef2(:n), zero, kind=stnd )
!
    call fft( coefc(:n), FORWARD=true  )
!
    freqr2(:n) = real( coefc(:n),  kind=stnd )
!
!   DEALLOCATE WORK ARRAYS.
!
    call end_fft()
!
    deallocate( coef )
!
!   TEST THE ACCURACY OF THE RESULTS.
!
    err = maxval(abs(freqr(:n)-freqr2(:n)))/maxval(abs(freqr(:n)))
!
    if ( err<=sqrt(epsilon(err))  ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex1_freq_func
! ============================
!
end program ex1_freq_func

ex1_gchol_cmp.F90

program ex1_gchol_cmp
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines GCHOL_CMP and CHOL_SOLVE
!   in module Lin_Procedures . 
!                                                                              
! LATEST REVISION : 18/06/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, zero, c10, true, false, gchol_cmp, &
                         chol_solve, 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
!
    integer(i4b), parameter :: prtunit=6, n=4000, m=n-10
!
    real(stnd), parameter :: fudge=c10
!
    character(len=*), parameter :: name_proc='Example 1 of gchol_cmp'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, eps, tol, d1, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, a2, c
    real(stnd), dimension(:),   allocatable :: invdiag, b, b2, d, res
!
    integer(i4b) :: krank
    integer      :: iok, istart, iend, irate, imax, itime
!
    logical(lgl)   :: do_test, upper
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : SOLVING A LINEAR SYSTEM WITH A REAL n-BY-n SYMMETRIC SEMI-DEFINITE POSITIVE
!               MATRIX AND ONE RIGHT HAND-SIDE WITH THE CHOLESKY DECOMPOSITION.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    tol = sqrt( epsilon( err ) )
    eps = fudge*tol
    err = zero
!
    do_test = true
    upper   = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( c(m,n), a(n,n), b(n), invdiag(n), d(m), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-by-n RANDOM SYMMETRIC POSITIVE SEMIDEFINITE MATRIX a .
!
    call random_number( c )
!
    a = matmul( transpose(c), c )
!
!   GENERATE A RANDOM RIGHT HAND-SIDE VECTOR b BELONGING TO THE RANGE OF a.
!
    call random_number( d )
!
    b = matmul( transpose(c), d )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS .
!
        allocate(  a2(n,n), b2(n), res(n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       MAKE A COPY OF THE COEFFICIENT MATRIX AND RIGHT HAND-SIDE VECTOR .
!
        a2(:n,:n) = a(:n,:n)
        b2(:n)    = b(:n)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   COMPUTE THE SOLUTION VECTOR FOR SYMMETRIC POSITIVE SEMIDEFINITE
!   SYSTEM
!
!                     a*x = b .
!
!   BY COMPUTING THE CHOLESKY DECOMPOSITION OF MATRIX a .
!   IF ON OUTPUT OF gchol_cmp d1 IS GREATER OR EQUAL TO ZERO
!   THEN THE SYMMETRIC LINEAR SYSTEM CAN BE SOLVED BY 
!   SUBROUTINE chol_solve.
!
    call gchol_cmp( a, invdiag, krank, d1, tol=tol, upper=upper )
!
    if ( d1<zero ) then
!
!       ANORMAL EXIT FROM gchol_cmp SUBROUTINE, PRINT A WARNING.
!
        write (prtunit,*) 'Error in exit of GCHOL_CMP subroutine, d1=', d1
        write (prtunit,*)
!
    else
!
!       SOLVE THE SYMMETRIC LINEAR SYSTEM.
!
        call chol_solve( a, invdiag, b, upper=upper )
!
    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 ( d1>=zero .and. do_test ) then
!
!       CHECK THE RESULTS FOR SMALL RESIDUALS.
!
        res(:n) = b2(:n) - matmul( a2, b(:n) )
        err = norm(res) / ( real(n,stnd)*( norm(a2) + norm(b2) ) )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( do_test ) then
        deallocate( a, b, c, d, invdiag, a2, b2, res )
    else
        deallocate( a, b, c, d, invdiag )
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. d1>=zero ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,0pd12.4,a)')    &
      'The elapsed time for solving a positive semi-definite symmetric system of size ', &
       n, ' is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_gchol_cmp
! ============================
!
end program ex1_gchol_cmp

ex1_gchol_cmp2.F90

program ex1_gchol_cmp2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine GCHOL_CMP2
!   in module Lin_Procedures . 
!                                                                              
! LATEST REVISION : 18/06/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, zero, c10, true, false, gchol_cmp2,  &
                         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
!
    integer(i4b), parameter :: prtunit=6, n=4000, m=n-10_i4b
!
    real(stnd), parameter :: fudge=c10
!
    character(len=*), parameter :: name_proc='Example 1 of gchol_cmp2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, eps, tol, d1, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, a2, ainv, c, res
    real(stnd), dimension(:),   allocatable :: invdiag
!
    integer(i4b) :: j, krank
    integer      :: iok, istart, iend, irate, imax, itime
!
    logical(lgl)   :: do_test, upper
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : COMPUTING A SYMMETRIC GENERALIZED INVERSE OF A REAL n-BY-n SYMMETRIC SEMI-DEFINITE
!               POSITIVE MATRIX WITH THE CHOLESKY DECOMPOSITION.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    tol = sqrt( epsilon( err ) )
    eps = fudge*tol
    err = zero
!
    do_test = true
    upper   = false
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( c(m,n), a(n,n), ainv(n,n), invdiag(n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-by-n RANDOM SYMMETRIC POSITIVE SEMIDEFINITE MATRIX a .
!
    call random_number( c )
!
    a = matmul( transpose(c), c )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( a2(n,n), res(n,n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       MAKE A COPY OF THE SYMMETRIC POSITIVE SEMIDEFINITE 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 )
!
!   COMPUTE A GENERALIZED INVERSE OF A SYMMETRIC POSITIVE SEMIDEFINITE
!   MATRIX a BY USING THE CHOLESKY DECOMPOSITION OF a .
!
!   IF ON OUTPUT OF gchol_cmp2 d1 IS GREATER OR EQUAL TO ZERO
!   THEN THE SYMMETRIC MATRIX IS POSITIVE SEMIDEFINITE AND A
!   SYMMETRIC GENERALIZED INVERSE OF a HAS BEEN COMPUTED.
!
    call gchol_cmp2( a, invdiag, krank, d1, tol=tol, matinv=ainv, upper=upper, fill=true )
!
!   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 ( d1<zero ) then
!
!       ANORMAL EXIT FROM gchol_cmp2 SUBROUTINE, PRINT A WARNING.
!
        write (prtunit,*) 'Error in exit of GCHOL_CMP2 subroutine, d1=', d1
        write (prtunit,*)
!
    else if ( do_test ) then
!
!       CHECK THE IDENTITIES a*ainv*a = a AND  ainv*a*ainv = ainv ,
!       WHICH DEFINE THE GENERALIZED INVERSE OF a.
!
        res  = matmul(a2, matmul(ainv,a2)) - a2
        err1 = norm(res) / ( real(n,stnd)*norm(a2) )
!
        res = matmul(ainv, matmul(a2,ainv)) - ainv
        err2 = norm(res) / ( real(n,stnd)*norm(ainv) )
!
        err = max( err1, err2 )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( do_test ) then
        deallocate( a, ainv, c, invdiag, a2, res )
    else
        deallocate( a, ainv, c, invdiag )
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. d1>=zero ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    write (prtunit,*)
    write (*,'(a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing a (generalized) inverse of a positive semi-definite symmetric matrix of size ', &
       n, ' is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_gchol_cmp2
! =============================
!
end program ex1_gchol_cmp2

ex1_ginv.F90

program ex1_ginv
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of function GINV
!   in module SVD_Procedures. 
!                                                                              
! LATEST REVISION : 18/06/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, ginv, norm, &
                         c10, 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
!
    integer(i4b), parameter :: prtunit=6, m=4000, n=2000, k=min(m,n)
!   
    real(stnd), parameter  :: fudge=c10
!
    character(len=*), parameter :: name_proc='Example 1 of ginv'
!   
!   
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: eps, err, err1, err2, err3, err4, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, a2, ainv, ainv2, a_by_ainv, ainv_by_a
!
    integer :: 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 : COMPUTING THE GENERALIZED INVERSE OF A m-BY-n REAL MATRIX USING
!               THE SINGULAR VALUE DECOMPOSITION.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*sqrt( epsilon(eps) )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(m,n), ainv(n,m), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM DATA MATRIX.
!
    call random_number( a )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   COMPUTE GENERALIZED INVERSE OF a(:m,:n) WITH FUNCTION ginv.
!
    ainv(:n,:m) = ginv( a(:m,:n) )
!
!   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 ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( a2(m,n), ainv2(n,m), a_by_ainv(m,m),   &
                  ainv_by_a(n,n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE ainv*a AND a*ainv*a .
!
        ainv_by_a = matmul( ainv, a )
        a2        = matmul( a, ainv_by_a )
!
!       COMPUTE a*ainv AND ainv*a*ainv .
!
        a_by_ainv = matmul( a, ainv )
        ainv2     = matmul( ainv, a_by_ainv )
!
!       CHECK THE Moore-Penrose EQUATIONS :
!
!             a*ainv*a = a            (1)
!          ainv*a*ainv = ainv         (2)
!            (a*ainv)' = a*ainv       (3)
!            (ainv*a)' = ainv*a       (4)
!
        err1 = norm( a - a2 )
        err2 = norm( ainv - ainv2 )
        err3 = norm( a_by_ainv - transpose(a_by_ainv) )
        err4 = norm( ainv_by_a - transpose(ainv_by_a) )
!
        err = max( err1, err2, err3, err4 )/ ( real(k,stnd)*norm(a) )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a2, ainv2, a_by_ainv, ainv_by_a )        
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, ainv )
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing the generalized inverse of a ', &
       m, ' by ', n,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_ginv
! =======================
!
end program ex1_ginv

ex1_givens_mat_left.F90

program ex1_givens_mat_left
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine GIVENS_MAT_LEFT 
!   in module Giv_Procedures . 
!                                                                              
! LATEST REVISION : 26/06/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, givens_mat_left
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, m=1000, n=500, np1=n+1
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)               :: err
    real(stnd), dimension(m) :: a(m,n), syst(m,np1), x(n), b, res
!
    integer(i4b) :: i
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of givens_mat_left'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A RANDOM COEFFICIENT MATRIX a .
!
    call random_number( a )
!
!   GENERATE A RANDOM RIGHT HAND-SIDE VECTOR b .
!
    call random_number( b )
!
!   MAKE A COPY OF COEFFICIENT MATRIX a(:m,:n) .
!
    syst(:m,:n) = a(:m,:n)
!
!   MAKE A COPY OF RIGHT HAND-SIDE VECTOR b(:m) .
!
    syst(:m,np1) = b(:m)
!
!   EXAMPLE : LINEAR LEAST SQUARES SYSTEM.
!
!   COMPUTE SOLUTION VECTOR FOR LINEAR LEAST SQUARES SYSTEM
!
!             a(:m,:n)*x(:n)=b(:m) .
!
!   TRANSFORM THE MATRIX a TO UPPER TRAPEZOIDAL FORM BY APPLYING 
!   A SERIE OF GIVENS PLANE ROTATIONS ON THE ROWS OF a AND APPLY
!   THE ROTATIONS TO b .
!
    call givens_mat_left( syst(:m,:np1) )
!    
!   SOLVE THE n BY n UPPER TRIANGULAR SYSTEM.
!    
    do i = n, 1, -1
        x(i) = syst(i,np1)/syst(i,i)
        syst(1:i-1,np1) = syst(1:i-1,np1) - x(i)*syst(1:i-1,i)
    end do
!
!   CHECK THAT THE RESIDUALS ARE ORTHOGONAL TO THE COLUMN VECTORS OF a .
!
    res(:m) = b(:m) - matmul( a(:m,:n), x(:n) )
    err = sum(abs(matmul(res(:m)  ,a(:m,:n))) )/ sum( abs(a(:m,:n)) )
!
!   PRINT THE RESULT OF THE TEST.
!
    if ( err<=sqrt(epsilon(err)) ) then
        write (prtunit,*) 'Example 1 of GIVENS_MAT_LEFT is correct'
    else
        write (prtunit,*) 'Example 1 of GIVENS_MAT_LEFT is incorrect'
    end if
!
!
! END OF PROGRAM ex1_givens_mat_left
! ==================================
!
end program ex1_givens_mat_left

ex1_givens_mat_right.F90

program ex1_givens_mat_right
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine GIVENS_MAT_RIGHT 
!   in module Giv_Procedures . 
!                                                                              
! LATEST REVISION : 26/06/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, givens_mat_right
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, m=1000, n=500, np1=n+1
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)               :: err
    real(stnd), dimension(m) :: a(n,m), syst(np1,m), x(n), b, res
!
    integer(i4b) :: i
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of givens_mat_right'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A RANDOM COEFFICIENT MATRIX a .
!
    call random_number( a )
!
!   GENERATE A RANDOM RIGHT HAND-SIDE VECTOR b .
!
    call random_number( b )
!
!   MAKE A COPY OF COEFFICIENT MATRIX a(:n,:m) .
!
    syst(:n,:m) = a(:n,:m)
!
!   MAKE A COPY OF RIGHT HAND-SIDE VECTOR b(:m) .
!
    syst(np1,:m) = b(:m)
!
!   EXAMPLE : LINEAR LEAST SQUARES SYSTEM.
!
!   COMPUTE SOLUTION VECTOR FOR LINEAR LEAST SQUARES SYSTEM
!
!                      x(:n)*a(:n,:m)*=b(:m) .
!
!   TRANSFORM THE MATRIX a TO UPPER TRAPEZOIDAL FORM BY APPLYING 
!   A SERIE OF GIVENS PLANE ROTATIONS ON THE ROWS OF a AND APPLY
!   THE ROTATIONS TO b .
!
    call givens_mat_right( syst(:np1,:m) )
!    
!   SOLVE THE n BY n LOWER TRIANGULAR SYSTEM.
!    
    do i = n, 1, -1
        x(i) = ( syst(np1,i) - dot_product(syst(i+1:n,i),x(i+1:n)) )/syst(i,i)
    end do
!
!   CHECK THAT THE RESIDUALS ARE ORTHOGONAL TO THE COLUMN VECTORS OF a .
!
    res(:m) = b(:m) - matmul( x(:n), a(:n,:m) )
    err = sum(abs(matmul(a(:n,:m),res(:m))) )/ sum( abs(a(:n,:m)) )
!
!   PRINT THE RESULT OF THE TEST.
!
    if ( err<=sqrt(epsilon(err)) ) then
        write (prtunit,*) 'Example 1 of GIVENS_MAT_RIGHT is correct'
    else
        write (prtunit,*) 'Example 1 of GIVENS_MAT_RIGHT is incorrect'
    end if
!
!
! END OF PROGRAM ex1_givens_mat_right
! ==================================
!
end program ex1_givens_mat_right

ex1_hp_coef.F90

program ex1_hp_coef
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines/functions HP_COEF
!   and SYMLIN_FILTER in module Time_Series_Procedures.
!                                                                              
! LATEST REVISION : 30/11/2007
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, zero, half, one, two, pi, true, false, merror, allocate_error, arth,   &
                         hp_coef, symlin_filter, init_fft, fft, end_fft
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT, n IS THE LENGTH OF THE TIME SERIES .
!
    integer(i4b), parameter :: prtunit=6, n=2000
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                            :: err, tmp, fch
    real(stnd), dimension(n)              :: y, y2, y3, freq, freqr, tmpvec
    real(stnd), dimension(:), allocatable :: coef
!
    complex(stnd), dimension(n)           :: yc
!
    integer(i4b) :: i, k, k1, k2, ph, nfilt, khalf, kmid
!   
    integer :: iok
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of hp_coef'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A RANDOM REAL NUMBER SEQUENCE OF LENGTH n .
!
    call random_number( y(:n) )
!
!   SAVE THE REAL RANDOM NUMBER ARRAY.
!
    y2(:n) = y(:n)
!
!   ph IS THE MAXIMUM PERIOD OF OSCILLATION OF DESIRED COMPONENT.
!   ph IS EXPRESSED IN NUMBER OF OBSERVATIONS, I.E. pc==32(96) SELECT
!   A PERIOD OF 8 YRS FOR QUARTERLY (MONTHLY) DATA.
!
    ph  = 32
!
!   COMPUTE THE CORRESPONDING CUTOFF FREQUENCY fch .
!
    fch = one/real( ph, stnd )
!
!   NOW SELECT THE OPTIMAL NUMBER OF FILTER COEFFICIENTS k FOR THE LANCZOS FILTER.
!
    i = ceiling( one/(half-fch) )
    k = max( i, ph+1 )
!
!   CHECK IF k IS ODD.
!
    if ( (k/2)*2==k  ) k = k + 1
!
!   ALLOCATE WORK ARRAY FOR THE FILTER COEFFICIENTS.
!
    allocate( coef(k), stat=iok )
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   FUNCTION hp_coef COMPUTES THE K-TERM LEAST SQUARES APPROXIMATION TO AN
!   -IDEAL- HIGH-PASS FILTER WITH CUTOFF PERIODS PH (EG CUTOFF FREQUENCY 1/PH).
!
    coef(:k) = hp_coef( PH=ph, K=k )
!
!   SUBROUTINE symlin_filter PERFORMS A SYMMETRIC FILTERING OPERATION ON AN IMPUT
!   TIME SERIES (THE ARGUMENT VEC).
!
!   HERE symlin_filter FILTERS THE TIME SERIES .
!   NOTE THAT (size(COEF)-1)/2 DATA POINTS WILL BE LOST FROM EACH END OF THE SERIES SO THAT
!   NFILT (NFILT= size(VEC) - size(COEF) + 1) TIME OBSERVATIONS ARE RETURNED IN VEC(:NFILT)
!   AND THE REMAINING OBSERVATIONS ARE SET TO ZERO.
!
    call symlin_filter( VEC=y2(:n), COEF=coef(:k),  NFILT=nfilt )
!
!   NOW COMPUTE THE TRANSFERT FUNCTION freqr(:) OF THE LANCZOS FILTER AT THE FOURIER FREQUENCIES.
!
    kmid  = ( k + 1 )/2
    khalf = ( k - 1 )/2
!
    freqr(:n) = coef(kmid)
!
    tmp        = (two*pi)/real( n, stnd )
    freq(:n)   = arth( zero, tmp, n )
    tmpvec(:n) = zero
!
    do i = 1, khalf
        tmpvec(:n) = tmpvec(:n) + freq(:n)
        freqr(:n)  = freqr(:n)  + two*coef(kmid+i)*cos( tmpvec(:n) )
    end do
!
!   NOW, APPLY THE FILTER USING THE FFT AND THE CONVOLUTION THEOREM.
!
!   INITIALIZE THE FFT SUBROUTINE.
!
    call init_fft( n )
!
!   TRANSFORM THE TIME SERIES.
!
    yc(:n) = cmplx( y(1:n), zero, kind=stnd )
!
    call fft( yc(:n), forward=true  )
!
!   MULTIPLY THE FOURIER TRANSFORM OF THE TIME SERIES
!   BY THE TRANSFERT FUNCTION OF THE FILTER.
!
    yc(:n) = yc(:n)*freqr(:n)
!
!   INVERT THE SEQUENCE BACK TO GET THE FILTERED TIME SERIES.
!
    call fft( yc(:n), forward=false )
!
    y3(:n) = real( yc(:n),  kind=stnd )
!
!   DEALLOCATE WORK ARRAYS.
!
    call end_fft()
!
    deallocate( coef )
!
!   TEST THE ACCURACY OF THE FILTERING OPERATION.
!
    k1    = kmid
    k2    = n - khalf
!
    err = maxval(abs(y3(k1:k2)-y2(:nfilt)))/maxval(abs(y(k1:k2)))
!
    if ( err<=sqrt(epsilon(err))  ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex1_hp_coef
! ==========================
!
end program ex1_hp_coef

ex1_hp_coef2.F90

program ex1_hp_coef2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines/functions HP_COEF2
!   and SYMLIN_FILTER2 in module Time_Series_Procedures.
!                                                                              
! LATEST REVISION : 29/11/2007
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, true, merror, allocate_error,   &
                         hp_coef2, symlin_filter2
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT, n IS THE LENGTH OF THE TIME SERIES .
!
    integer(i4b), parameter :: prtunit=6, n=2001
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                            :: err
    real(stnd), dimension(n)              :: y, y2, y3
    real(stnd), dimension(:), allocatable :: coef
!
    integer(i4b) :: k, k1, k2, ph, khalf, kmid
!   
    integer :: iok
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of hp_coef2'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A RANDOM REAL NUMBER SEQUENCE OF LENGTH n .
!
    call random_number( y(:n) )
!
!   SAVE THE REAL RANDOM NUMBER ARRAY.
!
    y2(:n) = y(:n)
    y3(:n) = y(:n)
!
!   ph IS THE MAXIMUM PERIOD OF OSCILLATION OF DESIRED COMPONENT.
!   ph IS EXPRESSED IN NUMBER OF OBSERVATIONS, I.E. ph==32(96) SELECT
!   A PERIOD OF 8 YRS FOR QUARTERLY (MONTHLY) DATA.
!
    ph  = 32
!
!   NOW SELECT THE NUMBER OF FILTER COEFFICIENTS k FOR THE HAMMING FILTER.
!
    k = ph + 1
!
!   CHECK IF k IS ODD.
!
    if ( (k/2)*2==k )  k = k + 1
!
!   ALLOCATE WORK ARRAY FOR THE FILTER COEFFICIENTS.
!
    allocate( coef(k), stat=iok )
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   FUNCTION hp_coef2 COMPUTES THE K-TERM LEAST SQUARES APPROXIMATION TO AN
!   -IDEAL- HIGH-PASS FILTER WITH CUTOFF PERIODS PH (EG CUTOFF FREQUENCY 1/PH).
!
    coef(:k) = hp_coef2( PH=ph, K=k )
!
!   SUBROUTINE symlin_filter2 PERFORMS A SYMMETRIC FILTERING OPERATION ON AN IMPUT
!   TIME SERIES (THE ARGUMENT VEC).
!
!   HERE symlin_filter2 FILTERS THE TIME SERIES .
!   NOTE THAT (size(COEF)-1)/2 DATA POINTS WILL BE AFFECTED BY END EFFECTS  FROM EACH END OF THE SERIES.
!
    call symlin_filter2( VEC=y2(:n), COEF=coef(:k) )
!
!   FILTER AGAIN THE TIME SERIES, BUT COMPUTE THE VALUES AT THE ENDS OF THE OUTPUT
!   BY ASSUMING THAT THE INPUT IS PART OF A PERIODIC SEQUENCE OF PERIOD n .
!
    call symlin_filter2( VEC=y3(:n), COEF=coef(:k), USEFFT=true )
!
!   DEALLOCATE WORK ARRAY.
!
    deallocate( coef )
!
!   TEST THE ACCURACY OF THE FILTERING OPERATION.
!
    kmid  = ( k + 1 )/2
    khalf = ( k - 1 )/2
!
    k1    = kmid
    k2    = n - khalf
!
    err = maxval(abs(y3(k1:k2)-y2(k1:k2)))/maxval(abs(y(k1:k2)))
!
    if ( err<=sqrt(epsilon(err))  ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex1_hp_coef2
! ===========================
!
end program ex1_hp_coef2

ex1_hwfilter.F90

program ex1_hwfilter
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine HWFILTER
!   in module Time_Series_Procedures .
!                                                                              
! LATEST REVISION : 30/03/2007
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, one, hwfilter
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT, n IS THE LENGTH OF THE TIME SERIES.
!
    integer(i4b), parameter :: prtunit=6, n=5000
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)               :: err, win
    real(stnd), dimension(n) :: y, y2, y3
!
    integer(i4b) :: minp, maxp
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of hwfilter'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A RANDOM REAL NUMBER SEQUENCE OF LENGTH n .
!
    call random_number( y(:n) )
!
!   SAVE THE REAL RANDOM NUMBER ARRAY.
!
    y2(:n) = y(:n)
    y3(:n) = y(:n)
!
    minp  = 18_i4b
    maxp  = 96_i4b
!
!   BY DEFAULT, HAMMMING WINDOW FILTERING IS USED (i.e. win=0.54).
!   SET win=0.5 for HANNING WINDOW OR win=1 FOR RECTANGULAR WINDOW.
!   IN ANY CASE, win MUST BE GREATER OR EQUAL TO 0.5 AND LESS OR EQUAL TO 1.
!
    win = one
!
!   hwfilter FILTERS A TIME SERIES (THE ARGUMENT VEC) IN THE FREQUENCY BAND
!   LIMITED BY PERIODS PL AND PH BY WINDOWED FILTERING (PL AND PH ARE EXPRESSED IN NUMBER OF
!   POINTS, i.e. PL=18 AND PH=96 SELECTS PERIODS BETWEEN 1.5 YRS AND 8 YRS FOR MONTHLY DATA).
!
!   FILTER THE TIME SERIES, KEEP THE PERIODS BETWEEN minp AND maxp .
!
    call hwfilter( VEC=y2(:n), PL=minp, PH=maxp, WIN=win )
!
!   SETTING PH<PL IS ALLOWED AND PERFORMS BAND REJECTION OF PERIODS BETWEEN PH AND PL.
!
!   FILTER THE TIME SERIES, KEEP THE PERIODS OUTSIDE THE BAND BETWEEN minp AND maxp .
!
    call hwfilter( VEC=y3(:n), PL=maxp, PH=minp, WIN=win )
!
!   NOW RECONSTRUCT THE ORIGINAL TIME SERIES FROM THE TWO FILTERED TIME SERIES.
!
    y2(:n) = y2(:n) + y3(:n)
!
!   TEST THE ACCURACY OF THE RECONSTRUCTION.
!
    err = maxval(abs(y(:n)-y2(:n)))/maxval(abs(y(:n)))
!
    if ( err<=sqrt(epsilon(err))  ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex1_hwfilter
! ===========================
!
end program ex1_hwfilter

ex1_hwfilter2.F90

program ex1_hwfilter2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine HWFILTER2
!   in module Time_Series_Procedures .
!                                                                              
! LATEST REVISION : 30/03/2007
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, one, hwfilter2
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT, n IS THE LENGTH OF THE TIME SERIES.
!
    integer(i4b), parameter :: prtunit=6, n=20000
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)               :: err, win
    real(stnd), dimension(n) :: y, y2, y3
!
    integer(i4b) :: minp, maxp
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of hwfilter2'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A RANDOM REAL NUMBER SEQUENCE OF LENGTH n .
!
    call random_number( y(:n) )
!
!   SAVE THE REAL RANDOM NUMBER ARRAY.
!
    y2(:n) = y(:n)
    y3(:n) = y(:n)
!
    minp  = 18_i4b
    maxp  = 96_i4b
!
!   BY DEFAULT, HAMMMING WINDOW FILTERING IS USED (i.e. win=0.54).
!   SET win=0.5 for HANNING WINDOW OR win=1 FOR RECTANGULAR WINDOW.
!   IN ANY CASE, win MUST BE GREATER OR EQUAL TO 0.5 AND LESS OR EQUAL TO 1.
!
    win = one
!
!   hwfilter FILTERS A TIME SERIES (THE ARGUMENT VEC) IN THE FREQUENCY BAND
!   LIMITED BY PERIODS PL AND PH BY WINDOWED FILTERING (PL AND PH ARE EXPRESSED IN NUMBER OF
!   POINTS, i.e. PL=18 AND PH=96 SELECTS PERIODS BETWEEN 1.5 YRS AND 8 YRS FOR MONTHLY DATA).
!
!   FILTER THE TIME SERIES, KEEP THE PERIODS BETWEEN minp AND maxp .
!
    call hwfilter2( VEC=y2(:n), PL=minp, PH=maxp, WIN=win )
!
!   SETTING PH<PL IS ALLOWED AND PERFORMS BAND REJECTION OF PERIODS BETWEEN PH AND PL.
!
!   FILTER THE TIME SERIES, KEEP THE PERIODS OUTSIDE THE BAND BETWEEN minp AND maxp .
!
    call hwfilter2( VEC=y3(:n), PL=maxp, PH=minp, WIN=win )
!
!   NOW RECONSTRUCT THE ORIGINAL TIME SERIES FROM THE TWO FILTERED TIME SERIES.
!
    y2(:n) = y2(:n) + y3(:n)
!
!   TEST THE ACCURACY OF THE RECONSTRUCTION.
!
    err = maxval(abs(y(:n)-y2(:n)))/maxval(abs(y(:n)))
!
    if ( err<=sqrt(epsilon(err))  ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex1_hwfilter2
! ============================
!
end program ex1_hwfilter2

ex1_inv.F90

program ex1_inv
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of fonction INV
!   in module Lin_Procedures . 
!                                                                              
! LATEST REVISION : 18/06/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, is_nan, zero, one, inv, &
                         norm, merror, allocate_error
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=4000
!
    character(len=*), parameter :: name_proc='Example 1 of inv'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, eps, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, ainv, res
!
    integer(i4b) :: j
    integer      :: iok, istart, iend, irate, imax, itime
!
    logical(lgl) :: do_test, failure
!
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : COMPUTE THE INVERSE OF A REAL n-BY-n MATRIX.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = sqrt( epsilon( err ) )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), ainv(n,n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM DATA MATRIX a .
!
    call random_number( a )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   COMPUTE THE MATRIX INVERSE WITH FUNCTION inv.
!
    ainv = inv( a ) 
!
!   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 IF THE MATRIX IS SINGULAR.
!
    failure = is_nan( ainv )
!
    if ( failure ) then
!
!       ANORMAL EXIT FROM inv FUNCTION, PRINT A WARNING.
!
        write (prtunit,*) 'Error in exit of INV function, input matrix is singular'
        write (prtunit,*)
!
    else if ( do_test ) then
!
!       ALLOCATE WORK ARRAY.
!
        allocate( res(n,n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE a TIMES ITS INVERSE - IDENTITY.
!
        res = matmul( a, ainv )
!
        do j = 1_i4b, n
            res(j,j) = res(j,j) - one
        end do
!
        err = norm( res(:n,:n) ) /( real(n,stnd)*norm(a(:n,:n)) )
!
!       DEALLOCATE WORK ARRAY.
!
        deallocate( res )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( ainv, a )
!
!   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 (*,'(a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing the inverse of a real matrix of size ', &
       n, ' by ', n, ' is', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_inv
! ======================
!
end program ex1_inv

ex1_leapyr.F90

program ex1_leapyr
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of function LEAPYR
!   in module Time_Procedures .
!                                                                              
! LATEST REVISION : 26/06/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, lgl, leapyr
!   
!
! STRONG TYPING IMPOSED
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT.
!
    integer(i4b), parameter :: prtunit=6
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    integer(i4b) :: iyr
!   
    logical(lgl) :: is_leapyr
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of leapyr'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A YEAR.
!
    iyr  = 1902
!
!   CHECK IF iyr IS A LEAP YEAR. 
!
    is_leapyr = leapyr( iyr )
!
!   FUNCTION leapyr IS RETURNED AS "true"
!   IF iyr IS A LEAP YEAR, AND "false" OTHERWISE.
!
!   LEAP YEARS ARE YEARS THAT ARE EVENLY DIVISIBLE BY 4, EXCEPT YEARS
!   THAT ARE EVENLY DIVISIBLE BY 100 MUST BE DIVISIBLE BY 400.
!   GREGORIAN CALENDAR ADOPTED OCT. 15, 1582.
!
!   PRINT THE RESULT.
!
    if ( is_leapyr ) then
        write (prtunit,*) 'The year ', iyr,' is a leap year'
    else
        write (prtunit,*) 'The year ', iyr,' is not a leap year'
    end if
!
!
! END OF PROGRAM ex1_leapyr
! =========================
!
end program ex1_leapyr

ex1_lin_lu_solve.F90

program ex1_lin_lu_solve
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine LIN_LU_SOLVE
!   in module Lin_Procedures . 
!                                                                              
! LATEST REVISION : 26/09/2014
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, lin_lu_solve, merror, allocate_error
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=4001
!
    character(len=*), parameter :: name_proc='Example 1 of lin_lu_solve'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, eps, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a
    real(stnd), dimension(:), allocatable   :: b, x, res
!
    integer        :: iok, istart, iend, irate
!
    logical(lgl)   :: failure, do_test
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : REAL MATRIX AND ONE RIGHT HAND-SIDE.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = sqrt( epsilon( err ) )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), b(n), x(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 RANDOM SOLUTION VECTOR x .
!
    call random_number( x )
!
!   COMPUTE THE MATRIX-VECTOR PRODUCT b = a*x .
!
    b = matmul( a, x )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count=istart, count_rate=irate )
!
!   COMPUTE THE SOLUTION VECTOR FOR LINEAR SYSTEM
!
!            a*x = b .
!
!   BY COMPUTING THE LU DECOMPOSITION WITH PARTIAL PIVOTING AND
!   IMPLICIT ROW SCALING OF MATRIX a. IF ON OUTPUT OF lin_lu_solve
!   failure IS SET TO FALSE THEN THE LINEAR SYSTEM IS NOT SINGULAR
!   AND THE SOLUTION VECTOR HAS BEEN COMPUTED.
!
    call lin_lu_solve( a, b, failure )
!
!   STOP THE TIMER.
!
    call system_clock( count=iend )
!
    elapsed_time = real( iend - istart, stnd )/real( irate, stnd )
!
    if ( failure ) then
!
!       ANORMAL EXIT FROM lin_lu_solve SUBROUTINE, PRINT A WARNING.
!
        write (prtunit,*) 'Error in the call to LIN_LU_SOLVE subroutine, failure=', failure
!
    else if ( do_test ) then
!
!       ALLOCATE WORK ARRAY .
!
        allocate( res(n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       CHECK THE RESULTS FOR SMALL RESIDUALS.
!
        res(:n) = b(:n) - x(:n)
        err     = sum( abs(res) ) / sum( abs(x) ) 
!
!       DEALLOCATE WORK ARRAY.
!
        deallocate( res )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, b, x )
!
!   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 (*,'(a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing the solution of a linear real system of size ', &
       n, ' is', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_lin_lu_solve
! ===============================
!
end program ex1_lin_lu_solve

ex1_llsq_qr_solve.F90

program ex1_llsq_qr_solve
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine LLSQ_QR_SOLVE
!   in modules LLSQ_Procedures .
!                                                                              
! LATEST REVISION : 25/07/2014
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, lgl, stnd, zero, true, false, llsq_qr_solve
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, m=4000, n=2000
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, tol
    real(stnd), dimension(m)                :: resid, b
    real(stnd), dimension(n)                :: x
    real(stnd), allocatable, dimension(:,:) :: a
!
    integer(i4b) :: krank
!
    integer      :: iok
!
    logical(lgl) :: do_test
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of llsq_qr_solve'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(m,n), stat=iok )
!
    if ( iok/=0 ) then
        write (prtunit,*)  'Problem in attempt to allocate memory !'
        stop
    end if
!
!   GENERATE A RANDOM COEFFICIENT VECTOR a .
!
    call random_number( a )
!
!   GENERATE A RANDOM RIGHT HAND-SIDE MATRIX b .
!
    call random_number( b )
!
!   EXAMPLE 1 : LINEAR LEAST SQUARES SYSTEM.
!
!   COMPUTE SOLUTION VECTOR FOR LINEAR LEAST SQUARES SYSTEM
!
!           a(:m,:n)*x(:n)=b(:m) .
!
    err      = zero
    do_test  = false
!
!   SET TOLERANCE .
!
    tol = 0.00001_stnd
!
    krank = 0
!
    call llsq_qr_solve( a(:m,:n), b(:m), x(:n),               &
                        krank=krank, tol=tol, resid=resid(:m) )
!
!   llsq_qr_solve COMPUTES SOLUTION(S) TO REAL LINEAR LEAST SQUARES PROBLEMS 
!   OF THE FORM:
!
!                       Minimize 2-norm(| b - a*x |)
!
!   USING AN ORTHOGONAL FACTORIZATION WITH COLUMNS PIVOTING OF a. a IS A m VECTOR
!   OR AN m-BY-n MATRIX WHICH MAY BE RANK-DEFICIENT. IF a IS A MATRIX, m>=n OR
!   n>m IS PERMITTED.
!
!   SEVERAL RIGHT HAND SIDE VECTORS b AND SOLUTION VECTORS x CAN BE
!   HANDLED IN A SINGLE CALL; THEY ARE STORED AS THE COLUMNS OF THE
!   m-BY-nrhs RIGHT HAND SIDE MATRIX b AND THE n-BY-nrhs SOLUTION
!   MATRIX x, RESPECTIVELY. IN OTHER WORDS, THE ARGUMENTS b AND x MAY
!   BE VECTORS OR MATRICES.
!
!   a AND b ARE NOT OVERWRITTEN BY llsq_qr_solve. THE OPTIONAL ARGUMENTS krank,
!   tol AND min_norm MUST NOT BE PRESENT IF a IS A m-VECTOR.
!
!   ON INPUT, IF THE OPTIONAL PARAMETER krank IS SPECIFIED AND IF krank=k,
!   THIS IMPLIES THAT THE FIRST k COLUMNS OF a ARE TO BE FORCED INTO THE BASIS.
!   PIVOTING IS PERFORMED ON THE LAST n-k COLUMNS OF a.
!   
!   WHEN krank>=min(m,n) IS USED, PIVOTING IS NOT PERFORMED. THIS IS
!   APPROPRIATE WHEN a IS KNOWN TO BE FULL RANK. krank<=0 CAN BE USED
!   WHEN PIVOTING IS DESIRED ON ALL COLUMNS OF a.
!   
!   BY DEFAULT, PIVOTING IS DONE ON ALL THE COLUMNS OF a.
!   
!   ON EXIT, IF THE OPTIONAL PARAMETER krank IS SPECIFIED,
!   krank CONTAINS THE EFFECTIVE RANK OF a. I.E., THE NUMBER
!   OF INDEPENDENT COLUMNS IN MATRIX a.
!                      
!   IF tol IS PRESENT AND IS IN [0,1[, THEN :
!       ON ENTRY, SPECIFIC CALCULATIONS TO DETERMINE THE EFFECTIVE RANK a
!       ARE PERFORMED. tol IS USED TO DETERMINE THE EFFECTIVE RANK
!       OF a, WHICH IS THEN DEFINED AS THE ORDER OF THE LARGEST LEADING
!       TRIANGULAR SUBMATRIX r11 IN THE QR FACTORIZATION WITH PIVOTING OF a,
!       WHOSE ESTIMATED CONDITION NUMBER IN THE 1-NORM IS LESS THAN 1/tol.
!       IF tol=0 IS SPECIFIED THE NUMERICAL RANK OF a IS DETERMINED.
!       ON EXIT, THE RECIPROCAL OF THE CONDITION NUMBER IS RETURNED IN tol.
!
!   IF tol IS NOT SPECIFIED OR IS OUTSIDE [0,1[ :
!       THE CALCULATIONS TO DETERMINE THE EFFECTIVE RANK OF a ARE NOT
!       PERFORMED AND CRUDE TESTS ON r(j,j) ARE DONE TO DETERMINE
!       THE NUMERICAL RANK OF a.
!
!   IF IT IS POSSIBLE THAT a MAY NOT BE FULL RANK (I.E., CERTAIN COLUMNS OF a ARE
!   LINEAR COMBINATIONS OF OTHER COLUMNS), THEN THE LINEARLY DEPENDENT COLUMNS CAN
!   USUALLY BE DETERMINED BY USING krank=0  AND tol=RELATIVE PRECISION OF THE ELEMENTS
!   IN a. IF EACH ELEMENT IS CORRECT TO, SAY, 5 DIGITS THEN tol=0.00001 SHOULD
!   BE USED. ALSO, IT MAY BE HELPFUL TO SCALE THE COLUMNS OF a SO THAT ALL ELEMENTS 
!   ARE ABOUT THE SAME ORDER OF MAGNITUDE.
!   
!   ON EXIT, IF THE OPTIONAL PARAMETER resid IS PRESENT,
!   THE RESIDUAL VECTOR OR MATRIX b - a*x is COMPUTED AND
!
!                               resid = b - a*x .
!
!   THE 2-NORM OF THE RESIDUAL VECTOR(S) FOR THE SOLUTION VECTOR(S) x, CAN ALSO BE COMPUTED
!   DIRECTLY BY SPECIFYING THE OPTIONAL PARAMETER rnorm IN THE CALL OF llsq_qr_solve .
!
!   THE MINIMUN 2-NORM SOLUTION(S) ARE COMPUTED IF THE OPTIONAL LOGICAL PARAMETER min_norm IS
!   PRESENT AND IS SET TO true. OTHERWISE, SOLUTION(S) ARE COMPUTED SUCH THAT IF THE jTH COLUMN
!   OF a IS OMITTED FROM THE BASIS, x[j] OR x[j,:nrhs] IS SET TO ZERO.
!
    if ( do_test ) then
!
!       CHECK THAT THE RESIDUALS ARE ORTHOGONAL TO THE COEFFICIENT MATRIX a .
!
        err = maxval( abs( matmul( resid, a ) ) )/ sum( abs(a) )
!
    end if
!
!   DEALLOCATE WORK ARRAY.
!
    deallocate( a )
!
!   PRINT THE RESULT OF THE TEST.
!
    if ( err<=sqrt(epsilon(err)) ) then
        write (prtunit,*) 'Example 1 of LLSQ_QR_SOLVE is correct'
    else
        write (prtunit,*) 'Example 1 of LLSQ_QR_SOLVE is incorrect'
    end if
!
!
! END OF PROGRAM ex1_llsq_qr_solve
! ================================
!
end program ex1_llsq_qr_solve

ex1_llsq_qr_solve2.F90

program ex1_llsq_qr_solve2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine LLSQ_QR_SOLVE2
!   in modules LLSQ_Procedures .
!                                                                              
! LATEST REVISION : 25/07/2014
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, lgl, stnd, zero, true, false, llsq_qr_solve2
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, m=4000, n=2000
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, tol
    real(stnd), dimension(m)                :: b
    real(stnd), dimension(n)                :: x
    real(stnd), allocatable, dimension(:,:) :: a, a2
!
    integer(i4b) :: krank
!
    integer      :: iok
!
    logical(lgl) :: comp_resid, do_test
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of llsq_qr_solve2'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
    err      = zero
    do_test  = false
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(m,n), stat=iok )
!
    if ( iok/=0 ) then
        write (prtunit,*)  'Problem in attempt to allocate memory !'
        stop
    end if
!
!   GENERATE A RANDOM COEFFICIENT VECTOR a .
!
    call random_number( a )
!
!   GENERATE A RANDOM RIGHT HAND-SIDE MATRIX b .
!
    call random_number( b )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAY.
!
        allocate( a2(m,n), stat=iok )
!
        if ( iok/=0 ) then
            write (prtunit,*)  'Problem in attempt to allocate memory !'
            stop
        end if
!
!       SAVE DATA MATRIX .
!
        a2(:m,:n) = a(:m,:n)
!
    end if
!
!   EXAMPLE 1 : LINEAR LEAST SQUARES SYSTEM.
!
!   COMPUTE SOLUTION VECTOR FOR LINEAR LEAST SQUARES SYSTEM
!
!           a(:m,:n)*x(:n)=b(:m) .
!
!   SET TOLERANCE .
!
    tol = 0.00001_stnd
!
    krank      = 0
    comp_resid = true
!
    call llsq_qr_solve2( a(:m,:n), b(:m), x(:n),                     &
                         comp_resid=comp_resid, krank=krank, tol=tol )
!
!   llsq_qr_solve2 COMPUTES SOLUTION(S) TO REAL LINEAR LEAST SQUARES PROBLEMS 
!   OF THE FORM:
!
!                       Minimize 2-norm(| b - a*x |)
!
!   USING AN ORTHOGONAL FACTORIZATION WITH COLUMNS PIVOTING OF a. a IS A m VECTOR
!   OR AN m-BY-n MATRIX WHICH MAY BE RANK-DEFICIENT. IF a IS A MATRIX, m>=n OR
!   n>m IS PERMITTED.
!
!   SEVERAL RIGHT HAND SIDE VECTORS b AND SOLUTION VECTORS x CAN BE
!   HANDLED IN A SINGLE CALL; THEY ARE STORED AS THE COLUMNS OF THE
!   m-BY-nrhs RIGHT HAND SIDE MATRIX b AND THE n-BY-nrhs SOLUTION
!   MATRIX x, RESPECTIVELY. IN OTHER WORDS, THE ARGUMENTS b AND x MAY
!   BE VECTORS OR MATRICES.
!
!   a AND b ARE OVERWRITTEN BY llsq_qr_solve2. THE OPTIONAL ARGUMENTS krank,
!   tol AND min_norm MUST NOT BE PRESENT IF a IS A m-VECTOR.
!
!   ON INPUT, IF THE OPTIONAL PARAMETER krank IS SPECIFIED AND IF krank=k,
!   THIS IMPLIES THAT THE FIRST k COLUMNS OF a ARE TO BE FORCED INTO THE BASIS.
!   PIVOTING IS PERFORMED ON THE LAST n-k COLUMNS OF a.
!   
!   WHEN krank>=min(m,n) IS USED, PIVOTING IS NOT PERFORMED. THIS IS
!   APPROPRIATE WHEN a IS KNOWN TO BE FULL RANK. krank<=0 CAN BE USED
!   WHEN PIVOTING IS DESIRED ON ALL COLUMNS OF a.
!   
!   BY DEFAULT, PIVOTING IS DONE ON ALL THE COLUMNS OF a.
!   
!   ON EXIT, IF THE OPTIONAL PARAMETER krank IS SPECIFIED,
!   krank CONTAINS THE EFFECTIVE RANK OF a. I.E., THE NUMBER
!   OF INDEPENDENT COLUMNS IN MATRIX a.
!                      
!   IF tol IS PRESENT AND IS IN [0,1[, THEN :
!       ON ENTRY, SPECIFIC CALCULATIONS TO DETERMINE THE EFFECTIVE RANK a
!       ARE PERFORMED. tol IS USED TO DETERMINE THE EFFECTIVE RANK
!       OF a, WHICH IS THEN DEFINED AS THE ORDER OF THE LARGEST LEADING
!       TRIANGULAR SUBMATRIX r11 IN THE QR FACTORIZATION WITH PIVOTING OF a,
!       WHOSE ESTIMATED CONDITION NUMBER IN THE 1-NORM IS LESS THAN 1/tol.
!       IF tol=0 IS SPECIFIED THE NUMERICAL RANK OF a IS DETERMINED.
!       ON EXIT, THE RECIPROCAL OF THE CONDITION NUMBER IS RETURNED IN tol.
!
!   IF tol IS NOT SPECIFIED OR IS OUTSIDE [0,1[ :
!       THE CALCULATIONS TO DETERMINE THE EFFECTIVE RANK OF a ARE NOT
!       PERFORMED AND CRUDE TESTS ON r(j,j) ARE DONE TO DETERMINE
!       THE NUMERICAL RANK OF a.
!
!   IF IT IS POSSIBLE THAT a MAY NOT BE FULL RANK (I.E., CERTAIN COLUMNS OF a ARE
!   LINEAR COMBINATIONS OF OTHER COLUMNS), THEN THE LINEARLY DEPENDENT COLUMNS CAN
!   USUALLY BE DETERMINED BY USING krank=0  AND tol=RELATIVE PRECISION OF THE ELEMENTS
!   IN a. IF EACH ELEMENT IS CORRECT TO, SAY, 5 DIGITS THEN tol=0.00001 SHOULD
!   BE USED. ALSO, IT MAY BE HELPFUL TO SCALE THE COLUMNS OF a SO THAT ALL ELEMENTS 
!   ARE ABOUT THE SAME ORDER OF MAGNITUDE.
!   
!   ON EXIT, IF THE OPTIONAL LOGICAL PARAMETER comp_resid IS PRESENT AND IS SET TO true,
!   THE RESIDUAL VECTOR OR MATRIX b - a*x is COMPUTED AND IS OUTPUT IN b .
!
!   THE 2-NORM OF THE RESIDUAL VECTOR(S) FOR THE SOLUTION VECTOR(S) x, CAN ALSO BE COMPUTED
!   DIRECTLY BY SPECIFYING THE OPTIONAL PARAMETER rnorm IN THE CALL OF llsq_qr_solve2 .
!
!   THE MINIMUN 2-NORM SOLUTION(S) ARE COMPUTED IF THE OPTIONAL LOGICAL PARAMETER min_norm IS
!   PRESENT AND IS SET TO true. OTHERWISE, SOLUTION(S) ARE COMPUTED SUCH THAT IF THE jTH COLUMN
!   OF a IS OMITTED FROM THE BASIS, x[j] OR x[j,:nrhs] IS SET TO ZERO.
!
    if ( do_test ) then
!
!       CHECK THAT THE RESIDUALS ARE ORTHOGONAL TO THE COEFFICIENT MATRIX a .
!
        err = maxval( abs( matmul( b, a2 ) ) )/ sum( abs(a2) )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a2 )
!
    end if
!
!   DEALLOCATE WORK ARRAY.
!
    deallocate( a )
!
!   PRINT THE RESULT OF THE TEST.
!
    if ( err<=sqrt(epsilon(err)) ) then
        write (prtunit,*) 'Example 1 of LLSQ_QR_SOLVE2 is correct'
    else
        write (prtunit,*) 'Example 1 of LLSQ_QR_SOLVE2 is incorrect'
    end if
!
!
! END OF PROGRAM ex1_llsq_qr_solve2
! =================================
!
end program ex1_llsq_qr_solve2

ex1_llsq_svd_solve.F90

program ex1_llsq_svd_solve
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine LLSQ_SVD_SOLVE
!   in module LLSQ_Procedures. 
!                                               
! LATEST REVISION : 04/09/2014
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, lamch, norm,        &
                         print_array, llsq_svd_solve, merror, allocate_error
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=2000, m=4000, p=min(m,n)
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of llsq_svd_solve'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, eps, tol, rnorm, bnorm, cond, sfmin
    real(stnd), dimension(m)                :: b
    real(stnd), dimension(n)                :: x, sing_values
    real(stnd), allocatable, dimension(:)   :: b2, res
    real(stnd), allocatable, dimension(:,:) :: a, a2
!
    integer(i4b) :: krank
!
    integer      :: iok
!
    logical(lgl) :: failure, do_test, do_print
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : LINEAR LEAST SQUARES SYSTEM AND ONE RIGHT HAND-SIDE.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    err      = zero
    do_test  = true
    do_print = false
!
!   ALLOCATE WORK ARRAY.
!
    allocate( a(m,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 )
!
!   GENERATE A RANDOM RIGHT HAND-SIDE VECTOR b .
!
    call random_number( b )
!
    if ( do_print ) then
!
!       COMPUTE THE NORM OF DEPENDENT VARIABLE b .
!
        bnorm = norm( b )
!
    end if
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( a2(m,n), b2(m), res(m), 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 VECTOR .
!
        b2(:m) = b(:m)
!
    end if
!
!   llsq_svd_solve COMPUTES THE MINIMUM NORM SOLUTION TO A REAL LINEAR LEAST
!   SQUARES PROBLEM :
!
!                       Minimize 2-norm(| b - A*x |)
!
!   USING THE SINGULAR VALUE DECOMPOSITION (SVD) OF A. A IS AN m-BY-n MATRIX
!   WHICH MAY BE RANK-DEFICIENT.
!
!   THE EFFECTIVE RANK OF A, krank,IS DETERMINED BY TREATING AS ZERO THOSE
!   SINGULAR VALUES WHICH ARE LESS THAN tol TIMES THE LARGEST SINGULAR VALUE.
!
    tol = 0.0000001_stnd
!
!   COMPUTE THE LEAST-SQUARES SOLUTION MATRIX OF a*x=b .
!
    call llsq_svd_solve( a, b, failure, x,                                            &
                         singvalues=sing_values, krank=krank, rnorm=rnorm, tol=tol )
!
    if ( do_test ) then
!
!       CHECK THAT THE RESIDUALS ARE ORTHOGONAL TO THE COLUMN VECTORS OF a .
!
        res = b2 - matmul( a2, x )
        err = sum(abs(matmul(res,a2)) )/ sum( abs(a2) )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a2, b2, res )
!
    end if
!
!   DEALLOCATE WORK ARRAY.
!
    deallocate( a )
!
    if ( err<=eps .and. .not.failure ) then
!
        write (prtunit,*) name_proc//' is correct'
!
        if ( do_print ) then
!
!           GET MACHINE CONSTANT sfmin, SUCH THAT 1/sfmin DOES NOT OVERFLOW.
!
            sfmin = lamch( 's' )
!
!           COMPUTE THE CONDITION NUMBER OF A IN THE 2-NORM
!
!                   singvalues(1)/singvalues(min(m,n)) .
!
            if ( sing_values(p)/sing_values(1)<=sfmin ) then
                cond = huge( a )
            else
                cond = sing_values(1)/sing_values(p)
            end if
!
!           PRINT RESULTS .
!
            write (prtunit,*)
            write (prtunit,*)
            write (prtunit,*) 'LEAST SQUARES SOLUTION VIA SINGULAR VALUE DECOMPOSITION'
            write (prtunit,*) '           MIN OF IIA*x-bII**2 FOR x                   '
            write (prtunit,*)
!
            call print_array( sing_values, title=' SINGULAR VALUES ASSOCIATED WITH MATRIX A ' )
!
            write (prtunit,*)
            write (prtunit,*) 'TOLERANCE FOR ZERO SINGULAR VALUE (tol*sing_values(1)):',tol*sing_values(1)
            write (prtunit,*)
            write (prtunit,*) 'CONDITION NUMBER OF A :',cond
            write (prtunit,*) 'RANK OF A             :',krank
            write (prtunit,*)
            write (prtunit,*) 'RESIDUAL SUM OF SQUARES IIA*x-bII**2               :',rnorm**2
            write (prtunit,*) 'RESIDUAL SUM OF SQUARES (%) (IIA*x-bII**2/IIbII**2):',(rnorm/bnorm)**2
!
            call print_array( x, title=' ASSOCIATED LEAST SQUARES SOLUTION x ' )
!
        end if
!
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex1_llsq_svd_solve
! =================================
!
end program ex1_llsq_svd_solve

ex1_lp_coef.F90

program ex1_lp_coef
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines/functions LP_COEF
!   and SYMLIN_FILTER in module Time_Series_Procedures.
!                                                                              
! LATEST REVISION : 30/11/2007
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, zero, half, one, two, pi, true, false, merror, allocate_error, arth,   &
                         lp_coef, symlin_filter, init_fft, fft, end_fft
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT, n IS THE LENGTH OF THE TIME SERIES .
!
    integer(i4b), parameter :: prtunit=6, n=2000
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                            :: err, tmp, fcl
    real(stnd), dimension(n)              :: y, y2, y3, freq, freqr, tmpvec
    real(stnd), dimension(:), allocatable :: coef
!
    complex(stnd), dimension(n)           :: yc
!
    integer(i4b) :: i, k, k1, k2, pl, nfilt, khalf, kmid
!   
    integer :: iok
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of lp_coef'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A RANDOM REAL NUMBER SEQUENCE OF LENGTH n .
!
    call random_number( y(:n) )
!
!   SAVE THE REAL RANDOM NUMBER ARRAY.
!
    y2(:n) = y(:n)
!
!   pl IS THE MINIMUM PERIOD OF OSCILLATION OF DESIRED COMPONENT.
!   pl IS EXPRESSED IN NUMBER OF OBSERVATIONS, I.E. pl==32(96) SELECT
!   A PERIOD OF 8 YRS FOR QUARTERLY (MONTHLY) DATA.
!
    pl  = 32
!
!   COMPUTE THE CORRESPONDING CUTOFF FREQUENCY fcl .
!
    fcl = one/real( pl, stnd )
!
!   NOW SELECT THE OPTIMAL NUMBER OF FILTER COEFFICIENTS k FOR THE LANCZOS FILTER.
!
    i = ceiling( one/(half-fcl) )
    k = max( i, pl+1 )
!
!   CHECK IF k IS ODD.
!
    if ( (k/2)*2==k  ) k = k + 1
!
!   ALLOCATE WORK ARRAY FOR THE FILTER COEFFICIENTS.
!
    allocate( coef(k), stat=iok )
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   FUNCTION lp_coef COMPUTES THE K-TERM LEAST SQUARES APPROXIMATION TO AN
!   -IDEAL- LOW-PASS FILTER WITH CUTOFF PERIODS PL (EG CUTOFF FREQUENCY 1/PL).
!
    coef(:k) = lp_coef( PL=pl, K=k )
!
!   SUBROUTINE symlin_filter PERFORMS A SYMMETRIC FILTERING OPERATION ON AN IMPUT
!   TIME SERIES (THE ARGUMENT VEC).
!
!   HERE symlin_filter FILTERS THE TIME SERIES .
!   NOTE THAT (size(COEF)-1)/2 DATA POINTS WILL BE LOST FROM EACH END OF THE SERIES SO THAT
!   NFILT (NFILT= size(VEC) - size(COEF) + 1) TIME OBSERVATIONS ARE RETURNED IN VEC(:NFILT)
!   AND THE REMAINING OBSERVATIONS ARE SET TO ZERO.
!
    call symlin_filter( VEC=y2(:n), COEF=coef(:k),  NFILT=nfilt )
!
!   NOW COMPUTE THE TRANSFERT FUNCTION freqr(:) OF THE LANCZOS FILTER AT THE FOURIER FREQUENCIES.
!
    kmid  = ( k + 1 )/2
    khalf = ( k - 1 )/2
!
    freqr(:n) = coef(kmid)
!
    tmp        = (two*pi)/real( n, stnd )
    freq(:n)   = arth( zero, tmp, n )
    tmpvec(:n) = zero
!
    do i = 1, khalf
        tmpvec(:n) = tmpvec(:n) + freq(:n)
        freqr(:n)  = freqr(:n)  + two*coef(kmid+i)*cos( tmpvec(:n) )
    end do
!
!   NOW, APPLY THE FILTER USING THE FFT AND THE CONVOLUTION THEOREM.
!
!   INITIALIZE THE FFT SUBROUTINE.
!
    call init_fft( n )
!
!   TRANSFORM THE TIME SERIES.
!
    yc(:n) = cmplx( y(1:n), zero, kind=stnd )
!
    call fft( yc(:n), forward=true  )
!
!   MULTIPLY THE FOURIER TRANSFORM OF THE TIME SERIES
!   BY THE TRANSFERT FUNCTION OF THE FILTER.
!
    yc(:n) = yc(:n)*freqr(:n)
!
!   INVERT THE SEQUENCE BACK TO GET THE FILTERED TIME SERIES.
!
    call fft( yc(:n), forward=false )
!
    y3(:n) = real( yc(:n),  kind=stnd )
!
!   DEALLOCATE WORK ARRAYS.
!
    call end_fft()
!
    deallocate( coef )
!
!   TEST THE ACCURACY OF THE FILTERING OPERATION.
!
    k1    = kmid
    k2    = n - khalf
!
    err = maxval(abs(y3(k1:k2)-y2(:nfilt)))/maxval(abs(y(k1:k2)))
!
    if ( err<=sqrt(epsilon(err))  ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex1_lp_coef
! ==========================
!
end program ex1_lp_coef

ex1_lp_coef2.F90

program ex1_lp_coef2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines/functions LP_COEF2
!   and SYMLIN_FILTER2 in module Time_Series_Procedures.
!                                                                              
! LATEST REVISION : 12/11/2007
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, true, merror, allocate_error,   &
                         lp_coef2, symlin_filter2
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT, n IS THE LENGTH OF THE TIME SERIES .
!
    integer(i4b), parameter :: prtunit=6, n=2001
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                            :: err
    real(stnd), dimension(n)              :: y, y2, y3
    real(stnd), dimension(:), allocatable :: coef
!
    integer(i4b) :: k, k1, k2, pl, khalf, kmid
!   
    integer :: iok
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of lp_coef2'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A RANDOM REAL NUMBER SEQUENCE OF LENGTH n .
!
    call random_number( y(:n) )
!
!   SAVE THE REAL RANDOM NUMBER ARRAY.
!
    y2(:n) = y(:n)
    y3(:n) = y(:n)
!
!   pl IS THE MINIMUM PERIOD OF OSCILLATION OF DESIRED COMPONENT.
!   pl IS EXPRESSED IN NUMBER OF OBSERVATIONS, I.E. pc==32(96) SELECT
!   A PERIOD OF 8 YRS FOR QUARTERLY (MONTHLY) DATA.
!
    pl  = 32
!
!   NOW SELECT THE NUMBER OF FILTER COEFFICIENTS k FOR THE HAMMING FILTER.
!
    k = pl + 1
    if ( (k/2)*2==k )  k = k + 1
!
!   ALLOCATE WORK ARRAY FOR THE FILTER COEFFICIENTS.
!
    allocate( coef(k), stat=iok )
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   FUNCTION lp_coef2 COMPUTES THE K-TERM LEAST SQUARES APPROXIMATION TO AN
!   -IDEAL- LOW-PASS FILTER WITH CUTOFF PERIODS PL (EG CUTOFF FREQUENCY 1/PL).
!
    coef(:k) = lp_coef2( PL=pl, K=k )
!
!   SUBROUTINE symlin_filter2 PERFORMS A SYMMETRIC FILTERING OPERATION ON AN IMPUT
!   TIME SERIES (THE ARGUMENT VEC).
!
!   HERE symlin_filter2 FILTERS THE TIME SERIES .
!   NOTE THAT (size(COEF)-1)/2 DATA POINTS WILL BE AFFECTED BY END EFFECTS  FROM EACH END OF THE SERIES.
!
    call symlin_filter2( VEC=y2(:n), COEF=coef(:k) )
!
!   FILTER AGAIN THE TIME SERIES, BUT COMPUTE THE VALUES AT THE ENDS OF THE OUTPUT
!   BY ASSUMING THAT THE INPUT IS PART OF A PERIODIC SEQUENCE OF PERIOD n .
!
    call symlin_filter2( VEC=y3(:n), COEF=coef(:k), USEFFT=true )
!
!   DEALLOCATE WORK ARRAY.
!
    deallocate( coef )
!
!   TEST THE ACCURACY OF THE FILTERING OPERATION.
!
    kmid  = ( k + 1 )/2
    khalf = ( k - 1 )/2
!
    k1    = kmid
    k2    = n - khalf
!
    err = maxval(abs(y3(k1:k2)-y2(k1:k2)))/maxval(abs(y(k1:k2)))
!
    if ( err<=sqrt(epsilon(err))  ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex1_lp_coef2
! ===========================
!
end program ex1_lp_coef2

ex1_lq_cmp.F90

program ex1_lq_cmp
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines LQ_CMP and ORTHO_GEN_LQ
!   in modules QR_Procedures.
!                                                                              
! LATEST REVISION : 15/06/2018
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, zero, one, c50, true, false, lq_cmp, ortho_gen_lq, 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
!
    integer(i4b), parameter :: prtunit=6, n=1000, m=1500
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of lq_cmp'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd), dimension(:,:), allocatable :: a, q, l, res
    real(stnd), dimension(:),   allocatable :: diagl, tau, res2, norma
    real(stnd)                              :: err, err1, err2, err3, eps, ulp, elapsed_time
!
    integer(i4b) :: k, j, p
    integer      :: iok, istart, iend, irate, imax, itime
!
    logical(lgl) :: do_test
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : COMPUTING THE QL DECOMPOSITION OF A MATRIX.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    ulp = epsilon( err )
    eps = fudge*ulp
    err = zero
!
    do_test = true
!
    k = min( m, n )
    p = max( m, n )
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( q(p,m), l(n,k), diagl(k), tau(k), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM COEFFICIENT MATRIX a(:n,:m).
!
    call random_number( q(:n,:m) )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( a(n,m), res(p,m), res2(n), norma(n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       MAKE A COPY OF THE RANDOM DATA MATRIX.
!
        a(:n,:m) = q(:n,:m)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   COMPUTE LQ DECOMPOSITION OF RANDOM DATA MATRIX.
!
    call lq_cmp( q(:n,:m), diagl(:k), tau(:k) )
!
!   lq_cmp COMPUTES AN ORTHOGONAL FACTORIZATION OF A REAL n-BY-m MATRIX
!   BY THE HOUSEOLDER METHOD. THE MATRIX IS ASSUMED OF FULL RANK. THE ROUTINE
!   COMPUTES A LQ FACTORIZATION OF a AS:
!
!                     a = l * q
!
!   ON EXIT, a HAS BEEN OVERWRITTEN BY DETAILS OF ITS ORTHOGONAL
!   FACTORIZATION. 
!
!   THE MATRIX q IS REPRESENTED AS A PRODUCT OF ELEMENTARY REFLECTORS
!
!            q = h(k)*h(k-1)* ... *h(1), WHERE k = min( size(a,1) , size(a,2) )
!
!   EACH h(i) HAS THE FORM
!
!            h(i) = I + BETA * ( V * V' ) ,
!                      
!   WHERE BETA IS A REAL SCALAR AND V IS A REAL M-ELEMENT VECTOR WITH V(1:i-1) = 0.
!   V(i:m) IS STORED ON EXIT IN a(i,i:m) AND BETA IN beta(i).
!                      
!   THE ELEMENTS BELOW THE DIAGONAL OF THE ARRAY a CONTAIN THE
!   CORRESPONDING ELEMENTS OF THE TRIANGULAR MATRIX l. THE ELEMENTS
!   OF THE DIAGONAL OF l ARE STORED IN THE ARRAY diagl. 
!
!   RESTORE TRIANGULAR FACTOR L OF LQ DECOMPOSITION OF RANDOM DATA MATRIX a
!   IN MATRIX l(:n,:k).
!
    do j = 1, k
!
        l(1:j-1,j) = zero
        l(j,j)     = diagl(j)
        l(j+1:n,j) = q(j+1:n,j)
!
    end do
!
!   GENERATE ORTHOGONAL MATRIX Q OF LQ DECOMPOSITION OF RANDOM DATA MATRIX a
!   AND AN ORTHOGONAL BASIS FOR THE ORTHOGONAL COMPLEMENT TO THE RANGE OF a'.
!   a IS ASSUMED OF FULL RANK.
!
    call ortho_gen_lq( q(:m,:m), tau(:k) )
!
!   ortho_gen_lq GENERATES AN m-BY-m REAL MATRIX WITH ORTHONORMAL ROWS, WHICH IS
!   DEFINED AS THE FIRST m ROWS OF A PRODUCT OF k ELEMENTARY REFLECTORS OF ORDER m
!
!            q = h(k)*h(k-1)* ... *h(1)
!
!   AS RETURNED BY lq_cmp.
!
!   THE SIZE OF beta DETERMINES THE NUMBER k OF ELEMENTARY REFLECTORS
!   WHOSE PRODUCT DEFINES THE MATRIX q.
!
!   NOW, THE ROWS OF q(:k,:m) ARE AN ORTHOGONAL BASIS FOR THE RANGE OF a(:n,:m)'
!   AND THE ORTHOGONAL BASIS FOR THE ORTHOGONAL COMPLEMENT TO THE RANGE OF a(:n,:m)'
!   ARE THR ROWS OF q(k+1:m,:m).
!
!   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 ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a(:n,:m) - l(:n,:n)*q(:n,:m).
!
        res(:n,:m) = a(:n,:m) - matmul( l(:n,:k), q(:k,:m) )
        res2(:n)   = norm( res(:n,:m), dim=1_i4b )
        norma(:n)  = norm( a(:n,:m), dim=1_i4b )
        err1       = maxval( res2(:n) / norma(:n) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - Q*Q'.
!
        res(:m,:m) = matmul( q(:m,:m), transpose(q(:m,:m)) )
!
        do j = 1, m
            res(j,j) =  res(j,j) - one
        end do
!
        err2 = maxval( abs(res(:m,:m)) )/real(m,stnd)
!
!       CHECK ORTHOGONALITY OF a(:n,:m) AND ITS ORTHOGONAL COMPLEMENT q(n+1:m,:m).
!
        if ( m>n ) then
!
            res(:n,n+1_i4b:m) = matmul( a(:n,:m), transpose(q(n+1_i4b:m,:m) ) )
            err3 = maxval( abs( res(:n,n+1_i4b:m) ) )/real(m,stnd)
!
        else
!
            err3 = zero
!
        end if
!
        err = max( err1, err2, err3 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, res, res2, norma )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( l, q, diagl, tau )
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) then
!
        write (prtunit,*) 
        write (prtunit,*) 'Accuracy of the LQ decomposition                                       = ', err1
        write (prtunit,*) 'Orthogonality of the Q matrix                                          = ', err2
!
        if ( m>n ) then
            write (prtunit,*) 'Orthogonality of the row-space of the matrix and its orthogonal complement = ', err3
        end if
!
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing LQ decomposition of a ', &
       n, ' by ', m,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_lq_cmp
! =========================
!
end program ex1_lq_cmp

ex1_lu_cmp.F90

program ex1_lu_cmp
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines LU_CMP and LU_SOLVE
!   in module Lin_Procedures . 
!                                                                              
! LATEST REVISION : 18/06/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, zero, true, false, lu_cmp, lu_solve, &
                         norm, merror, allocate_error
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=4000
!
    character(len=*), parameter :: name_proc='Example 1 of lu_cmp'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, eps, d1, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a
    real(stnd), dimension(:),  allocatable  :: b, x, res
!
    integer(i4b), dimension(:), allocatable :: ip
    integer                                 :: iok, istart, iend, irate, imax, itime
!
    logical(lgl)   :: do_test
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : SOLVING A LINEAR SYSTEM WITH A REAL n-BY-n MATRIX
!               AND ONE RIGHT HAND-SIDE WITH THE LU DECOMPOSITION.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = sqrt( epsilon( err ) )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), b(n), x(n), ip(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 RANDOM SOLUTION VECTOR x .
!
    call random_number( x )
!
!   COMPUTE THE MATRIX-VECTOR 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 VECTOR FOR THE LINEAR SYSTEM
!
!            a*x = b .
!
!   BY COMPUTING THE LU DECOMPOSITION WITH PARTIAL PIVOTING AND
!   IMPLICIT ROW SCALING OF MATRIX a. IF ON OUTPUT OF lu_cmp
!   d1 IS DIFFERENT FROM ZERO THEN THE LINEAR SYSTEM IS NOT
!   SINGULAR AND CAN BE SOLVED BY SUBROUTINE lu_solve.
!
    call lu_cmp( a, ip, d1 )
!
    if ( d1==zero ) then
!
!       ANORMAL EXIT FROM lu_cmp SUBROUTINE, PRINT A WARNING.
!
        write (prtunit,*) 'Error in exit of LU_CMP subroutine, d1=', d1
        write (prtunit,*)
!
    else
!
!       SOLVE THE LINEAR SYSTEM.
!
        call lu_solve( a, ip, b )
!
    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 ( d1/=zero .and. do_test ) then
!
!       ALLOCATE WORK ARRAY.
!
        allocate( res(n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       CHECK THE RESULTS FOR SMALL RESIDUALS.
!
        res(:n) = b(:n) - x(:n)
        err     = norm(res) /( real(n,stnd)*norm(x) )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, b, x, ip, res )
!
    else
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, b, x, ip )
!
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. d1/=zero ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing the solution of a linear real system of size ', &
       n, ' by ', n, ' is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_lu_cmp
! =========================
!
end program ex1_lu_cmp

ex1_lu_cmp2.F90

program ex1_lu_cmp2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines LU_CMP2
!   in module Lin_Procedures . 
!                                                                              
! LATEST REVISION : 18/06/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, zero, one, true, false,   &
                         lu_cmp2, norm, merror, allocate_error
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=4000
!
    character(len=*), parameter :: name_proc='Example 1 of lu_cmp2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, eps, d1, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, a2, ainv, res
!
    integer(i4b)                            :: j
    integer(i4b), dimension(:), allocatable :: ip
    integer                                 :: iok, istart, iend, irate, imax, itime
!
    logical(lgl) :: do_test
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : COMPUTE THE INVERSE OF A REAL n-BY-n MATRIX
!               BY USING THE LU DECOMPOSITION.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = sqrt( epsilon( err ) )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), ainv(n,n), ip(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 )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( a2(n,n), res(n,n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       SAVE A COPY OF THE 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 )
!
!   COMPUTE THE INVERSE OF A SQUARE REAL MATRIX BY COMPUTING
!   THE LU DECOMPOSITION WITH PARTIAL PIVOTING AND
!   IMPLICIT ROW SCALING OF MATRIX a. IF ON OUTPUT OF lu_cmp2
!   d1 IS DIFFERENT FROM ZERO THEN THE MATRIX IS NOT SINGULAR
!   AND THE INVERSE OF a HAS BEEN COMPUTED.
!
    call lu_cmp2( a, ip, d1, matinv=ainv )
!
!   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 ( d1==zero ) then
!
!       ANORMAL EXIT FROM lu_cmp2 SUBROUTINE, PRINT A WARNING.
!
        write (prtunit,*) 'Error in exit of LU_CMP2 subroutine, d1=', d1
        write (prtunit,*)
!
    else if ( do_test ) then
!
!       COMPUTE a TIMES ITS INVERSE - IDENTITY.
!
        res = matmul( a2, ainv )
!
        do j = 1_i4b, n
            res(j,j) = res(j,j) - one
        end do
!
!       CHECK THE RESULTS FOR SMALL RESIDUALS.
!
        err = norm( res(:n,:n) ) /( real(n,stnd)*norm(a2(:n,:n)) )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( do_test ) then
        deallocate( a, ainv, ip, a2, res )
    else
        deallocate( a, ainv, ip )
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. d1/=zero ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing the inverse of a  real matrix of size ', &
       n, ' by ', n, ' is', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_lu_cmp2
! ==========================
!
end program ex1_lu_cmp2

ex1_matmul2.F90

program ex1_matmul2
!
!
! Purpose
! =======
!
!   This program illustrates the use of function MATMUL2
!   in module Module_Utilities and compares its efficiency with the intrinsic MATMUL function. 
!                                                                              
! LATEST REVISION : 08/05/2015
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, norm, matmul2, merror, allocate_error
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=4000, p=2000, m=2000
!
    character(len=*), parameter :: name_proc='Example 1 of matmul2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, eps, elapsed_time1, elapsed_time2
    real(stnd), dimension(:,:), allocatable :: a, b, c, c2, resid
!
    integer :: iok, istart, iend, irate, imax, itime
!
    logical(lgl) :: do_test, failure
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : MULTIPLICATION OF TWO REAL MATRICES.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = epsilon( err )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,p), b(p,m), c(n,m), c2(n,m), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE THE RANDOM REAL MATRICES a AND b.
!
    call random_number( a(:n,:p) )
    call random_number( b(:p,:m) )
!
!   MULTIPLY THE TWO MATRICES WITH matmul2 FUNCTION.
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
    c2(:n,:m) = matmul2( a(:n,:p), b(:p,:m) )
!
!   STOP THE TIMER.
!
    call system_clock( count=iend )
!
    itime = iend - istart
    if ( iend<istart ) then
        itime = itime + imax   
    end if
!
    elapsed_time1 = real( itime, stnd )/real( irate, stnd )
!
!   NOW RECOMPUTE THE MATRIX PRODUCT WITH matmul INTRINSIC FUNCTION.
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count=istart )
!
    c(:n,:m) = matmul( a(:n,:p), b(:p,:m) )
!
!   STOP THE TIMER.
!
    call system_clock( count=iend )
!
    itime = iend - istart
    if ( iend<istart ) then
        itime = itime + imax   
    end if
!
    elapsed_time2 = real( itime, stnd )/real( irate, stnd )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAY.
!
        allocate( resid(n,m), stat=iok )
!
        if ( iok/=0 ) then
           call merror( name_proc//allocate_error )
        end if
!
        resid(:n,:m) = abs( c2(:n,:m) - c(:n,:m) )
!
!       CHECK THE RESULTS.
!
        err = maxval( resid(:n,:m) )/norm( c )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, b, c, c2, resid )
!
    else
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, b, c, c2 )
!
    end if
!
!   CHECK AND PRINT THE RESULTS.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for multiplying two real matrices of sizes ', n, ' by ', p, ' and ', p, ' by ', m,  &
       ' with matmul2() function is ', elapsed_time1, ' seconds'
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for multiplying two real matrices of sizes ', n, ' by ', p, ' and ', p, ' by ', m,  &
       ' with the intrinsic matmul() function is ', elapsed_time2, ' seconds'
!
!
! END OF PROGRAM ex1_matmul2
! ==========================
!
end program ex1_matmul2

ex1_normal_random_number2_.F90

program ex1_normal_random_number2_
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine NORMAL_RANDOM_NUMBER2_ and
!   function NORMAL_RAND_NUMBER2 in module Random.
!                                                                            
! LATEST REVISION : 23/11/2016
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, extd,  merror, allocate_error, random_seed_,  &
                         normal_rand_number2, normal_random_number2_
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n1=10**4, n2=10**4
!
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd) :: elapsed_time
    real(extd), allocatable, dimension(:,:) :: real_mat
!
    integer(i4b) :: i, j
    integer      :: iok, istart, iend, irate, imax, itime
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of normal_random_number2_'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   ALLOCATE WORK ARRAY.
!
    allocate( real_mat(n1,n2), 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=2 )
!
!   RESET THE SEEDS USED BY THE UNIFORM RANDOM GENERATOR.
!
    call random_seed_()
!
    call system_clock( count_rate=irate, count_max=imax  )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count=istart )
!
!   GENERATE A NORMAL RANDOM REAL MATRIX USING FUNCTION normal_rand_number3().
!
    do i = 1_i4b, n2
!
        do j = 1_i4b, n1
!
             real_mat(j,i) = normal_rand_number2( )
!
        end do
!
    end do
!
!   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 )
!
    write (*,'(a,i10,a,0pd12.4,a)')              &
      'The elapsed time for generating ', n1*n2, &
      ' random normal real numbers with function normal_rand_number2() is',  &
      elapsed_time, ' seconds'
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count=istart )
!
!   GENERATE A NORMAL RANDOM REAL MATRIX USING VECTOR
!   FORM OF SUBROUTINE normal_random_number_.
!
    do i = 1_i4b, n2
!
        call normal_random_number2_( real_mat(:n1,i) )
!
    end do
!
!   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 )
!
    write (prtunit,*) 
    write (*,'(a,i10,a,0pd12.4,a)')              &
      'The elapsed time for generating ', n1*n2, &
      ' random normal real numbers with vector form of subroutine normal_random_number2_ is',  &
      elapsed_time, ' seconds'
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count=istart )
!
!   GENERATE A NORMAL RANDOM REAL MATRIX USING MATRIX
!   FORM OF SUBROUTINE normal_random_number2_.
!
    call normal_random_number2_( real_mat(:n1,:n2) )
!
!   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 )
!
    write (prtunit,*) 
    write (*,'(a,i10,a,0pd12.4,a)')              &
      'The elapsed time for generating ', n1*n2, &
      ' random normal real numbers with matrix form of subroutine normal_random_number2_ is',  &
      elapsed_time, ' seconds'
!
!   DEALLOCATE WORK ARRAY.
!
    deallocate( real_mat )
!
!
! END OF PROGRAM ex1_normal_random_number2_
! =========================================
!
end program ex1_normal_random_number2_

ex1_normal_random_number3_.F90

program ex1_normal_random_number3_
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine NORMAL_RANDOM_NUMBER3_ and
!   function NORMAL_RAND_NUMBER3 in module Random.
!                                       
! LATEST REVISION : 23/11/2016
!
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd,  merror, allocate_error, random_seed_,  &
                         normal_rand_number3, normal_random_number3_
!
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!
!
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n1=10**4, n2=10**4
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd) :: elapsed_time
    real(stnd), allocatable, dimension(:,:) :: real_mat
!
    integer(i4b) :: i, j
    integer      :: iok, istart, iend, irate, imax, itime
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of normal_random_number3_'
!
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   ALLOCATE WORK ARRAY.
!
    allocate( real_mat(n1,n2), 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=2 )
!
!   RESET THE SEEDS USED BY THE UNIFORM RANDOM GENERATOR.
!
    call random_seed_()
!
    call system_clock( count_rate=irate, count_max=imax  )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count=istart )
!
!   GENERATE A NORMAL RANDOM REAL MATRIX USING FUNCTION normal_rand_number3().
!
    do i = 1_i4b, n2
!
        do j = 1_i4b, n1
!
             real_mat(j,i) = normal_rand_number3( )
!
        end do
!
    end do
!
!   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 )
!
    write (*,'(a,i10,a,0pd12.4,a)')              &
      'The elapsed time for generating ', n1*n2, &
      ' random normal real numbers with function normal_rand_number3() is',  &
      elapsed_time, ' seconds'
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count=istart )
!
!   GENERATE A NORMAL RANDOM REAL MATRIX USING VECTOR
!   FORM OF SUBROUTINE normal_random_number_.
!
    do i = 1_i4b, n2
!
        call normal_random_number3_( real_mat(:n1,i) )
!
    end do
!
!   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 )
!
    write (prtunit,*) 
    write (*,'(a,i10,a,0pd12.4,a)')              &
      'The elapsed time for generating ', n1*n2, &
      ' random normal real numbers with vector form of subroutine normal_random_number3_ is',  &
      elapsed_time, ' seconds'
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count=istart )
!
!   GENERATE A NORMAL RANDOM REAL MATRIX USING MATRIX
!   FORM OF SUBROUTINE normal_random_number3_.
!
    call normal_random_number3_( real_mat(:n1,:n2) )
!
!   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 )
!
    write (prtunit,*) 
    write (*,'(a,i10,a,0pd12.4,a)')              &
      'The elapsed time for generating ', n1*n2, &
      ' random normal real numbers with matrix form of subroutine normal_random_number3_ is',  &
      elapsed_time, ' seconds'
!
!   DEALLOCATE WORK ARRAY.
!
    deallocate( real_mat )
!
!
! END OF PROGRAM ex1_normal_random_number3_
! =========================================
!
end program ex1_normal_random_number3_

ex1_normal_random_number_.F90

program ex1_normal_random_number_
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine NORMAL_RANDOM_NUMBER_ and
!   function NORMAL_RAND_NUMBER in module Random.
!                                                                            
! LATEST REVISION : 23/11/2016
!                                               
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd,  merror, allocate_error, random_seed_,  &
                         normal_rand_number, normal_random_number_
!
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n1=10**4, n2=10**4
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd) :: elapsed_time
    real(stnd), allocatable, dimension(:,:) :: real_mat
!
    integer(i4b) :: i, j
    integer      :: iok, istart, iend, irate, imax, itime
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of normal_random_number_'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   ALLOCATE WORK ARRAY.
!
    allocate( real_mat(n1,n2), 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=2 )
!
!   RESET THE SEEDS USED BY THE UNIFORM RANDOM GENERATOR.
!
    call random_seed_()
!
    call system_clock( count_rate=irate, count_max=imax  )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count=istart )
!
!   GENERATE A NORMAL RANDOM REAL MATRIX USING FUNCTION normal_rand_number().
!
    do i = 1_i4b, n2
!
        do j = 1_i4b, n1
!
             real_mat(j,i) = normal_rand_number( )
!
        end do
!
    end do
!
!   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 )
!
    write (*,'(a,i10,a,0pd12.4,a)')              &
      'The elapsed time for generating ', n1*n2, &
      ' random normal real numbers with function normal_rand_number() is',  &
      elapsed_time, ' seconds'
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count=istart )
!
!   GENERATE A NORMAL RANDOM REAL MATRIX USING VECTOR
!   FORM OF SUBROUTINE normal_random_number_.
!
    do i = 1_i4b, n2
!
        call normal_random_number_( real_mat(:n1,i) )
!
    end do
!
!   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 )
!
    write (prtunit,*) 
    write (*,'(a,i10,a,0pd12.4,a)')              &
      'The elapsed time for generating ', n1*n2, &
      ' random normal real numbers with vector form of subroutine normal_random_number_ is',  &
      elapsed_time, ' seconds'
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count=istart )
!
!   GENERATE A NORMAL RANDOM REAL MATRIX USING MATRIX
!   FORM OF SUBROUTINE normal_random_number_.
!
    call normal_random_number_( real_mat(:n1,:n2) )
!
!   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 )
!
    write (prtunit,*) 
    write (*,'(a,i10,a,0pd12.4,a)')              &
      'The elapsed time for generating ', n1*n2, &
      ' random normal real numbers with matrix form of subroutine normal_random_number_ is',  &
      elapsed_time, ' seconds'
!
!   DEALLOCATE WORK ARRAY.
!
    deallocate( real_mat )
!
!
! END OF PROGRAM ex1_normal_random_number_
! ========================================
!
end program ex1_normal_random_number_

ex1_ortho_gen_q_bd.F90

program ortho_gen_q_bd
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines BD_CMP, ORTHO_GEN_Q_BD
!   and ORTHO_GEN_P_BD in module SVD_Procedures.
!                                                                              
! LATEST REVISION : 18/06/2018
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, bd_cmp,         &
                         ortho_gen_q_bd, ortho_gen_p_bd, 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
!
    integer(i4b), parameter :: prtunit=6, m=3000, n=3000, nm=min(n,m)
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of ortho_gen_q_bd'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err3, err, eps, elapsed_time
    real(stnd), allocatable, dimension(:)   :: d, e, tauq, taup
    real(stnd), allocatable, dimension(:,:) :: a, a2, resid, bd, p
!
    integer(i4b) :: l
!
    integer      :: 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 : BIDIAGONAL REDUCTION OF A m-by-n REAL MATRIX.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
!
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(m,n), p(n,nm), d(nm), e(nm),     &
              tauq(nm), taup(nm), 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 ARRAYS.
!
        allocate( a2(m,n), bd(nm,nm), resid(nm,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 )
!
!   FIRST, CALL bd_cmp TO REDUCE THE MATRIX a TO BIDIAGONAL FORM
!
!                      a = Q*BD*P**(t)
!
!   WHERE Q AND P ARE ORTHOGONAL AND BD IS AN UPPER OR LOWER BIDIAGONAL MATRIX.
!
    call bd_cmp( a, d, e, tauq, taup )
!
!   ON OUTPUT OF bd_cmp:
!
!       a, tauq AND taup CONTAINS THE ELEMENTARY REFLECTORS
!       DEFINING Q AND P IN PACKED FORM.
!
!       d AND e CONTAINS RESPECTIVELY, THE DIAGONAL AND
!       SUBDIAGONAL OF THE BIDIAGONAL MATRIX BD.
!
!   SECOND, CALL ortho_gen_p_bd AND ortho_gen_q_bd TO GENERATE P AND Q.
!
    call ortho_gen_p_bd( a, taup, p )
!
!   ON OUTPUT OF ortho_gen_p_bd, p CONTAINS THE ORTHOGONAL MATRIX P.
!
    call ortho_gen_q_bd( a, tauq )
!
!   ON OUTPUT OF ortho_gen_q_bd, a CONTAINS THE FIRST min(n,m) COLUMNS OF Q.
!
!   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 ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION Q**(t)*a - BD*P**(t),
!
        bd(:nm,:nm) = zero
!
        if ( m>=n ) then
!
!           BD IS UPPER BIDIAGONAL.
!
            do l = 1_i4b, nm-1_i4b
                bd(l,l)       = d(l)
                bd(l,l+1_i4b) = e(l+1_i4b)
            end do
!
            bd(nm,nm) = d(nm)
!
        else
!
!           BD IS LOWER BIDIAGONAL.
!
            bd(1_i4b,1_i4b) = d(1_i4b)
!
            do l = 2_i4b, nm
                bd(l,l-1_i4b) = e(l)
                bd(l,l)       = d(l)
            end do
!
        endif
!
        resid(:nm,:n) = matmul( transpose(a(:m,:nm)), a2(:m,:n) )           &
                        - matmul( bd(:nm,:nm), transpose(p(:n,:nm )) )
!
        bd(:nm,1_i4b) = norm( resid(:nm,:n), dim=1_i4b )
        err1 =  maxval( bd(:nm,1_i4b) )/( norm( a2 )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - Q**(t)*Q.
!
        call unit_matrix( a2(:nm,:nm) )
!
        resid(:nm,:nm) = abs( a2(:nm,:nm) - matmul( transpose(a(:m,:nm )), a(:m,:nm ) ) )
        err2 = maxval( resid(:nm,:nm) )/real(m,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - P**(t)*P.
!
        resid(:nm,:nm) = abs( a2(:nm,:nm) - matmul( transpose(p(:n,:nm )), p(:n,:nm ) ) )
        err3 = maxval( resid(:nm,:nm) )/real(n,stnd)
!
        err = max( err1, err2, err3 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a2, bd, resid )
!
    endif
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, p, d, e, tauq, taup )
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) 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,i5,a,i5,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_ortho_gen_q_bd
! =================================
!
end program ex1_ortho_gen_q_bd

ex1_permute_cor.F90

program ex1_permute_cor
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines COMP_COR and PERMUTE_COR
!   in module Mul_Stat_Procedures .
!                                                                              
! LATEST REVISION : 26/06/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, lgl, true, comp_cor, permute_cor, random_seed_, random_number_
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
! p       IS THE NUMBER OF OBSERVATIONS OF THE RANDOM VECTORS
! nrep    IS THE NUMBER OF SHUFFLES FOR THE PERMUTATION TEST
! nsample IS THE NUMBER OF SAMPLES TO EVALUATE THE REJECTION RATE OF THE TEST
!
    integer(i4b), parameter :: prtunit=6, p=50, nrep=99, nsample=3000
!
! sign_level IS THE SIGNIFICANCE LEVEL OF THE PERMUTATION TEST
! eps        IS THE ALLOWED RELATIVE ERROR FOR THE REJECTION RATE
!
    real(stnd),  parameter :: sign_level=0.05, eps=0.2
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                      :: xyn, xycor, prob, err_prob
    real(stnd), dimension(2)        :: xstat, ystat
    real(stnd), dimension(p)        :: x, y
!
    integer(i4b) :: i, rej_rate
!
    logical(lgl) :: first, last
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of permute_cor'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   INITIALIZE THE RANDOM GENERATOR.
!
    call random_seed_()
!
!   INITIALIZE THE REJECTION RATE FOR THE PERMUTATION TEST.
!
    rej_rate = 0
    first    = true
    last     = true
!
!   GENERATE A RANDOM UNIFORM OBSERVATION VECTOR y .
!
    call random_number_( y(:p) )
!
    do i=1, nsample
!
!       GENERATE A RANDOM UNIFORM OBSERVATION VECTOR x .
!
        call random_number_( x(:p) )
!
!       COMPUTE THE CORRELATIONS BETWEEN x AND y
!       FOR THE p OBSERVATIONS .
!
        call comp_cor( x(:p), y(:p), first, last, xstat(:2), ystat(:2), xycor, xyn )
!
!       ON EXIT OF COMP_COR WHEN last=true :
!
!      xstat(1)     CONTAINS THE MEAN VALUE OF THE OBSERVATION VECTOR x(:p).
!
!      xstat(2)     CONTAINS THE VARIANCE OF THE OBSERVATION VECTOR x(:p).
!
!      ystat(1)     CONTAINS THE MEAN VALUE OF THE OBSERVATION VECTOR  y(:p).
!
!      ystat(2)     CONTAINS THE VARIANCE OF THE OBSERVATION VECTOR  y(:p).
!
!      xycor        CONTAINS THE CORRELATION COEFFICIENT BETWEEN x(:p) AND y(:p).
!
!      xyn          CONTAINS THE NUMBER OF OBSERVATIONS IN THE DATA VECTORS
!                   x(:p) AND  y(:p) (xyn=real(p,stnd) ).
!
!
!       NOW COMPUTE A PERMUTATION TEST OF THE CORRELATION BETWEEN x AND y WITH
!       SUBROUTINE permute_cor WITH nrep SHUFFLES .
!
        call permute_cor( x(:p), y(:p), xstat(:2), ystat(:2), xycor, prob, nrep=nrep )
!
!       EVALUATE THE REJECTION RATE .
!
        if ( prob<=sign_level ) rej_rate = rej_rate + 1
!
    end do
!
!   NOW COMPUTE THE REJECTION RATE OF THE TEST. IDEALLY FOR THE sign_level
!   SIGNIFICANCE LEVEL, WE WOULD REJECT ONLY THE NULL HYPOTHESIS sign_level %
!   OF THE TIME. IN OTHER WORDS, THE REJECTION RATE MUST BE APPROXIMATELY EQUAL
!   TO THE SIGNIFICANCE LEVEL sign_level .
!
    prob = real( rej_rate, stnd )/real( nsample, stnd )
!
!   COMPUTE THE RELATIVE ERROR OF THE REJECTION RATE.
!
    err_prob = abs( (prob-sign_level)/sign_level )
!
!   CHECK THAT THE RELATIVE ERROR OF THE REJECTION RATE IS LESS THAN eps .
!
    if ( err_prob<=eps ) then
        write (prtunit,*) 'Example 1 of PERMUTE_COR is correct'
    else
        write (prtunit,*) 'Example 1 of PERMUTE_COR is incorrect'
    end if
!
!
! END OF PROGRAM ex1_permute_cor
! ==============================
!
end program ex1_permute_cor

ex1_phase_scramble_cor.F90

program ex1_phase_scramble_cor
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines COMP_COR and PHASE_SCRAMBLE_COR
!   in module Mul_Stat_Procedures .
!                                                                              
! LATEST REVISION : 26/06/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, lgl, true, comp_cor, phase_scramble_cor, pinvn
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
! p       IS THE NUMBER OF OBSERVATIONS OF THE TIME SERIES VECTORS
! nrep    IS THE NUMBER OF SHUFFLES FOR THE PHASE-SCRAMBLED BOOTSTRAP TEST
! nsample IS THE NUMBER OF SAMPLES TO EVALUATE THE REJECTION RATE OF THE TEST
!
    integer(i4b), parameter :: prtunit=6, p=50, nrep=99, nsample=2000
!
! sign_level IS THE SIGNIFICANCE LEVEL OF PHASE-SCRAMBLED BOOTSTRAP TEST
! eps        IS THE ALLOWED RELATIVE ERROR FOR THE REJECTION RATE
! b          IS THE LAG-1 AUTOCORRELATION FOR THE AR(1) MODEL USED
!            TO GENERATE THE TIME SERIES
!
    real(stnd),  parameter :: sign_level=0.05, eps=0.2, b=0.2
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                      :: xyn, xycor, prob, err_prob
    real(stnd), dimension(2)        :: xstat, ystat
    real(stnd), dimension(p)        :: x, y, e
!
    integer(i4b) :: i, j, rej_rate
!
    logical(lgl) :: first, last
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of phase_scramble_cor'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   INITIALIZE THE RANDOM GENERATOR.
!
    call random_seed()
!
!   INITIALIZE THE REJECTION RATE FOR THE PERMUTATION TEST.
!
    rej_rate = 0
    first    = true
    last     = true
!
!   GENERATE A TIME SERIES USING AN AR(1) MODEL OF THE FORM
!
!               y(i+1) = b*y(i) + e(i)
!
!     WHERE b IS THE SPECIFIED LAG-1 AUTOCORRELATION AND e(I)
!     IS A NORMALLY DISTRIBUTED RANDOM VARIABLE WITH A 0 MEAN
!     AND A VARIANCE OF 1.
!
    call random_number( y(:p) )
    e(:p) = pinvn( y(:p) )
!
    y(1) = e(1)
    do j=2, p
        y(j) = b*y(j-1) + e(j)
    end do
!
    do i=1, nsample
!
!       GENERATE ANOTHER INDEPENDENT TIME SERIES FROM THE SAME AR(1) MODEL .
!
        call random_number( x(:p) )
        e(:p) = pinvn( x(:p) )
!
        x(1) = e(1)
        do j=2, p
            x(j) = b*x(j-1) + e(j)
        end do
!
!       COMPUTE THE CORRELATIONS BETWEEN x AND y
!       FOR THE p OBSERVATIONS .
!
        call comp_cor( x(:p), y(:p), first, last, xstat(:2), ystat(:2), xycor, xyn )
!
!       ON EXIT OF COMP_COR WHEN last=true :
!
!      xstat(1)     CONTAINS THE MEAN VALUE OF THE OBSERVATION VECTOR x(:p).
!
!      xstat(2)     CONTAINS THE VARIANCE OF THE OBSERVATION VECTOR x(:p).
!
!      ystat(1)     CONTAINS THE MEAN VALUE OF THE OBSERVATION VECTOR  y(:p).
!
!      ystat(2)     CONTAINS THE VARIANCE OF THE OBSERVATION VECTOR  y(:p).
!
!      xycor        CONTAINS THE CORRELATION COEFFICIENT BETWEEN x(:p) AND y(:p).
!
!      xyn          CONTAINS THE NUMBER OF OBSERVATIONS IN THE DATA VECTORS
!                   x(:p) AND  y(:p) (xyn=real(p,stnd) ).
!
!
!       NOW COMPUTE A THE PHASE-SCRAMBLED BOOTSTRAP TEST OF THE CORRELATION
!       BETWEEN x AND y WITH SUBROUTINE phase_scramble_cor WITH nrep SHUFFLES .
!
        call phase_scramble_cor( x(:p), y(:p), xstat(:2), ystat(:2), xycor, prob, nrep=nrep )
!
!       EVALUATE THE REJECTION RATE .
!
        if ( prob<=sign_level ) rej_rate = rej_rate + 1
!
    end do
!
!   NOW COMPUTE THE REJECTION RATE OF THE TEST. IDEALLY FOR THE sign_level
!   SIGNIFICANCE LEVEL, WE WOULD REJECT ONLY THE NULL HYPOTHESIS sign_level %
!   OF THE TIME. IN OTHER WORDS, THE REJECTION RATE MUST BE APPROXIMATELY EQUAL
!   TO THE SIGNIFICANCE LEVEL sign_level .
!
    prob = real( rej_rate, stnd )/real( nsample, stnd )
!
!   COMPUTE THE RELATIVE ERROR OF THE REJECTION RATE.
!
    err_prob = abs( (prob-sign_level)/sign_level )
!
!   CHECK THAT THE RELATIVE ERROR OF THE REJECTION RATE IS LESS THAN eps .
!
    if ( err_prob<=eps ) then
        write (prtunit,*) 'Example 1 of PHASE_SCRAMBLE_COR is correct'
    else
        write (prtunit,*) 'Example 1 of PHASE_SCRAMBLE_COR is incorrect'
    end if
!
!
! END OF PROGRAM ex1_phase_scramble_cor
! =====================================
!
end program ex1_phase_scramble_cor

ex1_pk_coef.F90

program ex1_pk_coef
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines/functions PK_COEF,
!   FREQ_FUNC and SYMLIN_FILTER in module Time_Series_Procedures.
!                                                                              
! LATEST REVISION : 12/11/2007
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, zero, half, one, two, pi, true, false, merror, allocate_error,   &
                         pk_coef, freq_func, symlin_filter, init_fft, fft, end_fft
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT, n IS THE LENGTH OF THE TIME SERIES .
!
    integer(i4b), parameter :: prtunit=6, n=2000
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                            :: err, tmp, fc
    real(stnd), dimension(n)              :: y, y2, y3, freqr
    real(stnd), dimension(:), allocatable :: coef
!
    complex(stnd), dimension(n)           :: yc
!
    integer(i4b) :: i, k, k1, k2, pc, nfilt, khalf, kmid
!   
    integer :: iok
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of pk_coef'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A RANDOM REAL NUMBER SEQUENCE OF LENGTH n .
!
    call random_number( y(:n) )
!
!   SAVE THE REAL RANDOM NUMBER ARRAY.
!
    y2(:n) = y(:n)
!
!   pc IS THE PERIOD OF OSCILLATION WITH A PEAK RESPONSE NEAR ONE.
!   pc IS EXPRESSED IN NUMBER OF OBSERVATIONS, I.E. pc==32(96) SELECT
!   A PERIOD OF 8 YRS FOR QUARTERLY (MONTHLY) DATA.
!
    pc  = 32
!
!   COMPUTE THE CORRESPONDING CUTOFF FREQUENCY.
!
    fc = one/real( pc, stnd )
!
!   NOW SELECT THE OPTIMAL NUMBER OF FILTER COEFFICIENTS k FOR THE LANCZOS FILTER.
!
    tmp = 2.3*max( real( pc, stnd ), one/(half-fc) )
    k = ceiling( tmp, i4b )
!
!   CHECK IF k IS ODD.
!
    if ( (k/2)*2==k  ) k = k + 1
!
!   ALLOCATE WORK ARRAY FOR THE FILTER COEFFICIENTS.
!
    allocate( coef(k), stat=iok )
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   FUNCTION pk_coef COMPUTES THE K-TERM LEAST SQUARES APPROXIMATION TO AN
!   -IDEAL- BAND PASS FILTER WITH A PEAK RESPONSE NEAR ONE AT THE PERIOD pc (EG FREQUENCY FREQ=1/pc).
!
    coef(:k) = pk_coef( FREQ=fc, K=k )
!
!   SUBROUTINE symlin_filter PERFORMS A SYMMETRIC FILTERING OPERATION ON AN IMPUT
!   TIME SERIES (THE ARGUMENT VEC).
!
!   HERE symlin_filter FILTERS THE TIME SERIES .
!   NOTE THAT (size(COEF)-1)/2 DATA POINTS WILL BE LOST FROM EACH END OF THE SERIES SO THAT
!   NFILT (NFILT= size(VEC) - size(COEF) + 1) TIME OBSERVATIONS ARE RETURNED IN VEC(:NFILT)
!   AND THE REMAINING OBSERVATIONS ARE SET TO ZERO.
!
    call symlin_filter( VEC=y2(:n), COEF=coef(:k),  NFILT=nfilt )
!
!   NOW COMPUTE THE TRANSFERT FUNCTION freqr(:) OF THE LANCZOS FILTER AT THE FOURIER FREQUENCIES.
!
    call freq_func( NFREQ=n, COEF=coef(:k), FREQR=freqr(:n), FOUR_FREQ=true )
!
!   APPLY THE FILTER USING THE FFT AND THE CONVOLUTION THEOREM.
!
!   INITIALIZE THE FFT SUBROUTINE.
!
    call init_fft( n )
!
!   TRANSFORM THE TIME SERIES.
!
    yc(:n) = cmplx( y(1:n), zero, kind=stnd )
!
    call fft( yc(:n), forward=true  )
!
!   MULTIPLY THE FOURIER TRANSFORM OF THE TIME SERIES
!   BY THE TRANSFERT FUNCTION OF THE FILTER.
!
    yc(:n) = yc(:n)*freqr(:n)
!
!   INVERT THE SEQUENCE BACK TO GET THE FILTERED TIME SERIES.
!
    call fft( yc(:n), forward=false )
!
    y3(:n) = real( yc(:n),  kind=stnd )
!
!   DEALLOCATE WORK ARRAYS.
!
    call end_fft()
!
    deallocate( coef )
!
!   TEST THE ACCURACY OF THE FILTERING OPERATION.
!
    kmid  = ( k + 1 )/2
    khalf = ( k - 1 )/2
    k1    = kmid
    k2    = n - khalf
!
    err = maxval(abs(y3(k1:k2)-y2(:nfilt)))/maxval(abs(y(k1:k2)))
!
    if ( err<=sqrt(epsilon(err))  ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex1_pk_coef
! ==========================
!
end program ex1_pk_coef

ex1_power_spectrum.F90

program ex1_power_spectrum
!
!
! Purpose
! =======
                                                                                                                                      !
!   This program is intended to demonstrate the use of subroutine POWER_SPECTRUM
!   in module Time_Series_Procedures .
!                                                                              
! LATEST REVISION : 19/03/2008
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, lgl, true, false, one, power_spectrum, comp_mvs, print_array
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT, n IS THE LENGTH OF THE TIME SERIES AND MUST BE EVEN.
!
    integer(i4b), parameter :: prtunit=6, n=100, psn=(n/2)+1
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                   :: err_mean, err_var, xmean, xmean2, xvar, xvar2, xstd, eps, tmp
    real(stnd), dimension(n)     :: x
    real(stnd), dimension(psn,2) :: psx
!
    integer(i4b) :: trend, win, i
!
    logical(lgl) :: smooth, normpsd
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of power_spectrum'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
    eps = sqrt( epsilon(err_mean) )
!
!   GENERATE A RANDOM REAL NUMBER SEQUENCE OF LENGTH n .
!
    call random_number( x(:n) )
!
!   COMPUTE THE POWER SPECTRUM OF THE TIME SERIES x(:n).
!
!   BY DEFAULT, BARTLETT WINDOW IS USED IN THE COMPUTATION OF THE POWER SPECTRUM (i.e. WIN=1).
!   SET WIN=2 FOR RECTANGULAR WINDOW, WIN=3 FOR WELCH WINDOW, WIN=4 FOR HANNING WINDOW
!   OR WIN=5 FOR HAMMING WINDOW.
!   IN ANY CASE, WIN MUST BE GREATER OR EQUAL TO 1 AND LESS OR EQUAL TO 5.
!
    win = 2
!
!   BY DEFAULT, THE MEAN OF THE TIME SERIES IS REMOVED BEFORE THE COMPUTATION
!   OF THE POWER SPECTRUM (i.e. TREND=1).
!   SET TREND=2 FOR REMOVING THE DRIFT OR TREND=3 FOR REMOVING THE LEAST SQUARES LINE
!   FROM THE TIME SERIES BEFORE ESTIMATING THE POWER SPECTRUM.
!   FOR OTHER VALUES OF TREND NOTHING IS DONE BEFORE ESTIMATING THE SPECTRUM.
!
    trend = 0
!
!   ON ENTRY, IF NORMPSD IS SET TO TRUE, THE PSD ESTIMATES ARE NORMALIZED IN SUCH
!   A WAY THAT THE TOTAL AREA UNDER THE POWER SPECTRUM IS EQUAL TO THE VARIANCE OF
!   THE TIME SERIES VEC. IF NORMPSD IS SET TO FALSE, THE SUM OF THE PSD ESTIMATES
!   (e.g. sum( PSVEC(2:) ) IS EQUAL TO THE VARIANCE OF THE TIME SERIES.
!   THE DEFAULT IS NORMPSD=true .
!
    normpsd = false
!
!   ON EXIT, PSVEC CONTAINS THE POWER SPECTRAL DENSITY (PSD) ESTIMATES OF VEC
!   AT THE psn FOURIER FREQUENCIES.
!
    call power_spectrum( VEC=x(:n), PSVEC=psx(:psn,2), NORMPSD=normpsd,   &
                         WIN=win, TREND=trend )
!
!   BUILD UP PERIOD AXIS.
!
    psx(1,1) = -one
    tmp = real( n, stnd )
!
    do i = 1, psn-1
        psx(i+1,1) = tmp/real( i, stnd )
    end do
!
!   PRINT POWER SPECTRUM OF x(:n).
!
    call print_array( psx, title='POWER SPECTRUM', namcol=(/ "PERIOD", "PSD   "/) )
!
!   ESTIMATE THE MEAN AND VARIANCE OF THE SIGNAL THROUGH THE POWER SPECTRUM.
!
    xmean2 = sqrt( psx(1,2) )
    xvar2  = sum( psx(2:psn,2) )
!
!   COMPUTE THE MEAN AND THE VARIANCE WITH SUBROUTINE comp_mvs .
!
    call comp_mvs( X=x(:n), FIRST=true, LAST=true, XMEAN=xmean, XVAR=xvar, XSTD=xstd )
!
!   COMPARE THE TWO SETS OF STATISTICS.
!
    err_mean = abs( (xmean-xmean2)/xmean )
    err_var  = abs( (xvar-xvar2)/xvar )
!
!   TEST THE ACCURACY OF THE STATISTICS.
!
    if ( max(err_mean,err_var)<=eps  ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex1_power_spectrum
! =================================
!
end program ex1_power_spectrum

ex1_print_array.F90

program ex1_print_array
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine PRINT_ARRAY
!   in module Print_Procedures .
!                                                                            
! LATEST REVISION : 26/06/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, print_array
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, m=20, n=5
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)  :: real_matrix(m,n), real_vector(m)
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of print_array'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A RANDOM REAL MATRIX .
!
    call random_number( real_matrix )
!
!   GENERATE A RANDOM REAL VECTOR .
!
    call random_number( real_vector )
!
!   PRINT THE RANDOM REAL MATRIX .
!
    call print_array( real_matrix, title='real_matrix' )
!
!   PRINT THE RANDOM REAL VECTOR .
!
    call print_array( real_vector, title='real_vector' )
!
!
! END OF PROGRAM ex1_print_array
! ==============================
!
end program ex1_print_array

ex1_probbeta.F90

program ex1_probbeta
!
!
! Purpose
! =======
!
!   This program is intended to illustrate the use of functions PROBBETA, PINVSTUDENT
!   in module Prob_Procedures .
!                                                                              
!                                                                              
! LATEST REVISION : 22/02/2013
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, half, probbeta, pinvstudent
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=5000, m=10000
!
    real(stnd), parameter :: eps = 1.0e-4_stnd 
!
    character(len=*), parameter :: name_proc='Example 1 of probbeta'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd), dimension(n,m) :: p, p2, t, x
    real(stnd)                 :: err, df, a
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE THE DEGREES OF FREEDOM OF STUDENT T-DISTRIBUTION .
!
    df = 50_stnd
!
!   GENERATE A RANDOM PROBABILITY MATRIX p .
!
    call random_number( p(:n,:m) )
!
!   COMPUTE THE TWO-TAIL QUANTILES T OF STUDENT T-DISTRIBUTION
!   WITH df DEGREES OF FREEDOM.
!
    t(:n,:m) = pinvstudent( p(:n,:m), df )
!
!   RECOMPUTE THE PROBABILITIES FROM THE QUANTILES
!   WITH probbeta FUNCTION.
!
    x(:n,:m) =  df/(df+ t(:n,:m)*t(:n,:m) )
    a = half*df
!
    p2(:n,:m) = probbeta( x(:n,:m), a, half )
!
!   CHECK THAT p AND p2 AGREE.
!
    err = maxval( abs( p(:n,:m) - p2(:n,:m) ) )
!
!   PRINT THE RESULT OF THE TEST.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex1_probbeta
! ===========================
!
end program ex1_probbeta

ex1_probn.F90

program ex1_probn
!
!
! Purpose
! =======
!
!   This program is intended to illustrate the use of functions PROBN and PINVN
!   in module Prob_Procedures .
!                                                                              
!                                                                              
! LATEST REVISION : 15/02/2013
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, false, probn, pinvn
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=5000, m=10000
!
    real(stnd), parameter :: eps = 1.0e-4_stnd 
!
    character(len=*), parameter :: name_proc='Example 1 of probn'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd), dimension(n,m) :: p, p2, x
    real(stnd)                 :: err
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A RANDOM PROBABILITY MATRIX p .
!
    call random_number( p(:n,:m) )
!
!   COMPUTE THE NORMAL DEVIATES CORRESPONDING TO LOWER TAIL AREAS OF P .
!
    x(:n,:m) = pinvn( p(:n,:m) ) 
!
!   RECOMPUTE THE PROBABILITIES FROM THE NORMAL DEVIATES .
!
    p2(:n,:m) = probn( x(:n,:m), upper=false )
!
!   CHECK THAT p AND p2 AGREE.
!
    err = maxval( abs( p(:n,:m) - p2(:n,:m) ) )
!
!   PRINT THE RESULT OF THE TEST.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex1_probn
! ========================
!
end program ex1_probn

ex1_probn2.F90

program ex1_probn2
!
!
! Purpose
! =======
!
!   This program is intended to illustrate the use of functions PROBN2 and PINVN2
!   in module Prob_Procedures .
!                                                                              
!                                                                              
! LATEST REVISION : 15/02/2013
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, extd, false, probn2, pinvn2
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=5000, m=10000
!
    real(extd), parameter :: eps = 1.0e-6_extd
!
    character(len=*), parameter :: name_proc='Example 1 of probn2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(extd), dimension(n,m) :: p, p2, x
    real(extd)                 :: err
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A RANDOM PROBABILITY MATRIX p .
!
    call random_number( p(:n,:m) )
!
!   COMPUTE THE NORMAL DEVIATES CORRESPONDING TO LOWER TAIL AREAS OF P .
!
    x(:n,:m) = pinvn2( p(:n,:m) ) 
!
!   RECOMPUTE THE PROBABILITIES FROM THE NORMAL DEVIATES .
!
    p2(:n,:m) = probn2( x(:n,:m), upper=false )
!
!   CHECK THAT p AND p2 AGREE.
!
    err = maxval( abs( p(:n,:m) - p2(:n,:m) ) )
!
!   PRINT THE RESULT OF THE TEST.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex1_probn2
! =========================
!
end program ex1_probn2

ex1_probq.F90

program ex1_probq
!
!
! Purpose
! =======
!
!   This program is intended to illustrate the use of functions PROBQ, PINVQ
!   in module Prob_Procedures .
!                                                                              
!                                                                              
! LATEST REVISION : 26/02/2013
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, false, probq, pinvq
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=5000, m=10000
!
    real(stnd), parameter :: eps = 1.0e-3_stnd 
!
    character(len=*), parameter :: name_proc='Example 1 of probq'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd), dimension(n,m) :: p, p2, x2
    real(stnd)                 :: err
!
    integer(i4b) :: ndf
!
    logical(lgl) :: upper
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE THE DEGREES OF FREEDOM OF CHI-SQUARED DISTRIBUTION .
!
    ndf = 50_i4b
!
!   GENERATE A RANDOM PROBABILITY MATRIX p(:m,:n) .
!
    call random_number( p(:n,:m) )
!
!   COMPUTE THE QUANTILES x2(:m,:n) OF CHI-SQUARED DISTRIBUTION WITH ndf DEGREES OF FREEDOM
!   CORRESPONDING TO LOWER TAIL AREAS OF p(:m,:n) .
!
    x2(:n,:m) = pinvq( p(:n,:m), ndf )
!
!   RECOMPUTE THE PROBABILITIES FROM THE QUANTILES
!   WITH probq FUNCTION.
!
    upper = false
!
    p2(:n,:m) = probq( x2(:n,:m), ndf, upper=upper )
!
!   CHECK THAT p(:n,:m) AND p2(:n,:m) AGREE.
!
    err = maxval( abs( p(:n,:m) - p2(:n,:m) ) )
!
!   PRINT THE RESULT OF THE TEST.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex1_probq
! ========================
!
end program ex1_probq

ex1_probq2.F90

program ex1_probq2
!
!
! Purpose
! =======
!
!   This program is intended to illustrate the use of functions PROBQ2, PINVQ2
!   in module Prob_Procedures .
!                                                                              
!                                                                              
! LATEST REVISION : 26/02/2013
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, false, probq2, pinvq2
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=5000, m=10000
!
    real(stnd), parameter :: eps = 1.0e-3_stnd 
!
    character(len=*), parameter :: name_proc='Example 1 of probq2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd), dimension(n,m) :: p, p2, x2
    real(stnd)                 :: err, df
!
    integer(i4b) :: i, j
!
    logical(lgl) :: upper
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE THE DEGREES OF FREEDOM OF CHI-SQUARED DISTRIBUTION.
!   DF IS NOT NECESSARILY AN INTEGER.
!
    df = 50.5_stnd
!
!   GENERATE A RANDOM PROBABILITY MATRIX p(:m,:n) .
!
    call random_number( p(:n,:m) )
!
!   COMPUTE THE QUANTILES x2(:m,:n) OF CHI-SQUARED DISTRIBUTION WITH df DEGREES OF FREEDOM
!   CORRESPONDING TO LOWER TAIL AREAS OF p(:m,:n) .
!
    x2(:n,:m) = pinvq2( p(:n,:m), df )
!
!   RECOMPUTE THE PROBABILITIES FROM THE QUANTILES
!   WITH probq2 FUNCTION.
!
    upper = false
!
    p2(:n,:m) = probq2( x2(:n,:m), df, upper=upper )
!
!   CHECK THAT p(:n,:m) AND p2(:n,:m) AGREE.
!
    err = maxval( abs( p(:n,:m) - p2(:n,:m) ) )
!
!   PRINT THE RESULT OF THE TEST.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex1_probq2
! =========================
!
end program ex1_probq2

ex1_probq3.F90

program ex1_probq3
!
!
! Purpose
! =======
!
!   This program is intended to illustrate the use of functions PROBQ3, PINVQ2
!   in module Prob_Procedures .
!                                                                              
!                                                                              
! LATEST REVISION : 26/02/2013
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, false, probq3, pinvq2
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=5000, m=10000
!
    real(stnd), parameter :: eps = 1.0e-3_stnd 
!
    character(len=*), parameter :: name_proc='Example 1 of probq3'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd), dimension(n,m) :: p, p2, x2
    real(stnd)                 :: err, df
!
    integer(i4b) :: i, j
!
    logical(lgl) :: upper
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE THE DEGREES OF FREEDOM OF CHI-SQUARED DISTRIBUTION.
!   DF IS NOT NECESSARILY AN INTEGER.
!
    df = 50.5_stnd
!
!   GENERATE A RANDOM PROBABILITY MATRIX p(:m,:n) .
!
    call random_number( p(:n,:m) )
!
!   COMPUTE THE QUANTILES x2(:m,:n) OF CHI-SQUARED DISTRIBUTION WITH df DEGREES OF FREEDOM
!   CORRESPONDING TO LOWER TAIL AREAS OF p(:m,:n) .
!
    x2(:n,:m) = pinvq2( p(:n,:m), df )
!
!   RECOMPUTE THE PROBABILITIES FROM THE QUANTILES
!   WITH probq3 FUNCTION.
!
    upper = false
!
    p2(:n,:m) = probq3( x2(:n,:m), df, upper=upper )
!
!   CHECK THAT p(:n,:m) AND p2(:n,:m) AGREE.
!
    err = maxval( abs( p(:n,:m) - p2(:n,:m) ) )
!
!   PRINT THE RESULT OF THE TEST.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex1_probq3
! =========================
!
end program ex1_probq3

ex1_probstudent.F90

program ex1_probstudent
!
!
! Purpose
! =======
!
!   This program is intended to illustrate the use of functions PROBSTUDENT, PINVSTUDENT
!   in module Prob_Procedures .
!                                                                              
!                                                                              
! LATEST REVISION : 26/02/2013
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, false, probstudent, pinvstudent
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=5000, m=10000
!
    real(stnd), parameter :: eps = 1.0e-4_stnd 
!
    character(len=*), parameter :: name_proc='Example 1 of probstudent'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd), dimension(n,m) :: p, p2, t
    real(stnd)                 :: err, df
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE THE DEGREES OF FREEDOM OF STUDENT T-DISTRIBUTION .
!
    df = 50._stnd
!
!   GENERATE A RANDOM PROBABILITY MATRIX p(:n,:m) .
!
    call random_number( p(:n,:m) )
!
!   COMPUTE THE TWO-TAIL QUANTILES t OF STUDENT T-DISTRIBUTION 
!   WITH df DEGREES OF FREEDOM CORRESPONDING TO AREAS OF p(:n,:m) .
!
    t(:n,:m) = pinvstudent( p(:n,:m), df )
!
!   RECOMPUTE THE PROBABILITIES FROM THE QUANTILES
!   WITH probstudent FUNCTION.
!
    p2(:n,:m) = probstudent( t(:n,:m), df )
!
!   CHECK THAT p AND p2 AGREE.
!
    err = maxval( abs( p(:n,:m) - p2(:n,:m) ) )
!
!   PRINT THE RESULT OF THE TEST.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex1_probstudent
! ==============================
!
end program ex1_probstudent

ex1_probt.F90

program ex1_probt
!
!
! Purpose
! =======
!
!   This program is intended to illustrate the use of functions PROBT, PINVT
!   in module Prob_Procedures .
!                                                                              
!                                                                              
! LATEST REVISION : 26/02/2013
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, false, probt, pinvt
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=5000, m=10000
!
    real(stnd), parameter :: eps = 1.0e-4_stnd 
!
    character(len=*), parameter :: name_proc='Example 1 of probt'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd), dimension(n,m) :: p, p2, t
    real(stnd)                 :: err
!
    integer(i4b) :: ndf
!
    logical(lgl) :: upper
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE THE DEGREES OF FREEDOM OF STUDENT T-DISTRIBUTION .
!
    ndf = 50_i4b
!
!   GENERATE A RANDOM PROBABILITY MATRIX p(:,:) .
!
    call random_number( p(:n,:m) )
!
!   COMPUTE THE QUANTILES T OF STUDENT T-DISTRIBUTION WITH ndf DEGREES OF FREEDOM
!   CORRESPONDING TO LOWER TAIL AREAS OF p(:,:) .
!
    t(:n,:m) = pinvt( p(:n,:m), ndf )
!
!   RECOMPUTE THE PROBABILITIES FROM THE QUANTILES
!   WITH probt FUNCTION.
!
    upper = false
!
    p2(:n,:m) = probt( t(:n,:m), ndf, upper=upper )
!
!   CHECK THAT p AND p2 AGREE.
!
    err = maxval( abs( p(:n,:m) - p2(:n,:m) ) )
!
!   PRINT THE RESULT OF THE TEST.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex1_probt
! ========================
!
end program ex1_probt

ex1_qr_cmp.F90

program ex1_qr_cmp
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines QR_CMP and 
!   ORTHO_GEN_QR in modules QR_Procedures.
!                                                                              
! LATEST REVISION : 15/06/2018
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, one, c50, qr_cmp, ortho_gen_qr,   &
                         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
!
    integer(i4b), parameter :: prtunit = 6, m=2000, n=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of qr_cmp'
!
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, err3, eps, ulp, elapsed_time
    real(stnd), allocatable, dimension(:)   :: diagr, beta, resid2, norma
    real(stnd), allocatable, dimension(:,:) :: a, q, r, resid
!
    integer(i4b) :: k, j, l
    integer      :: 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 : COMPUTE QR DECOMPOSITION OF RANDOM DATA MATRIX.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    ulp = epsilon( err )
    eps = fudge*ulp
    err = zero
!
    do_test = true
!
    k = min( m, n )
    l = max( m, n )
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( r(k,n), q(m,l), diagr(k), beta(k), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM COEFFICIENT MATRIX a(:m,:n) .
!
    call random_number( q(:m,:n) )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( a(m,n), resid(m,l), resid2(n), norma(n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       MAKE A COPY OF THE RANDOM DATA MATRIX.
!
        a(:m,:n) = q(:m,:n)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   COMPUTE QR DECOMPOSITION OF RANDOM DATA MATRIX WITH SUBROUTINE qr_cmp.
!
    call qr_cmp( q(:m,:n), diagr(:k), beta(:k) )
!
!   qr_cmp COMPUTES AN ORTHOGONAL FACTORIZATION OF A REAL m-BY-n MATRIX
!   BY THE HOUSEOLDER METHOD. THE MATRIX IS ASSUMED OF FULL RANK. THE ROUTINE
!   COMPUTES A QR FACTORIZATION OF a AS:
!
!                     a = q * r 
!
!   ON EXIT, a HAS BEEN OVERWRITTEN BY DETAILS OF ITS ORTHOGONAL
!   FACTORIZATION. 
!
!   THE MATRIX q IS REPRESENTED AS A PRODUCT OF ELEMENTARY REFLECTORS
!
!            q = h(1)*h(2)* ... *h(k), WHERE k = min( size(a,1) , size(a,2) )
!
!   EACH h(i) HAS THE FORM
!
!            h(i) = I + BETA * ( V * V' ) ,
!                      
!   WHERE BETA IS A REAL SCALAR AND V IS A REAL M-ELEMENT VECTOR WITH V(1:i-1) = 0.
!   V(i:m) IS STORED ON EXIT IN a(i:m,i) AND BETA IN beta(i).
!                      
!   THE ELEMENTS ABOVE THE DIAGONAL OF THE ARRAY a CONTAIN THE
!   CORRESPONDING ELEMENTS OF THE TRIANGULAR MATRIX r. THE ELEMENTS
!   OF THE DIAGONAL OF r ARE STORED IN THE ARRAY diagr. 
!
!   NOW, RESTORE TRIANGULAR FACTOR r OF QR DECOMPOSITION OF RANDOM DATA MATRIX a
!   IN MATRIX r(:k,:n) .
!
    do j = 1_i4b, k
!
        r(1_i4b:j-1_i4b,j) = q(1_i4b:j-1_i4b,j)
        r(j,j)             = diagr(j)
        r(j+1_i4b:k,j)     = zero
!
    end do
!
    do j = k+1_i4b, n
!
        r(1_i4b:k,j) = q(1_i4b:k,j)
!
    end do
!
!   GENERATE ORTHOGONAL MATRIX q OF QR DECOMPOSITION OF RANDOM DATA MATRIX a
!   AND AN ORTHOGONAL BASIS FOR THE ORTHOGONAL COMPLEMENT TO THE RANGE OF a .
!   a IS ASSUMED OF FULL RANK.
!
    call ortho_gen_qr( q(:m,:m), beta(:k) )
!
!   ortho_gen_qr GENERATES AN m-BY-m REAL MATRIX WITH ORTHONORMAL COLUMNS, WHICH IS
!   DEFINED AS THE FIRST m COLUMNS OF A PRODUCT OF k ELEMENTARY REFLECTORS OF ORDER m
!
!            q = h(1)*h(2)* ... *h(k)
!
!   AS RETURNED BY qr_cmp OR qr_cmp2.
!
!   THE SIZE OF beta DETERMINES THE NUMBER k OF ELEMENTARY REFLECTORS
!   WHOSE PRODUCT DEFINES THE MATRIX q.
!
!   NOW Q IS IN q(:m,:k) AND THE ORTHOGONAL BASIS FOR THE ORTHOGONAL COMPLEMENT
!   TO THE RANGE OF a IS IN q(:m,k+1:m).
!
!   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 ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a(:m,:n) - q(:m,:n)*r(:n,:n).
!
        resid(:m,:n) = a(:m,:n) - matmul( q(:m,:k), r(:k,:n) )
        resid2(:n)   = norm( resid(:m,:n), dim=2_i4b )
        norma(:n)    = norm( a(:m,:n), dim=2_i4b )
        err1         = maxval( resid2(:n) / norma(:n) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - Q'*Q.
!
        call unit_matrix( resid(:m,:m) )
!
        resid(:m,:m) = abs( resid(:m,:m) - matmul( transpose(q(:m,:m)), q(:m,:m) ) )
        err2 = maxval( resid(:m,:m) )/real(m,stnd)
!
!       CHECK ORTHOGONALITY OF a(:m,:n) AND ITS ORTHOGONAL COMPLEMENT q(:m,n+1:m).
!
        if ( m>n ) then
!
            resid(:n,n+1_i4b:m) = matmul( transpose(a(:m,:n)), q(:m,n+1_i4b:m) )
            err3 = maxval( abs( resid(:n,n+1_i4b:m) ) )/real(m,stnd)
!
        else
!
            err3 = zero
!
        end if
!
        err = max( err1, err2, err3 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, resid, resid2, norma )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( r, q, diagr, beta )
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) then
!
        write (prtunit,*) 
        write (prtunit,*) 'Accuracy of the QR decomposition                                       = ', err1
        write (prtunit,*) 'Orthogonality of the Q matrix                                          = ', err2
!
        if ( m>n ) then
            write (prtunit,*) 'Orthogonality of the range of the matrix and its orthogonal complement = ', err3
        end if
!
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing QR decomposition of a ', &
       m, ' by ', n,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_qr_cmp
! =========================
!
end program ex1_qr_cmp

ex1_qr_cmp2.F90

program ex1_qr_cmp2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines QR_CMP2 and 
!   ORTHO_GEN_QR in modules QR_Procedures.
!                                                                              
! LATEST REVISION : 02/06/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, one, c50, qr_cmp2, ortho_gen_qr,   &
                         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
!
    integer(i4b), parameter :: prtunit = 6, m=3000, n=300
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of qr_cmp2'
!
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, err3, eps, ulp, tol, elapsed_time
    real(stnd), allocatable, dimension(:)   :: diagr, beta, resid2, norma
    real(stnd), allocatable, dimension(:,:) :: a, q, r, resid
!
    integer(i4b)                            :: k, j, l, krank
    integer(i4b), allocatable, dimension(:) :: ip
    integer                                 :: 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 : COMPUTE QR DECOMPOSITION WITH COLUMN PIVOTING
!               OF RANDOM DATA MATRIX.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    ulp = epsilon( err )
    eps = fudge*ulp
    err = zero
!
!   SET TOLERANCE .
!
    tol = 0.000001_stnd
!
    krank = 0
!
    do_test = true
!
    k = min( m, n )
    l = max( m, n )
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( r(k,n), q(m,l), diagr(k), beta(k), ip(n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM COEFFICIENT MATRIX a(:m,:n) .
!
    call random_number( q(:m,:n) )
!
!   GENERATE A DEFICIENT COEFFICIENT MATRIX a(:m,:n) .
!
    j = min( n, 5_i4b ) 
    q(:m,j) = q(:m,1_i4b) + q(:m,2_i4b)
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( a(m,n), resid(m,l), resid2(n), norma(n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       MAKE A COPY OF THE RANDOM DATA MATRIX.
!
        a(:m,:n) = q(:m,:n)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   COMPUTE QR DECOMPOSITION WITH COLUMN PIVOTING OF RANDOM DATA MATRIX
!   WITH SUBROUTINE qr_cmp2.
!
    call qr_cmp2( q(:m,:n), diagr(:k), beta(:k), ip(:n), krank, tol=tol )
!
!   qr_cmp2 COMPUTES A (COMPLETE) ORTHOGONAL FACTORIZATION OF A REAL m-BY-n MATRIX.
!   THE MATRIX MAY BE RANK-DEFICIENT. THE ROUTINE FIRST COMPUTES A QR FACTORIZATION
!   WITH COLUMN PIVOTING OF a AS:
!
!                     a * p = q * r = q * [ r11 r12 ]
!                                         [  0  r22 ]
!
!   WITH r11 DEFINED AS THE LARGEST LEADING SUBMATRIX WHOSE ESTIMATED CONDITION
!   NUMBER, IN THE 1-NORM, IS LESS THAN 1/tol OR SUCH THAT ABS(r11[j,j])>0 IF 
!   tol IS ABSENT. THE ORDER OF r11, krank, IS THE EFFECTIVE RANK OF a. 
!
!   ON INPUT, krank=k, IMPLIES THAT THE FIRST k COLUMNS OF A ARE
!   TO BE FORCED INTO THE BASIS. PIVOTING IS PERFORMED ON THE LAST n-k
!   COLUMNS OF a.
!   WHEN krank>=min(m,n) IS USED, PIVOTING IS NOT PERFORMED. THIS IS
!   APPROPRIATE WHEN a IS KNOWN TO BE FULL RANK. krank<=0 CAN BE USED
!   WHEN PIVOTING IS DESIRED ON ALL COLUMNS OF a.
!   
!   IF THE OPTIONAL PARAMETER tau IS PRESENT, THEN r22 IS CONSIDERED TO BE NEGLIGIBLE
!   AND r12 IS ANNIHILATED BY ORTHOGONAL TRANSFORMATIONS FROM THE RIGHT,
!   ARRIVING AT THE COMPLETE ORTHOGONAL FACTORIZATION:
!  
!                     a * p = q * [ t11 0 ] * z
!                                 [  0  0 ]
!   
!   p IS A n-BY-n PERMUTATION MATRIX, q IS A m-BY-m ORTHOGONAL MATRIX,
!   r IS A m-BY-n UPPER TRIANGULAR MATRIX, t11 IS A krank-BY-krank UPPER
!   TRIANGULAR MATRIX AND z IS A n-BY-n ORTHOGONAL MATRIX.
!
!   ON EXIT, a HAS BEEN OVERWRITTEN BY DETAILS OF ITS (COMPLETE) 
!   ORTHOGONAL FACTORIZATION. 
!
!   THE MATRIX q IS REPRESENTED AS A PRODUCT OF ELEMENTARY REFLECTORS
!
!            q = h(1)*h(2)* ... *h(k), WHERE k = min( size(a,1) , size(a,2) )
!
!   EACH h(i) HAS THE FORM
!
!            h(i) = I + BETA * ( V * V' ) ,
!                      
!   WHERE BETA IS A REAL SCALAR AND V IS A REAL M-ELEMENT VECTOR WITH V(1:i-1) = 0.
!   V(i:m) IS STORED ON EXIT IN a(i:m,i) AND BETA IN beta(i).
!                      
!   IF THE OPTIONAL PARAMETER tau IS ABSENT :         
!                      
!      qr_cmp2 COMPUTES ONLY A QR FACTORIZATION WITH COLUMN PIVOTING OF a.
!                      
!      THE ELEMENTS ABOVE THE DIAGONAL OF THE ARRAY a CONTAIN THE
!      CORRESPONDING ELEMENTS OF THE TRIANGULAR MATRIX r. THE ELEMENTS
!      OF THE DIAGONAL OF r ARE STORED IN THE ARRAY diagr. 
!
!      ON EXIT, IF ip(j)=k, THEN THE jTH COLUMN OF a*p WAS 
!      THE kTH COLUMN OF a. THE MATRIX p IS REPRESENTED IN THE ARRAY 
!      ip AS FOLLOWS: IF ip(j) = i THEN THE jTH COLUMN OF p IS 
!      THE iTH CANONICAL UNIT VECTOR.
!                      
!      ON EXIT, krank CONTAINS THE EFFECTIVE RANK OF a, I.E., THE ORDER OF
!      THE SUBMATRIX r11.
!                      
!   IF THE OPTIONAL PARAMETER tau IS PRESENT :         
!                      
!      qr_cmp2 COMPUTES A COMPLETE ORTHOGONAL FACTORIZATION OF a FROM THE QR 
!      FACTORIZATION WITH COLUMN PIVOTING OF a .
!                      
!      THE FACTORIZATION IS OBTAINED BY HOUSEHOLDER'S METHOD. THE kTH TRANSFORMATION
!      MATRIX, z(k), WHICH IS USED TO INTRODUCE ZEROS INTO THE kTH ROW OF r,
!      IS GIVEN IN THE FORM
!
!             z(k) = ( I    0  ),
!                    ( 0  T(k) )
!
!      WHERE
!
!             T(k) = I + TAU * ( U(k) * U(k)' ) , U(k) = (   1  )
!                                                        (   0  )
!                                                        ( L(k) )
!
!      TAU IS A SCALAR AND L(k) IS AN (n-krank) ELEMENT VECTOR. TAU and L(k) ARE CHOSEN
!      TO ANNIHILATE THE ELEMENTS OF THE kTH ROW OF r12.
!
!      ON EXIT, THE SCALAR TAU IS RETURNED IN THE kTH ELEMENT OF tau AND THE VECTOR U(K)
!      IN THE kTH ROW OF a, SUCH THAT THE ELEMENTS OF L(k) ARE IN a(k,krank+1:n).
!
!      THE z n-BY-n ORTHOGONAL MATRIX WHICH IS APPLIED FROM THE RIGHT TO R IS 
!      GIVEN BY THE PRODUCT
!
!             z = z(1) * z(2) * ... * z(krank)
!
!      ON EXIT, THE ELEMENTS ABOVE THE DIAGONAL OF THE ARRAY SECTION a(1:krank,1:krank)
!      CONTAIN THE CORRESPONDING ELEMENTS OF THE TRIANGULAR MATRIX t11. THE ELEMENTS OF
!      THE DIAGONAL OF t11 ARE STORED IN THE ARRAY SECTION diagr(1:krank).
!                      
!      ON EXIT, IF ip(j)=k, THEN THE jTH COLUMN OF a*p WAS 
!      THE kTH COLUMN OF a. THE MATRIX p IS REPRESENTED IN THE ARRAY 
!      ip AS FOLLOWS: IF ip(j) = i THEN THE jTH COLUMN OF p IS 
!      THE iTH CANONICAL UNIT VECTOR.
!                      
!      ON EXIT, krank CONTAINS THE EFFECTIVE RANK OF a, I.E., THE ORDER OF
!      THE SUBMATRIX t11.
!                      
!   IF tol IS PRESENT AND IS IN [0,1[, THEN :
!       ON ENTRY, THE CALCULATIONS TO DETERMINE THE CONDITION NUMBER OF a
!       ARE PERFORMED. THEN, tol IS USED TO DETERMINE THE EFFECTIVE RANK
!       OF a, WHICH IS DEFINED AS THE ORDER OF THE LARGEST LEADING
!       TRIANGULAR SUBMATRIX r11 IN THE QR FACTORIZATION WITH PIVOTING OF a,
!       WHOSE ESTIMATED CONDITION NUMBER IS LESS THAN 1/tol. IF tol=0 IS SPECIFIED
!       THE NUMERICAL RANK OF a IS DETERMINED.
!       ON EXIT, THE RECIPROCAL OF THE CONDITION NUMBER IS RETURNED IN tol.
!
!   IF tol IS NOT SPECIFIED OR IS OUTSIDE [0,1[ :
!       THE CALCULATIONS TO DETERMINE THE CONDITION NUMBER OF a ARE NOT
!       PERFORMED AND CRUDE TESTS ON r(j,j) ARE DONE TO DETERMINE
!       THE NUMERICAL RANK OF a.
!
!   IF IT IS POSSIBLE THAT a MAY NOT BE FULL RANK (I.E., CERTAIN COLUMNS OF a ARE
!   LINEAR COMBINATIONS OF OTHER COLUMNS), THEN THE LINEARLY DEPENDENT COLUMNS CAN
!   USUALLY BE DETERMINED BY USING krank=0  AND tol=RELATIVE PRECISION OF THE ELEMENTS
!   IN a. IF EACH ELEMENT IS CORRECT TO, SAY, 5 DIGITS THEN tol=0.00001 SHOULD
!   BE USED. ALSO, IT MAY BE HELPFUL TO SCALE THE COLUMNS OF a SO THAT ALL ELEMENTS 
!   ARE ABOUT THE SAME ORDER OF MAGNITUDE.
!
!   NOW, RESTORE TRIANGULAR FACTOR r OF QR DECOMPOSITION OF RANDOM DATA MATRIX a
!   IN MATRIX r(:k,:n) .
!
    do j = 1_i4b, k
!
        r(1_i4b:j-1_i4b,j) = q(1_i4b:j-1_i4b,j)
        r(j,j)             = diagr(j)
        r(j+1_i4b:k,j)     = zero
!
    end do
!
    do j = k+1_i4b, n
!
        r(1_i4b:k,j) = q(1_i4b:k,j)
!
    end do
!
!   GENERATE ORTHOGONAL MATRIX q OF QR DECOMPOSITION OF RANDOM DATA MATRIX a
!   AND AN ORTHOGONAL BASIS FOR THE ORTHOGONAL COMPLEMENT TO THE RANGE OF a .
!   a IS NOT ASSUMED OF FULL RANK.
!
    call ortho_gen_qr( q(:m,:m), beta(:krank) )
!
!   ortho_gen_qr GENERATES AN m-BY-m REAL MATRIX WITH ORTHONORMAL COLUMNS, WHICH IS
!   DEFINED AS THE FIRST m COLUMNS OF A PRODUCT OF k ELEMENTARY REFLECTORS OF ORDER m
!
!            q = h(1)*h(2)* ... *h(k)
!
!   AS RETURNED BY qr_cmp OR qr_cmp2.
!
!   THE SIZE OF beta DETERMINES THE NUMBER k OF ELEMENTARY REFLECTORS
!   WHOSE PRODUCT DEFINES THE MATRIX q.
!
!   NOW q IS IN q(:m,:krank) AND THE ORTHOGONAL BASIS FOR THE ORTHOGONAL COMPLEMENT
!   TO THE RANGE OF a IS IN q(:m,krank+1:m).
!
!   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 ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a(:m,:n)*p(:n,:n) - q(:m,:krank)*r(:krank,:n).
!
        resid(:m,:n) = a(:m,ip(:n)) - matmul( q(:m,:krank), r(:krank,:n) )
        resid2(:n)   = norm( resid(:m,:n), dim=2_i4b )
        norma(:n)    = norm( a(:m,:n), dim=2_i4b )
        err1         = maxval( resid2(:n) / norma(:n) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - Q**(t)*Q.
!
        call unit_matrix( resid(:m,:m) )
!
        resid(:m,:m) = abs( resid(:m,:m) - matmul( transpose(q(:m,:m)), q(:m,:m) ) )
        err2 = maxval( resid(:m,:m) )/real(m,stnd)
!
!       CHECK ORTHOGONALITY OF a(:m,:krank) AND ITS ORTHOGONAL COMPLEMENT q(:m,krank+1:n).
!
        if ( m>krank ) then
!
            resid(:krank,krank+1:m) = matmul( transpose(a(:m,:krank)), q(:m,krank+1:m) )
            err3 = maxval( abs( resid(:krank,krank+1:m) ) )/real(m,stnd)
!
        else
!
            err3 = zero
!
        end if
!
        err = max( err1, err2, err3 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, resid, resid2, norma )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( r, q, diagr, beta, ip )
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) then
!
        write (prtunit,*) 
        write (prtunit,*) 'Rank of the matrix               = ', krank
        write (prtunit,*) 'Accuracy of the QR decomposition = ', err1
        write (prtunit,*) 'Orthogonality of the Q matrix    = ', err2
!
        if ( m>n ) then
            write (prtunit,*) 'Orthogonality of the range of the matrix&
                              & and its orthogonal complement = ', err3
        end if
!
    end if
!
    write (prtunit,*)
    write (*,'(a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing QR decomposition with column pivoting of a ', &
       m, ' by ', n,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_qr_cmp2
! ==========================
!
end program ex1_qr_cmp2

ex1_quick_sort.F90

program ex1_quick_sort
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine QUICK_SORT
!   in module Sort_Procedures.
!                                                                              
! LATEST REVISION : 27/06/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, false, arth, quick_sort
!   
!
! STRONG TYPING IMPOSED
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=100
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd), dimension(n) :: x
!
    integer(i4b)               :: i, i1, i2, j, k
    integer(i4b), dimension(n) :: y
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of quick_sort'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE RANDOM REAL DATA TO SORT.
!
    call random_number( x )
!
!   GENERATE A RANDOM ORDERING OF THE INTEGERS 1 TO n.
!
    y = arth( 1_i4b, 1_i4b, n ) 
!    
!   STARTING AT THE END, SWAP THE CURRENT LAST INDICATOR WITH ONE
!   RANDOMLY CHOSEN FROM THOSE PRECEEDING IT.

    do i = n, 2, -1
        j = 1 + i * x(i)
        if (j < i) then
            k    = y(i)
            y(i) = y(j)
            y(j) = k
        end if
    end do
!
!   EXAMPLE 1 : SORT THE REAL DATA IN ASCENDING ORDER.
!
    call quick_sort( x  )
!
!   CHECK THAT THE SORTED ARRAY IS NON-DECREASING.
!
    i1 = count( x(1:n-1) > x(2:n) )
!
!   EXAMPLE 2 : SORT THE INTEGER DATA IN DECREASING ORDER.
!
    call quick_sort( y, ascending=false )
!
!   CHECK THAT THE SORTED ARRAY IS NON-INCREASING.
!
    i2 = count( y(1:n-1) < y(2:n) )
!
!   PRINT THE RESULT OF THE TESTS.
!
    if ( i1==0 .and. i2==0 ) then
        write (prtunit,*) 'Example 1 of QUICK_SORT is correct'
    else
        write (prtunit,*) 'Example 1 of QUICK_SORT is incorrect'
    end if
!
!
! END OF PROGRAM ex1_quick_sort
! =============================
!
end program ex1_quick_sort

ex1_random_eig.F90

program ex1_random_eig
!
!
! Purpose
! =======
!
!   This program illustrates how to compute an approximate partial EigenValue
!   Decomposition (EVD) of a symmetric matrix with randomized power subspace iterations
!   using STATPACK.
!                                                                              
!                                                     
! Further Details
! ===============
!
!   The program shows the use of subroutines QR_CMP and ORTHO_GEN_QR
!   in module QR_Procedures, EIG_CMP in module Eig_procedures, RANDOM_NUMBER_,
!   NORMAL_RANDOM_NUMBER3_ and GEN_RANDOM_SYM_MAT in module Random.
!                                                                              
! LATEST REVISION : 23/10/2020
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, half, one, seven, c30, merror, allocate_error, &
                         norm, unit_matrix, random_seed_, random_number_, normal_random_number3_,          &
                         eig_abs_sort, qr_cmp, ortho_gen_qr, eig_cmp, gen_random_sym_mat
!
#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, neig IS THE TARGET RANK OF THE APPROXIMATE PARTIAL EVD DECOMPOSITION,
! neig0 IS THE RANK OF THE GENERATED MATRIX,
! n IS THE DIMENSION OF THE GENERATED SYMMETRIC MATRIX.
!
    integer(i4b), parameter :: prtunit=6, n=2000, neig=5, neig0=1000
!
    character(len=*), parameter :: name_proc='Example 1 of random_eig'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd) :: err, err1, err2, eps, elapsed_time, tmp, norma, relerr, relerr2
    real(stnd), dimension(:,:), allocatable :: a, q, qt, b, eigvec, v
    real(stnd), dimension(:),   allocatable :: diagr, beta, eigval0, eigval
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: p, np, i, niter, mat_type
!
    logical(lgl) :: failure, do_test, ortho
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : PARTIAL EIGENVALUE DECOMPOSITION OF A n-BY-n REAL SYMMETRIC
!               MATRIX USING RANDOMIZED POWER SUBSPACE OR BLOCK KRYLOV ITERATIONS.
!
!   SPECIFY THE TYPE OF INPUT MATRIX:
!
!   mat_type = 1  -> SLOW DECAY OF EIGENVALUES      (IN ABSOLUTE MAGNITUDE)
!   mat_type = 2  -> FAST DECAY OF EIGENVALUES      (IN ABSOLUTE MAGNITUDE)
!   mat_type = 3  -> S-SHAPED DECAY OF EIGENVALUES  (IN ABSOLUTE MAGNITUDE)
!   mat_type > 3  -> VERY SLOW DECAY OF EIGENVALUES (IN ABSOLUTE MAGNITUDE)
!
    mat_type = 2_i4b
!
!   SET TOLERANCE FOR THE ERROR OF THE RELATIVE ERROR IN FROBENIUS NORM
!   OF THE COMPUTED PARTIAL EVD.
!
    eps = 0.001_stnd
!
!   SPECIFY IF NUMERICAL TESTS ARE PERFORMED TO TEST THE ACCURACY OF THE EIGEN COUPLETS.
!
    do_test = true
!
!   CHOOSE TUNING PARAMETERS FOR THE RANDOMIZED EVD ALGORITHM.
!
!   DETERMINE THE NUMBER OF POWER ITERATIONS niter TO BE PERFORMED.
!
    niter = 6_i4b
!
!   DETERMINE THE OVERSAMPLING SIZE p .
!
    p  = 20_i4b
!
!   CHECK VALIDITY OF THE OVERSAMPLING SIZE PARAMETER.
!
    np = min( p + neig, n )
!
!   SPECIFY IF ORTHONORMALIZATION IS CARRIED OUT BETWEEN EACH STEP
!   OF THE (POWER) SUBSPACE ITERATIONS, TO AVOID LOSS OF ACCURACY DUE
!   TO ROUNDING ERRORS. THIS IS NORMALLY NOT NEEDED FOR POSITIVE MATRIX.
!
    ortho = true
!
!   ALLOCATE WORK ARRAYS.
!
    i = max( np, neig0 )
!
    allocate( a(n,n), q(n,np), qt(np,n), b(n,np), v(np,np), eigvec(n,neig), &
              diagr(np), beta(i), eigval0(neig0), eigval(neig), stat=iok    )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-BY-n RANDOM REAL SYMMETRIC MATRIX a WITH
!   A SPECIFIED DISTRIBUTION OF EIGENVALUES.
!
!   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 EIGENVALUES.
!
    select case( mat_type )
!
        case( 1_i4b )
!
!           SLOW DECAY OF EIGENVALUES.
!
            do i = 1_i4b, neig0
!
                tmp = real( i, stnd )
!
                eigval0(i) = one/( tmp*tmp )
!        
            end do
!
        case( 2_i4b )
!
!           FAST DECAY OF EIGENVALUES.
!
            do i = 1_i4b, neig0
!
                tmp = real( i, stnd )
!
                eigval0(i) = exp( -tmp/seven )
!        
            end do
!
        case( 3_i4b )
!
!           S-SHAPED DECAY OF EIGENVALUES.
!
            do i = 1_i4b, neig0
!
                tmp = real( i, stnd )
!
                eigval0(i) = 0.0001_stnd + one/( one + exp( tmp -c30 ) )
!        
            end do
!
        case default
!
!           VERY SLOW DECAY OF EIGENVALUES.
!
            norma = real( neig0 - 1_i4b, stnd )
!
            do i = 1_i4b, neig0
!
                tmp = real( i - 1_i4b, stnd )
!
                eigval0(i) = exp( -tmp/norma )
!        
            end do
!
    end select
!  
!   CHANGE SIGN OF HALF OF THE EIGENVALUES.
!
    call random_number_( beta(:neig0) )
!
    where ( beta(:neig0)>half ) eigval0(:neig0) = -eigval0(:neig0)
!
!   SORT THE EIGENVALUES BY DECREASING ABSOLUTE MAGNITUDE.
!
    call eig_abs_sort( sort, eigval0(:neig0) )
!
!   GENERATE A SYMMETRIC MATRIX a WITH THE SPECIFIED EIGENVALUES
!   AND RANK neig0.
!
    call gen_random_sym_mat( eigval0(:neig0), a )
!
!   COMPUTE THE FROBENIUS NORM OF THE SYMMETRIC MATRIX.
!
!    norma = norm( a(:n,:n) )
    norma = sqrt(sum( eigval0(:neig0)**2 ) )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   GENERATE A n-BY-np IID GAUSSIAN MATRIX .
!
!   GENERATE A NORMAL RANDOM REAL MATRIX USING MATRIX
!   FORM OF SUBROUTINE normal_random_number3_.
!
!    call normal_random_number3_( b(:n,:np) )
!
!   GENERATE A NORMAL RANDOM REAL MATRIX USING VECTOR
!   FORM OF SUBROUTINE normal_random_number_.
!
    do i = 1_i4b, np
!
        call normal_random_number3_( b(:n,i) )
!
    end do
!
!   COMPUTE RANDOM SAMPLE MATRIX.
!
    q(:n,:np) = matmul( a(:n,:n), b(:n,:np) )
!
!   DO POWER ITERATIONS.
!
    do i = 1_i4b, niter
!
        if ( ortho ) then
!
!           COMPUTE QR DECOMPOSITION OF RANDOM SAMPLE MATRIX TO OBTAIN AN
!           ORTHONORMAL BASIS OF RANDOM SUBSPACE.
!
            call qr_cmp( q(:n,:np), diagr(:np), beta(:np) )
!
!           GENERATE ORTHOGONAL MATRIX q OF QR DECOMPOSITION OF RANDOM SAMPLE MATRIX.
!           q IS ASSUMED OF FULL RANK.
!
            call ortho_gen_qr( q(:n,:np), beta(:np) )
!
        end if
!
!       COMPUTE RANDOM SUBSPACE PROJECTION.
!
        b(:n,:np) = matmul( a(:n,:n), q(:n,:np)  )
!
        q(:n,:np) = b(:n,:np)
!
    end do
!
!   COMPUTE QR DECOMPOSITION OF RANDOM SAMPLE MATRIX TO OBTAIN AN
!   ORTHONORMAL BASIS OF RANDOM SUBSPACE.
!
    call qr_cmp( q(:n,:np), diagr(:np), beta(:np) )
!
!   GENERATE ORTHOGONAL MATRIX q OF QR DECOMPOSITION OF RANDOM SAMPLE MATRIX.
!   q IS ASSUMED OF FULL RANK.
!
    call ortho_gen_qr( q(:n,:np), beta(:np) )
!
!   COMPUTE FINAL RANDOM SUBSPACE PROJECTION.
!
    b(:n,:np) = matmul( a(:n,:n), q(:n,:np) )
!
!   COMPUTE v = q**(t)*b = q**(t)*a*q .
!
    qt(:np,:n) = transpose( q(:n,:np) )
!
    v(:np,:np) = matmul( qt(:np,:n), b(:n,:np) )
!
!   USE A SPECTRAL DECOMPOSITION.
!
    call eig_cmp( v(:np,:np), beta(:np), failure, maxiter=30_i4b )
!
    call eig_abs_sort( sort, beta(:np), v(:np,:np) )
!
!   COMPUTE THE APPROXIMATE TOP neig EIGENVECTORS OF a .
!
    eigvec(:n,:neig) = matmul( q(:n,:np), v(:np,:neig) )
!
!   EXTRACT THE APPROXIMATE TOP neig EIGENVALUES (IN ABSOLUTE MAGNITUDE) OF a .
!
    eigval(:neig) = beta(:neig)
!
!   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 )
!
!   COMPUTE THE ESTIMATED RELATIVE ERROR.
!
    tmp = one - sum( (eigval(1_i4b:neig)/norma)**2 )
    relerr = sqrt( max( tmp, zero ) )
!
!   COMPUTE THE TRUE RELATIVE ERROR.
!
    relerr2 = sqrt( sum( (eigval0(neig+1_i4b:neig0)/norma)**2 ) )
!
!   COMPUTE ERROR BETWEEN THE TRUE AND ESTIMATED RELATIVE ERRORS.
!
    err = abs( relerr - relerr2 )
!
!   TEST ACCURACY OF THE EIGEN COUPLETS IF REQUIRED.
!
    if ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*u(:n,:neig) - u(:n,:neig)*diag(eigval(:neig)),
!       WHERE u ARE THE EIGENVECTORS OF a.
!
        q(:n,:neig) = matmul(a,eigvec) - eigvec*spread(eigval(:neig),dim=1,ncopies=n)
        beta(:neig) = norm( q(:n,:neig), dim=2_i4b )
!
        err1 = maxval( beta(:neig) )/( norma*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u(:n,:neig)**(t)*u(:n,:neig).
!
        call unit_matrix( q(:neig,:neig) )
!
        v(:neig,:neig) = abs( q(:neig,:neig) - matmul( transpose(eigvec), eigvec ) )
!
        err2 = maxval( v(:neig,:neig) )/real(n,stnd)
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, q, qt, b, v, diagr, beta, eigval0, eigval, eigvec )
!
!   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
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing approximate ', neig, ' eigenvalues and eigenvectors of a ', &
       n, ' by ', n,' real symmetric matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_random_eig
! =============================
!
end program ex1_random_eig

ex1_random_eig_pos.F90

program ex1_random_eig_pos
!
!
! Purpose
! =======
!
!   This program illustrates how to compute an approximate eigenvalue decomposition
!   of a symmetric positive (semi-)definite matrix with randomized subspace iterations and/or
!   the Nystrom method using STATPACK.
!                                                                              
!                                                     
! Further Details
! ===============
!
!   The program also shows the use of subroutines SVD_CMP in module SVD_Procedures,
!   EIG_CMP in module EIG_Procedures, QR_CMP, ORTHO_GEN_QR in module QR_Procedures,
!   CHOL_CMP in module Lin_procedures, and NORMAL_RANDOM_NUMBER3_ and GEN_RANDOM_SYM_MAT
!   in module Random.
!                                                                              
! LATEST REVISION : 23/10/2020
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, one, seven, c30, merror, allocate_error, &
                         norm, unit_matrix, random_seed_, normal_random_number3_, chol_cmp,          &
                         eigval_sort, eig_abs_sort, qr_cmp, ortho_gen_qr, svd_cmp, eig_cmp,          &
                         gen_random_sym_mat
!
#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, neig IS THE TARGET RANK OF THE APPROXIMATE PARTIAL EVD DECOMPOSITION,
! neig0 IS THE RANK OF THE GENERATED MATRIX,
! n IS THE DIMENSION OF THE GENERATED SYMMETRIC POSITIVE SEMI-DEFINITE MATRIX.
!
    integer(i4b), parameter :: prtunit=6, n=1000, neig=5, neig0=1000
!
    character(len=*), parameter :: name_proc='Example 1 of random_eig_pos'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd) :: d1, err, err1, err2, eps, elapsed_time, norma, tmp, relerr, relerr2
    real(stnd), dimension(:,:), allocatable :: a, q, qt, b, v, eigvec
    real(stnd), dimension(:),   allocatable :: diagr, beta, eigval, eigval0
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: p, np, i, j, niter, mat_type
!
    logical(lgl) :: failure, do_test, ortho, use_nystrom
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : PARTIAL EIGENVALUE DECOMPOSITION OF A n-BY-n REAL SYMMETRIC POSITIVE
!               SEMI-DEFINITE MATRIX USING RANDOMIZED POWER SUBSPACE OR BLOCK KRYLOV
!               ITERATIONS AND THE NYSTROM METHOD.
!
!   SPECIFY THE TYPE OF INPUT MATRIX:
!
!   mat_type = 1  -> SLOW DECAY OF EIGENVALUES
!   mat_type = 2  -> FAST DECAY OF EIGENVALUES
!   mat_type = 3  -> S-SHAPED DECAY OF EIGENVALUES
!   mat_type > 3  -> VERY SLOW DECAY OF EIGENVALUES
!
    mat_type = 2_i4b
!
!   SET TOLERANCE FOR THE ERROR OF THE RELATIVE ERROR IN FROBENIUS NORM
!   OF THE COMPUTED PARTIAL EVD.
!
    eps = 0.001_stnd
!
!   SPECIFY IF NUMERICAL TESTS ARE PERFORMED TO TEST THE ACCURACY OF THE EIGEN COUPLETS.
!
    do_test = true
!
!   CHOOSE TUNING PARAMETERS FOR THE RANDOMIZED EVD ALGORITHM.
!
!   DETERMINE THE NUMBER OF POWER ITERATIONS niter TO BE PERFORMED.
!
    niter = 6_i4b
!
!   DETERMINE THE OVERSAMPLING SIZE p .
!
    p = 20_i4b
!
!   CHECK VALIDITY OF THE OVERSAMPLING SIZE PARAMETER.
!
    np = min( p + neig, n )
!
!   SPECIFY IF ORTHONORMALIZATION IS CARRIED OUT BETWEEN EACH STEP
!   OF THE (POWER) SUBSPACE ITERATIONS, TO AVOID LOSS OF ACCURACY DUE
!   TO ROUNDING ERRORS. THIS IS NORMALLY NOT NEEDED FOR POSITIVE MATRIX.
!
    ortho = true
!
!   SPECIFY IF LAST STEP OF THE ALGORITHM IS PERFORMED WITH THE NYSTROM METHOD (AND A SVD)
!   OR AN EIGENVALUE DECOMPOSITION.
!
    use_nystrom = true
!
    d1 = one
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), q(n,np), qt(np,n), b(n,np), v(np,np), diagr(np),         &
              beta(np), eigval0(neig0), eigval(neig), eigvec(n,neig), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-BY-n RANDOM REAL SYMMETRIC POSITIVE SEMI-DEFINITE MATRIX a WITH A
!   SPECIFIED DISTRIBUTION OF EIGENVALUES.
!
!   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 EIGENVALUES.
!
    select case( mat_type )
!
        case( 1_i4b )
!
!           SLOW DECAY OF EIGENVALUES.
!
            do i = 1_i4b, neig0
!
                tmp = real( i, stnd )
!
                eigval0(i) = one/( tmp*tmp )
!        
            end do
!
        case( 2_i4b )
!
!           FAST DECAY OF EIGENVALUES.
!
            do i = 1_i4b, neig0
!
                tmp = real( i, stnd )
!
                eigval0(i) = exp( -tmp/seven )
!        
            end do
!
        case( 3_i4b )
!
!           S-SHAPED DECAY OF EIGENVALUES.
!
            do i = 1_i4b, neig0
!
                tmp = real( i, stnd )
!
                eigval0(i) = 0.0001_stnd + one/( one + exp( tmp -c30 ) )
!        
            end do
!
        case default
!
!           VERY SLOW DECAY OF EIGENVALUES.
!
            norma = real( neig0 - 1_i4b, stnd )
!
            do i = 1_i4b, neig0
!
                tmp = real( i - 1_i4b, stnd )
!
                eigval0(i) = exp( -tmp/norma )
!        
            end do
!
    end select
!
!   SORT THE EIGENVALUES BY DECREASING MAGNITUDE.
!
    call eigval_sort( sort, eigval0(:neig0) )
!
!   GENERATE A SYMMETRIC POSITIVE SEMI-DEFINITE MATRIX a WITH THE SPECIFIED EIGENVALUES
!   AND RANK neig0.
!
    call gen_random_sym_mat( eigval0(:neig0), a )
!
!   COMPUTE THE FROBENIUS NORM OF THE SYMMETRIC POSITIVE SEMI-DEFINITE MATRIX.
!
!    norma = norm( a(:n,:n) )
    norma = sqrt(sum( eigval0(:neig0)**2 ) )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   GENERATE A n-BY-np IID GAUSSIAN MATRIX .
!
!   GENERATE A NORMAL RANDOM REAL MATRIX USING MATRIX
!   FORM OF SUBROUTINE normal_random_number3_.
!
!    call normal_random_number3_( b(:n,:np) )
!
!   GENERATE A NORMAL RANDOM REAL MATRIX USING VECTOR
!   FORM OF SUBROUTINE normal_random_number_.
!
    do i = 1_i4b, np
!
        call normal_random_number3_( b(:n,i) )
!
    end do
!
!   COMPUTE RANDOM SAMPLE MATRIX.
!
    q(:n,:np) = matmul( a(:n,:n), b(:n,:np) )
!
!   DO POWER ITERATIONS.
!
    do i = 1_i4b, niter
!
        if ( ortho ) then
!
!           COMPUTE QR DECOMPOSITION OF RANDOM SAMPLE MATRIX TO OBTAIN AN
!           ORTHONORMAL BASIS OF RANDOM SUBSPACE.
!
            call qr_cmp( q(:n,:np), diagr(:np), beta(:np) )
!
!           GENERATE ORTHOGONAL MATRIX q OF QR DECOMPOSITION OF RANDOM SAMPLE MATRIX.
!           q IS ASSUMED OF FULL RANK.
!
            call ortho_gen_qr( q(:n,:np), beta(:np) )
!
        end if
!
!       COMPUTE RANDOM SUBSPACE PROJECTION.
!
        b(:n,:np) = matmul( a(:n,:n), q(:n,:np) )
!
        q(:n,:np) = b(:n,:np)
!
    end do
!
!   COMPUTE QR DECOMPOSITION OF RANDOM SAMPLE MATRIX TO OBTAIN AN
!   ORTHONORMAL BASIS OF RANDOM SUBSPACE.
!
    call qr_cmp( q(:n,:np), diagr(:np), beta(:np) )
!
!   GENERATE ORTHOGONAL MATRIX q OF QR DECOMPOSITION OF RANDOM SAMPLE MATRIX.
!   q IS ASSUMED OF FULL RANK.
!
    call ortho_gen_qr( q(:n,:np), beta(:np) )
!
!   COMPUTE b = a*q AND v = q**(t)*b .
!
    b(:n,:np) = matmul( a(:n,:n), q(:n,:np) )
!
    qt(:np,:n) = transpose( q(:n,:np) )
!
    v(:np,:np) = matmul( qt(:np,:n), b(:n,:np) )
!
    if ( use_nystrom ) then
!
!       USE THE NYSTROM METHOD.
!
!       SAVE v IF CHOLESKY FACTORIZATION FAILS.
!
        qt(:np,:np) = v(:np,:np)    
!
!       COMPUTE CHOLESKY FACTORIZATION OF v = c**(t)*c .
!
        call chol_cmp( v(:np,:np), diagr(:np), d1 )
!
    else
!
!       USE AN EVD DECOMPOSITION AS A BACKUP.
!
        d1 = zero
!
    end if
!
    if ( d1/=zero ) then
!
!       USE THE NYSTROM METHOD.
!
!       COMPUTE F = b*c**(-1) USING A TRIANGULAR SOLVE.
!
        qt(:np,:n) = transpose( b(:n,:np) )    
!
        do i = 1_i4b, n
!
            do j = 1_i4b, np
!
                qt(j,i) = ( qt(j,i) - dot_product( v(1_i4b:j-1_i4b,j), qt(1_i4b:j-1_i4b,i) ) )*diagr(j)
!
            end do
!
        end do
!
        b(:n,:np) = transpose( qt(:np,:n) )    
!
!       COMPUTE SVD OF THE CHOLESKY FACTOR.
!
        call svd_cmp( b(:n,:np), beta(:np), failure, v=v(:np,:np), sort=sort, max_francis_steps=10_i4b )
!
!       EXTRACT THE APPROXIMATE TOP neig EIGENVECTORS OF a .
!
        eigvec(:n,:neig) = b(:n,:neig)
!
!       COMPUTE THE APPROXIMATE TOP neig EIGENVALUES OF a .
!
        eigval(:neig) = beta(:neig)*beta(:neig)
!
    else
!
        if ( use_nystrom ) then
!
!           RESTORE v AS CHOLESKY FACTORIZATION FAILED.
!
            v(:np,:np) = qt(:np,:np) 
!
        end if
!
!       USE A STANDARD SPECTRAL DECOMPOSITION.
!
        call eig_cmp( v(:np,:np), beta(:np), failure, sort=sort, maxiter=30_i4b )
!
        call eig_abs_sort( sort, beta(:np), v(:np,:np) )
!
!       COMPUTE THE APPROXIMATE TOP neig EIGENVECTORS OF a .
!
        eigvec(:n,:neig) = matmul( q(:n,:np), v(:np,:neig) )
!
!       EXTRACT THE APPROXIMATE TOP neig EIGENVALUES OF a .
!
        eigval(:neig) = beta(:neig)
!
    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 )
!
!   COMPUTE THE ESTIMATED RELATIVE ERROR.
!
    tmp = one - sum( (eigval(1_i4b:neig)/norma)**2 )
    relerr = sqrt( max( tmp, zero ) )
!
!   COMPUTE THE TRUE RELATIVE ERROR.
!
    relerr2 = sqrt( sum( (eigval0(neig+1_i4b:neig0)/norma)**2 ) )
!
!   COMPUTE ERROR BETWEEN THE TRUE AND ESTIMATED RELATIVE ERRORS.
!
    err = abs( relerr - relerr2 )
!
!   TEST ACCURACY OF THE EIGEN COUPLETS IF REQUIRED.
!
    if ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*u(:n,:neig) - u(:n,:neig)*diag(eigval(:neig)),
!       WHERE u ARE THE EIGENVECTORS OF a.
!
        q(:n,:neig) = matmul(a,eigvec) - eigvec*spread(eigval(:neig),dim=1,ncopies=n)
        beta(:neig) = norm( q(:n,:neig), dim=2_i4b )
!
        err1 = maxval( beta(:neig) )/( norma*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u(:n,:neig)**(t)*u(:n,:neig).
!
        call unit_matrix( q(:neig,:neig) )
!
        v(:neig,:neig) = abs( q(:neig,:neig) - matmul( transpose(eigvec), eigvec ) )
!
        err2 = maxval( v(:neig,:neig) )/real(n,stnd)
!
        err = max( err1, err2 )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, q, qt, b, v, diagr, beta, eigval0, eigval, eigvec )
!
!   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
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing approximate ', neig, ' eigenvalues and eigenvectors of a ', &
       n, ' by ', n,' real symmetric positive semi-definite matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_random_eig_pos
! =================================
!
end program ex1_random_eig_pos

ex1_random_eig_pos_with_blas.F90

program ex1_random_eig_pos_with_blas
!
!
! Purpose
! =======
!
!   This program illustrates how to compute an approximate eigenvalue decomposition
!   of a symmetric positive (semi-)definite matrix with randomized subspace iterations and/or
!   the Nystrom method using STATPACK and BLAS subroutines.
!                                                                              
!                                                     
! Further Details
! ===============
!
!   The program shows the use of subroutines SVD_CMP in module SVD_Procedures,
!   EIG_CMP in module Eig_Procedures, QR_CMP, ORTHO_GEN_QR in module QR_Procedures,
!   CHOL_CMP in module Lin_procedures, and NORMAL_RANDOM_NUMBER3_ and GEN_RANDOM_SYM_MAT
!   in module Random and gemm, symm, syrk generic interfaces in module BLAS_interfaces.
!                                                                              
! LATEST REVISION : 23/10/2020
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, one, seven, c30, merror, allocate_error, &
                         norm, unit_matrix, random_seed_, normal_random_number3_, chol_cmp,          &
                         eigval_sort, eig_abs_sort, qr_cmp, ortho_gen_qr, svd_cmp, eig_cmp,          &
                         gen_random_sym_mat
!
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
#ifdef _TRANSPOSE
    use Statpack, only : transpose=>transpose2
#endif
#ifdef _BLAS
!    use BLAS_interfaces, only : gemm
    use BLAS_interfaces, only : symm, syrk, gemm
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT, neig IS THE TARGET RANK OF THE APPROXIMATE PARTIAL EVD DECOMPOSITION,
! neig0 IS THE RANK OF THE GENERATED MATRIX,
! n IS THE DIMENSION OF THE GENERATED SYMMETRIC POSITIVE SEMI-DEFINITE MATRIX.
!
    integer(i4b), parameter :: prtunit=6, n=2000, neig=5, neig0=1000
!
    character(len=*), parameter :: name_proc='Example 1 of random_eig_pos_with_blas'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd) :: d1, err, err1, err2, eps, elapsed_time, norma, tmp, relerr, relerr2
#ifdef _BLAS
    real(stnd), dimension(:,:), allocatable :: a, q, b, bt, v, eigvec
#else
    real(stnd), dimension(:,:), allocatable :: a, q, qt, b, bt, v, eigvec
#endif
    real(stnd), dimension(:),   allocatable :: diagr, beta, eigval, eigval0
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: p, np, i, j, niter, mat_type
!
    logical(lgl) :: failure, do_test, ortho, use_nystrom
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : PARTIAL EIGENVALUE DECOMPOSITION OF A n-BY-n REAL SYMMETRIC POSITIVE
!               SEMI-DEFINITE MATRIX USING RANDOMIZED POWER SUBSPACE OR BLOCK KRYLOV
!               ITERATIONS AND THE NYSTROM METHOD.
!
!   SPECIFY THE TYPE OF INPUT MATRIX:
!
!   mat_type = 1  -> SLOW DECAY OF EIGENVALUES
!   mat_type = 2  -> FAST DECAY OF EIGENVALUES
!   mat_type = 3  -> S-SHAPED DECAY OF EIGENVALUES
!   mat_type > 3  -> VERY SLOW DECAY OF EIGENVALUES
!
    mat_type = 2_i4b
!
!   SET TOLERANCE FOR THE ERROR OF THE RELATIVE ERROR IN FROBENIUS NORM
!   OF THE COMPUTED PARTIAL EVD.
!
    eps = 0.001_stnd
!
!   SPECIFY IF NUMERICAL TESTS ARE PERFORMED TO TEST THE ACCURACY OF THE EIGEN COUPLETS.
!
    do_test = true
!
!   CHOOSE TUNING PARAMETERS FOR THE RANDOMIZED EVD ALGORITHM.
!
!   DETERMINE THE NUMBER OF POWER ITERATIONS niter TO BE PERFORMED.
!
    niter = 6_i4b
!
!   DETERMINE THE OVERSAMPLING SIZE p .
!
    p  = 20_i4b
!
!   CHECK VALIDITY OF THE OVERSAMPLING SIZE PARAMETER.
!
    np = min( p + neig, n )
!
!   SPECIFY IF ORTHONORMALIZATION IS CARRIED OUT BETWEEN EACH STEP
!   OF THE (POWER) SUBSPACE ITERATIONS, TO AVOID LOSS OF ACCURACY DUE
!   TO ROUNDING ERRORS. THIS IS NORMALLY NOT NEEDED FOR POSITIVE MATRIX.
!
    ortho = false
!
!   SPECIFY IF LAST STEP OF THE ALGORITHM IS PERFORMED WITH THE NYSTROM METHOD (AND A SVD)
!   OR AN EIGENVALUE DECOMPOSITION.
!
    use_nystrom = true
!
    d1 = one
!
!   ALLOCATE WORK ARRAYS.
!
#ifdef _BLAS
    allocate( a(n,n), q(n,np), b(n,np), v(np,np), diagr(np),                    &
              beta(np),  eigval0(neig0), eigval(neig), eigvec(n,neig), stat=iok )
#else
    allocate( a(n,n), q(n,np), qt(np,n), b(n,np), v(np,np), diagr(np),          &
              beta(np),  eigval0(neig0), eigval(neig), eigvec(n,neig), stat=iok )
#endif
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-BY-n RANDOM REAL SYMMETRIC POSITIVE SEMI-DEFINITE MATRIX a WITH A
!   SPECIFIED DISTRIBUTION OF EIGENVALUES.
!
!   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 EIGENVALUES.
!
    select case( mat_type )
!
        case( 1_i4b )
!
!           SLOW DECAY OF EIGENVALUES.
!
            do i = 1_i4b, neig0
!
                tmp = real( i, stnd )
!
                eigval0(i) = one/( tmp*tmp )
!        
            end do
!
        case( 2_i4b )
!
!           FAST DECAY OF EIGENVALUES.
!
            do i = 1_i4b, neig0
!
                tmp = real( i, stnd )
!
                eigval0(i) = exp( -tmp/seven )
!        
            end do
!
        case( 3_i4b )
!
!           S-SHAPED DECAY OF EIGENVALUES.
!
            do i = 1_i4b, neig0
!
                tmp = real( i, stnd )
!
                eigval0(i) = 0.0001_stnd + one/( one + exp( tmp -c30 ) )
!        
            end do
!
        case default
!
!           VERY SLOW DECAY OF EIGENVALUES.
!
            norma = real( neig0 - 1_i4b, stnd )
!
            do i = 1_i4b, neig0
!
                tmp = real( i - 1_i4b, stnd )
!
                eigval0(i) = exp( -tmp/norma )
!        
            end do
!
    end select
!
!   SORT THE EIGENVALUES BY DECREASING MAGNITUDE.
!
    call eigval_sort( sort, eigval0(:neig0) )
!
!   GENERATE A SYMMETRIC POSITIVE SEMI-DEFINITE MATRIX a WITH THE SPECIFIED EIGENVALUES
!   AND RANK neig0.
!
    call gen_random_sym_mat( eigval0(:neig0), a )
!
!   COMPUTE THE FROBENIUS NORM OF THE SYMMETRIC POSITIVE SEMI-DEFINITE MATRIX.
!
!    norma = norm( a(:n,:n) )
    norma = sqrt(sum( eigval0(:neig0)**2 ) )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   GENERATE A n-BY-np IID GAUSSIAN MATRIX .
!
!   GENERATE A NORMAL RANDOM REAL MATRIX USING MATRIX
!   FORM OF SUBROUTINE normal_random_number3_.
!
!    call normal_random_number3_( b(:n,:np) )
!
!   GENERATE A NORMAL RANDOM REAL MATRIX USING VECTOR
!   FORM OF SUBROUTINE normal_random_number_.
!
    do i = 1_i4b, np
!
        call normal_random_number3_( b(:n,i) )
!
    end do
!
!   COMPUTE RANDOM SAMPLE MATRIX.
!
#ifdef _BLAS
!    call gemm( 'N', 'N', n, np, n, one, a(1_i4b:n,1_i4b:n), n,       &
!               b(1_i4b:n,1_i4b:np), n, zero, q(1_i4b:n,1_i4b:np), n  )
    call symm( 'L', 'U', n, np, one, a(1_i4b:n,1_i4b:n), n,          &
               b(1_i4b:n,1_i4b:np), n, zero, q(1_i4b:n,1_i4b:np), n  )
#else
    q(:n,:np) = matmul( a(:n,:n), b(:n,:np) )
#endif
!
!   DO POWER ITERATIONS.
!
    do i = 1_i4b, niter
!
        if ( ortho ) then
!
!           COMPUTE QR DECOMPOSITION OF RANDOM SAMPLE MATRIX TO OBTAIN AN
!           ORTHONORMAL BASIS OF RANDOM SUBSPACE.
!
            call qr_cmp( q(:n,:np), diagr(:np), beta(:np) )
!
!           GENERATE ORTHOGONAL MATRIX q OF QR DECOMPOSITION OF RANDOM SAMPLE MATRIX.
!           q IS ASSUMED OF FULL RANK.
!
            call ortho_gen_qr( q(:n,:np), beta(:np) )
!
        end if
!
!       COMPUTE RANDOM SUBSPACE PROJECTION.
!
#ifdef _BLAS
!        call gemm( 'N', 'N', n, np, n, one, a(1_i4b:n,1_i4b:n), n,       &
!                   q(1_i4b:n,1_i4b:np), n, zero, b(1_i4b:n,1_i4b:np), n  )
        call symm( 'L', 'U', n, np, one, a(1_i4b:n,1_i4b:n), n,          &
                   q(1_i4b:n,1_i4b:np), n, zero, b(1_i4b:n,1_i4b:np), n  )
#else
        b(:n,:np) = matmul( a(:n,:n), q(:n,:np)  )
#endif
!
        q(:n,:np) = b(:n,:np)
!
    end do
!
!   COMPUTE QR DECOMPOSITION OF RANDOM SAMPLE MATRIX TO OBTAIN AN
!   ORTHONORMAL BASIS OF RANDOM SUBSPACE.
!
    call qr_cmp( q(:n,:np), diagr(:np), beta(:np) )
!
!   GENERATE ORTHOGONAL MATRIX q OF QR DECOMPOSITION OF RANDOM SAMPLE MATRIX.
!   q IS ASSUMED OF FULL RANK.
!
    call ortho_gen_qr( q(:n,:np), beta(:np) )
!
!   COMPUTE b = a*q AND v = q**(t)*b .
!
#ifdef _BLAS
!    call gemm( 'N', 'N', n, np, n, one, a(1_i4b:n,1_i4b:n), n,       &
!               q(1_i4b:n,1_i4b:np), n, zero, b(1_i4b:n,1_i4b:np), n  )
    call symm( 'L', 'U', n, np, one, a(1_i4b:n,1_i4b:n), n,          &
               q(1_i4b:n,1_i4b:np), n, zero, b(1_i4b:n,1_i4b:np), n  )
!
     call gemm( 'T', 'N', np, np, n, one, q(1_i4b:n,1_i4b:np), n,       &
                b(1_i4b:n,1_i4b:np), n, zero, v(1_i4b:np,1_i4b:np), np  )
#else
    b(:n,:np) = matmul( a(:n,:n), q(:n,:np)  )
!
    qt(:np,:n) = transpose( q(:n,:np) )
!
    v(:np,:np) = matmul( qt(:np,:n), b(:n,:np) )
#endif
!
    if ( use_nystrom ) then
!
!       USE THE NYSTROM METHOD.
!
!       ALLOCATE WORK ARRAY.
!
        allocate( bt(np,n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       SAVE v IF CHOLESKY FACTORIZATION FAILS.
!
        bt(:np,:np) = v(:np,:np)   
!
!       COMPUTE CHOLESKY FACTORIZATION OF v = c**(t)*c .
!
        call chol_cmp( v(:np,:np), diagr(:np), d1 )
!
    else
!
!       USE AN EVD DECOMPOSITION AS A BACKUP.
!
        d1 = zero
!
    end if
!
    if ( d1/=zero ) then
!
!       USE THE NYSTROM METHOD.
!
!       COMPUTE F = b*c**(-1) USING A TRIANGULAR SOLVE.
!
        bt(:np,:n) = transpose( b(:n,:np) )    
!
        do i = 1_i4b, n
!
            do j = 1_i4b, np
!
                bt(j,i) = ( bt(j,i) - dot_product( v(1_i4b:j-1_i4b,j), bt(1_i4b:j-1_i4b,i) ) )*diagr(j)
!
            end do
!
        end do
!
        b(:n,:np) = transpose( bt(:np,:n) )    
!
!       COMPUTE SVD OF THE CHOLESKY FACTOR.
!
        call svd_cmp( b(:n,:np), beta(:np), failure, v=v(:np,:np), sort=sort, max_francis_steps=10_i4b )
!
!       EXTRACT THE APPROXIMATE TOP neig EIGENVECTORS OF a .
!
        eigvec(:n,:neig) = b(:n,:neig)
!
!       COMPUTE THE APPROXIMATE TOP neig EIGENVALUES OF a .
!
        eigval(:neig) = beta(:neig)*beta(:neig)
!
!       DEALLOCATE WORK ARRAY.
!
        deallocate( bt )
!
    else
!
        if ( use_nystrom ) then
!
!           RESTORE v AS CHOLESKY FACTORIZATION FAILED.
!
            v(:np,:np) = bt(:np,:np)    
!
!           DEALLOCATE WORK ARRAY.
!
            deallocate( bt )
!
        end if
!
!       USE A STANDARD SPECTRAL DECOMPOSITION.
!
        call eig_cmp( v(:np,:np), beta(:np), failure, sort=sort, maxiter=30_i4b )
!
        call eig_abs_sort( sort, beta(:np), v(:np,:np) )
!
!       COMPUTE THE APPROXIMATE TOP neig EIGENVECTORS OF a .
!!
#ifdef _BLAS
        call gemm( 'N', 'N', n, neig, np, one, q(1_i4b:n,1_i4b:np), n,              &
                   v(1_i4b:np,1_i4b:neig), np, zero, eigvec(1_i4b:n,1_i4b:neig), n  )
#else
        eigvec(:n,:neig) = matmul( q(:n,:np), v(:np,:neig) )
#endif
!
!       EXTRACT THE APPROXIMATE TOP neig EIGENVALUES OF a .
!
        eigval(:neig) = beta(:neig)
!
    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 )
!
!   COMPUTE THE ESTIMATED RELATIVE ERROR.
!
    tmp = one - sum( (eigval(1_i4b:neig)/norma)**2 )
    relerr = sqrt( max( tmp, zero ) )
!
!   COMPUTE THE TRUE RELATIVE ERROR.
!
    relerr2 = sqrt( sum( (eigval0(neig+1_i4b:neig0)/norma)**2 ) )
!
!   COMPUTE ERROR BETWEEN THE TRUE AND ESTIMATED RELATIVE ERRORS.
!
    err = abs( relerr - relerr2 )
!
!   TEST ACCURACY OF THE EIGEN COUPLETS IF REQUIRED.
!
    if ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*u(:n,:neig) - u(:n,:neig)*diag(eigval(:neig)),
!       WHERE u ARE THE EIGENVECTORS OF a.
!
        q(:n,:neig) = eigvec(:n,:neig)*spread(eigval(:neig),dim=1,ncopies=n)
!
#ifdef _BLAS
!        call gemm( 'N', 'N', n, neig, n, one, a(1_i4b:n,1_i4b:n), n,              &
!                   eigvec(1_i4b:n,1_i4b:neig), n, -one, q(1_i4b:n,1_i4b:neig), n  )
       call symm( 'L', 'U', n, neig, one, a(1_i4b:n,1_i4b:n), n,                  &
                   eigvec(1_i4b:n,1_i4b:neig), n, -one, q(1_i4b:n,1_i4b:neig), n  )
#else
        q(:n,:neig) = matmul( a(:n,:n), eigvec(:n,:neig)  ) - q(:n,:neig)
#endif
!
        beta(:neig) = norm( q(:n,:neig), dim=2_i4b )
!
        err1 = maxval( beta(:neig) )/( norma*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u(:n,:neig)**(t)*u(:n,:neig).
!
        call unit_matrix( q(:neig,:neig) )
!
        v(:neig,:neig) = abs( q(:neig,:neig) - matmul( transpose(eigvec), eigvec ) )
!
        err2 = maxval( v(:neig,:neig) )/real(n,stnd)
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
#ifdef _BLAS
    deallocate( a, q, b, v, diagr, beta, eigval0, eigval, eigvec )
#else
    deallocate( a, q, qt, b, v, diagr, beta, eigval0, eigval, eigvec )
#endif
!
!   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
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing approximate ', neig, ' eigenvalues and eigenvectors of a ', &
       n, ' by ', n,' real symmetric positive semi-definite matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_random_eig_pos_with_blas
! ===========================================
!
end program ex1_random_eig_pos_with_blas

ex1_random_eig_with_blas.F90

program ex1_random_eig_with_blas
!
!
! Purpose
! =======
!
!   This program illustrates how to compute an approximate partial EigenValue
!   Decomposition (EVD) of a symmetric matrix with randomized power subspace iterations
!   using STATPACK and BLAS subroutines.
!                                                                              
!                                                     
! Further Details
! ===============
!
!   The program also shows the use of subroutines QR_CMP, ORTHO_GEN_QR in module QR_Procedures,
!   EIG_CMP in module Eig_procedures, NORMAL_RANDOM_NUMBER3_ and GEN_RANDOM_SYM_MAT in module
!   Random, and gemm, symm, syrk generic interfaces in module BLAS_interfaces.
!                                                                              
! LATEST REVISION : 23/10/2020
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, half, one, seven, c30, merror, allocate_error, &
                         norm, unit_matrix, random_seed_, random_number_, normal_random_number3_,          &
                         eig_abs_sort, qr_cmp, ortho_gen_qr, eig_cmp, gen_random_sym_mat
!
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
#ifdef _TRANSPOSE
    use Statpack, only : transpose=>transpose2
#endif
#ifdef _BLAS
!    use BLAS_interfaces, only : gemm
    use BLAS_interfaces, only : symm, syrk, gemm
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT, neig IS THE TARGET RANK OF THE APPROXIMATE PARTIAL EVD DECOMPOSITION,
! neig0 IS THE RANK OF THE GENERATED MATRIX,
! n IS THE DIMENSION OF THE GENERATED SYMMETRIC MATRIX.
!
    integer(i4b), parameter :: prtunit=6, n=2000, neig=5, neig0=1000
!
    character(len=*), parameter :: name_proc='Example 1 of random_eig_with_blas'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd) :: err, err1, err2, eps, elapsed_time, tmp, norma, relerr, relerr2
#ifdef _BLAS
    real(stnd), dimension(:,:), allocatable :: a, q, b, eigvec, v
#else
    real(stnd), dimension(:,:), allocatable :: a, q, qt, b, eigvec, v
#endif
    real(stnd), dimension(:),   allocatable :: diagr, beta, eigval0, eigval
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: p, np, i, niter, mat_type
!
    logical(lgl) :: failure, do_test, ortho
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : PARTIAL EIGENVALUE DECOMPOSITION OF A n-BY-n REAL SYMMETRIC
!               MATRIX USING RANDOMIZED POWER SUBSPACE OR BLOCK KRYLOV ITERATIONS.
!
!   SPECIFY THE TYPE OF INPUT MATRIX:
!
!   mat_type = 1  -> SLOW DECAY OF EIGENVALUES      (IN ABSOLUTE MAGNITUDE)
!   mat_type = 2  -> FAST DECAY OF EIGENVALUES      (IN ABSOLUTE MAGNITUDE)
!   mat_type = 3  -> S-SHAPED DECAY OF EIGENVALUES  (IN ABSOLUTE MAGNITUDE)
!   mat_type > 3  -> VERY SLOW DECAY OF EIGENVALUES (IN ABSOLUTE MAGNITUDE)
!
    mat_type = 2_i4b
!
!   SET TOLERANCE FOR THE ERROR OF THE RELATIVE ERROR IN FROBENIUS NORM
!   OF THE COMPUTED PARTIAL EVD.
!
    eps = 0.001_stnd
!
!   SPECIFY IF NUMERICAL TESTS ARE PERFORMED TO TEST THE ACCURACY OF THE EIGEN COUPLETS.
!
    do_test = true
!
!   CHOOSE TUNING PARAMETERS FOR THE RANDOMIZED EVD ALGORITHM.
!
!   DETERMINE THE NUMBER OF POWER ITERATIONS niter TO BE PERFORMED.
!
    niter = 6_i4b
!
!   DETERMINE THE OVERSAMPLING SIZE p .
!
    p  = 20_i4b
!
!   CHECK VALIDITY OF THE OVERSAMPLING SIZE PARAMETER.
!
    np = min( p + neig, n )
!
!   SPECIFY IF ORTHONORMALIZATION IS CARRIED OUT BETWEEN EACH STEP
!   OF THE (POWER) SUBSPACE ITERATIONS, TO AVOID LOSS OF ACCURACY DUE
!   TO ROUNDING ERRORS. THIS IS NORMALLY NOT NEEDED FOR POSITIVE MATRIX.
!
    ortho = true
!
!   ALLOCATE WORK ARRAYS.
!
    i = max( np, neig0 )
!
#ifdef _BLAS
    allocate( a(n,n), q(n,np), b(n,np), v(np,np), eigvec(n,neig),         &
              diagr(np), beta(i), eigval0(neig0), eigval(neig), stat=iok  )
#else
    allocate( a(n,n), q(n,np), qt(np,n), b(n,np), v(np,np), eigvec(n,neig), &
              diagr(np), beta(i), eigval0(neig0), eigval(neig), stat=iok    )
#endif
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-BY-n RANDOM REAL SYMMETRIC MATRIX a WITH
!   A SPECIFIED DISTRIBUTION OF EIGENVALUES.
!
!   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 EIGENVALUES.
!
    select case( mat_type )
!
        case( 1_i4b )
!
!           SLOW DECAY OF EIGENVALUES.
!
            do i = 1_i4b, neig0
!
                tmp = real( i, stnd )
!
                eigval0(i) = one/( tmp*tmp )
!        
            end do
!
        case( 2_i4b )
!
!           FAST DECAY OF EIGENVALUES.
!
            do i = 1_i4b, neig0
!
                tmp = real( i, stnd )
!
                eigval0(i) = exp( -tmp/seven )
!        
            end do
!
        case( 3_i4b )
!
!           S-SHAPED DECAY OF EIGENVALUES.
!
            do i = 1_i4b, neig0
!
                tmp = real( i, stnd )
!
                eigval0(i) = 0.0001_stnd + one/( one + exp( tmp -c30 ) )
!        
            end do
!
        case default
!
!           VERY SLOW DECAY OF EIGENVALUES.
!
            norma = real( neig0 - 1_i4b, stnd )
!
            do i = 1_i4b, neig0
!
                tmp = real( i - 1_i4b, stnd )
!
                eigval0(i) = exp( -tmp/norma )
!        
            end do
!
    end select
!  
!   CHANGE SIGN OF HALF OF THE EIGENVALUES.
!
    call random_number_( beta(:neig0) )
!
    where ( beta(:neig0)>half ) eigval0(:neig0) = -eigval0(:neig0)
!
!   SORT THE EIGENVALUES BY DECREASING ABSOLUTE MAGNITUDE.
!
    call eig_abs_sort( sort, eigval0(:neig0) )
!
!   GENERATE A SYMMETRIC MATRIX a WITH THE SPECIFIED EIGENVALUES
!   AND RANK neig0.
!
    call gen_random_sym_mat( eigval0(:neig0), a )
!
!   COMPUTE THE FROBENIUS NORM OF THE SYMMETRIC MATRIX.
!
!    norma = norm( a(:n,:n) )
    norma = sqrt(sum( eigval0(:neig0)**2 ) )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   GENERATE A n-BY-np IID GAUSSIAN MATRIX .
!
!   GENERATE A NORMAL RANDOM REAL MATRIX USING MATRIX
!   FORM OF SUBROUTINE normal_random_number3_.
!
!    call normal_random_number3_( b(:n,:np) )
!
!   GENERATE A NORMAL RANDOM REAL MATRIX USING VECTOR
!   FORM OF SUBROUTINE normal_random_number_.
!
    do i = 1_i4b, np
!
        call normal_random_number3_( b(:n,i) )
!
    end do
!
!   COMPUTE RANDOM SAMPLE MATRIX.
!
#ifdef _BLAS
!    call gemm( 'N', 'N', n, np, n, one, a(1_i4b:n,1_i4b:n), n,       &
!               b(1_i4b:n,1_i4b:np), n, zero, q(1_i4b:n,1_i4b:np), n  )
    call symm( 'L', 'U', n, np, one, a(1_i4b:n,1_i4b:n), n,          &
               b(1_i4b:n,1_i4b:np), n, zero, q(1_i4b:n,1_i4b:np), n  )
#else
    q(:n,:np) = matmul( a(:n,:n), b(:n,:np) )
#endif
!
!   DO POWER ITERATIONS.
!
    do i = 1_i4b, niter
!
        if ( ortho ) then
!
!           COMPUTE QR DECOMPOSITION OF RANDOM SAMPLE MATRIX TO OBTAIN AN
!           ORTHONORMAL BASIS OF RANDOM SUBSPACE.
!
            call qr_cmp( q(:n,:np), diagr(:np), beta(:np) )
!
!           GENERATE ORTHOGONAL MATRIX q OF QR DECOMPOSITION OF RANDOM SAMPLE MATRIX.
!           q IS ASSUMED OF FULL RANK.
!
            call ortho_gen_qr( q(:n,:np), beta(:np) )
!
        end if
!
!       COMPUTE RANDOM SUBSPACE PROJECTION.
!
#ifdef _BLAS
!        call gemm( 'N', 'N', n, np, n, one, a(1_i4b:n,1_i4b:n), n,       &
!                   q(1_i4b:n,1_i4b:np), n, zero, b(1_i4b:n,1_i4b:np), n  )
        call symm( 'L', 'U', n, np, one, a(1_i4b:n,1_i4b:n), n,          &
                   q(1_i4b:n,1_i4b:np), n, zero, b(1_i4b:n,1_i4b:np), n  )
#else
        b(:n,:np) = matmul( a(:n,:n), q(:n,:np)  )
#endif
!
        q(:n,:np) = b(:n,:np)
!
    end do
!
!   COMPUTE QR DECOMPOSITION OF RANDOM SAMPLE MATRIX TO OBTAIN AN
!   ORTHONORMAL BASIS OF RANDOM SUBSPACE.
!
    call qr_cmp( q(:n,:np), diagr(:np), beta(:np) )
!
!   GENERATE ORTHOGONAL MATRIX q OF QR DECOMPOSITION OF RANDOM SAMPLE MATRIX.
!   q IS ASSUMED OF FULL RANK.
!
    call ortho_gen_qr( q(:n,:np), beta(:np) )
!
!   COMPUTE FINAL RANDOM SUBSPACE PROJECTION.
!
#ifdef _BLAS
!    call gemm( 'N', 'N', n, np, n, one, a(1_i4b:n,1_i4b:n), n,       &
!               q(1_i4b:n,1_i4b:np), n, zero, b(1_i4b:n,1_i4b:np), n  )
    call symm( 'L', 'U', n, np, one, a(1_i4b:n,1_i4b:n), n,          &
               q(1_i4b:n,1_i4b:np), n, zero, b(1_i4b:n,1_i4b:np), n  )
!
!   COMPUTE v = q**(t)*b = q**(t)*a*q .
!
    call gemm( 'T', 'N', np, np, n, one, q(1_i4b:n,1_i4b:np), n,       &
               b(1_i4b:n,1_i4b:np), n, zero, v(1_i4b:np,1_i4b:np), np  )
#else
    b(:n,:np) = matmul( a(:n,:n), q(:n,:np)  )
!
!   COMPUTE v = q**(t)*b = q**(t)*a*q .
!
    qt(:np,:n) = transpose( q(:n,:np) )
!
    v(:np,:np) = matmul( qt(:np,:n), b(:n,:np) )
#endif
!
!   USE A SPECTRAL DECOMPOSITION.
!
    call eig_cmp( v(:np,:np), beta(:np), failure, maxiter=30_i4b )
!
    call eig_abs_sort( sort, beta(:np), v(:np,:np) )
!
!   COMPUTE THE APPROXIMATE TOP neig EIGENVECTORS OF a .
!
#ifdef _BLAS
    call gemm( 'N', 'N', n, neig, np, one, q(1_i4b:n,1_i4b:np), n,              &
               v(1_i4b:np,1_i4b:neig), np, zero, eigvec(1_i4b:n,1_i4b:neig), n  )
#else
    eigvec(:n,:neig) = matmul( q(:n,:np), v(:np,:neig) )
#endif
!
!   EXTRACT THE APPROXIMATE TOP neig EIGENVALUES (IN ABSOLUTE MAGNITUDE) OF a .
!
    eigval(:neig) = beta(:neig)
!
!   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 )
!
!   COMPUTE THE ESTIMATED RELATIVE ERROR.
!
    tmp = one - sum( (eigval(1_i4b:neig)/norma)**2 )
    relerr = sqrt( max( tmp, zero ) )
!
!   COMPUTE THE TRUE RELATIVE ERROR.
!
    relerr2 = sqrt( sum( (eigval0(neig+1_i4b:neig0)/norma)**2 ) )
!
!   COMPUTE ERROR BETWEEN THE TRUE AND ESTIMATED RELATIVE ERRORS.
!
    err = abs( relerr - relerr2 )
!
!   TEST ACCURACY OF THE EIGEN COUPLETS IF REQUIRED.
!
    if ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*u(:n,:neig) - u(:n,:neig)*diag(eigval(:neig)),
!       WHERE u ARE THE EIGENVECTORS OF a.
!
        q(:n,:neig) = eigvec(:n,:neig)*spread(eigval(:neig),dim=1,ncopies=n)
!
#ifdef _BLAS
!        call gemm( 'N', 'N', n, neig, n, one, a(1_i4b:n,1_i4b:n), n,              &
!                   eigvec(1_i4b:n,1_i4b:neig), n, -one, q(1_i4b:n,1_i4b:neig), n  )
       call symm( 'L', 'U', n, neig, one, a(1_i4b:n,1_i4b:n), n,                  &
                   eigvec(1_i4b:n,1_i4b:neig), n, -one, q(1_i4b:n,1_i4b:neig), n  )
#else
        q(:n,:neig) = matmul( a(:n,:n), eigvec(:n,:neig)  ) - q(:n,:neig)
#endif
!
        beta(:neig) = norm( q(:n,:neig), dim=2_i4b )
!
        err1 = maxval( beta(:neig) )/( norma*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u(:n,:neig)**(t)*u(:n,:neig).
!
        call unit_matrix( q(:neig,:neig) )
!
        v(:neig,:neig) = abs( q(:neig,:neig) - matmul( transpose(eigvec), eigvec ) )
!
        err2 = maxval( v(:neig,:neig) )/real(n,stnd)
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
#ifdef _BLAS
    deallocate( a, q, b, v, diagr, beta, eigval0, eigval, eigvec )
#else
    deallocate( a, q, qt, b, v, diagr, beta, eigval0, eigval, eigvec )
#endif
!
!   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
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing approximate ', neig, ' eigenvalues and eigenvectors of a ', &
       n, ' by ', n,' real symmetric matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_random_eig_with_blas
! =======================================
!
end program ex1_random_eig_with_blas

ex1_random_number.F90

program ex1_random_number
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of intrinsic subroutine RANDOM_NUMBER.
!                                                                            
! LATEST REVISION : 23/11/2016
!                                               
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd,  merror, allocate_error
!
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n1=10**4, n2=10**4
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd) :: elapsed_time
    real(stnd), allocatable, dimension(:,:) :: real_mat
!
    integer(i4b) :: i, j
    integer      :: iok, istart, iend, irate, imax, itime
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of intrinsic random_number'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   ALLOCATE WORK ARRAY.
!
    allocate( real_mat(n1,n2), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   RESET THE SEEDS USED BY THE INTRINSIC UNIFORM RANDOM GENERATOR.
!
    call random_seed()
!
    call system_clock( count_rate=irate, count_max=imax  )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count=istart )
!
!   GENERATE AN UNIFORM RANDOM REAL MATRIX USING
!   SCALAR FORM OF INTRINSIC SUBROUTINE random_number.
!
    do i = 1_i4b, n2
!
        do j = 1_i4b, n1
!
             call random_number( real_mat(j,i) )
!
        end do
!
    end do
!
!   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 )
!
    write (*,'(a,i10,a,0pd12.4,a)')              &
      'The elapsed time for generating ', n1*n2, &
      ' random uniform real numbers with scalar form of intrinsic subroutine random_number is',  &
      elapsed_time, ' seconds'
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count=istart )
!
!   GENERATE AN UNIFORM RANDOM REAL MATRIX USING VECTOR
!   FORM OF SUBROUTINE random_number.
!
    do i = 1_i4b, n2
!
        call random_number( real_mat(:n1,i) )
!
    end do
!
!   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 )
!
    write (prtunit,*) 
    write (*,'(a,i10,a,0pd12.4,a)')              &
      'The elapsed time for generating ', n1*n2, &
      ' random uniform real numbers with vector form of intrinsic subroutine random_number is',  &
      elapsed_time, ' seconds'
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count=istart )
!
!   GENERATE AN UNIFORM RANDOM REAL MATRIX USING MATRIX
!   FORM OF SUBROUTINE random_number.
!
    call random_number( real_mat(:n1,:n2) )
!
!   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 )
!
    write (prtunit,*) 
    write (*,'(a,i10,a,0pd12.4,a)')              &
      'The elapsed time for generating ', n1*n2, &
      ' random uniform real numbers with matrix form of intrinsic subroutine random_number is',  &
      elapsed_time, ' seconds'
!
!   DEALLOCATE WORK ARRAY.
!
    deallocate( real_mat )
!
!
! END OF PROGRAM ex1_random_number
! ================================
!
end program ex1_random_number

ex1_random_number_.F90

program ex1_random_number_
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine RANDOM_NUMBER_ and
!   function RAND_NUMBER in module Random.
!                                                                            
! LATEST REVISION : 23/11/2016
!                                               
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd,  merror, allocate_error, random_seed_,  &
                         rand_number, random_number_
!
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n1=10**4, n2=10**4
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd) :: elapsed_time
    real(stnd), allocatable, dimension(:,:) :: real_mat
!
    integer(i4b) :: i, j
    integer      :: iok, istart, iend, irate, imax, itime
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of random_number_'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   ALLOCATE WORK ARRAY.
!
    allocate( real_mat(n1,n2), 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=4 )
!
!   RESET THE SEEDS USED BY THE UNIFORM RANDOM GENERATOR.
!
    call random_seed_()
!
    call system_clock( count_rate=irate, count_max=imax  )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count=istart )
!
!   GENERATE AN UNIFORM RANDOM REAL MATRIX USING FUNCTION rand_number().
!
    do i = 1_i4b, n2
!
        do j = 1_i4b, n1
!
             real_mat(j,i) = rand_number( )
!
        end do
!
    end do
!
!   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 )
!
    write (*,'(a,i10,a,0pd12.4,a)')              &
      'The elapsed time for generating ', n1*n2, &
      ' random uniform real numbers with function rand_number() is',  &
      elapsed_time, ' seconds'
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count=istart )
!
!   GENERATE AN UNIFORM RANDOM REAL MATRIX USING VECTOR
!   FORM OF SUBROUTINE random_number_.
!
    do i = 1_i4b, n2
!
        call random_number_( real_mat(:n1,i) )
!
    end do
!
!   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 )
!
    write (prtunit,*) 
    write (*,'(a,i10,a,0pd12.4,a)')              &
      'The elapsed time for generating ', n1*n2, &
      ' random uniform real numbers with vector form of subroutine random_number_ is',  &
      elapsed_time, ' seconds'
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count=istart )
!
!   GENERATE AN UNIFORM RANDOM REAL MATRIX USING MATRIX
!   FORM OF SUBROUTINE random_number_.
!
    call random_number_( real_mat(:n1,:n2) )
!
!   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 )
!
    write (prtunit,*) 
    write (*,'(a,i10,a,0pd12.4,a)')              &
      'The elapsed time for generating ', n1*n2, &
      ' random uniform real numbers with matrix form of subroutine random_number_ is',  &
      elapsed_time, ' seconds'
!
!   DEALLOCATE WORK ARRAY.
!
    deallocate( real_mat )
!
!
! END OF PROGRAM ex1_random_number_
! =================================
!
end program ex1_random_number_

ex1_random_svd.F90

program ex1_random_svd
!
!
! Purpose
! =======
!
!   This program illustrates how to compute an approximate partial SVD with randomized
!   subspace iterations using STATPACK.
!                                                                              
!                                                     
! Further Details
! ===============
!
!   The program shows the use of subroutines SVD_CMP in module SVD_Procedures,
!   QR_CMP and ORTHO_GEN_QR in module QR_Procedures, NORMAL_RANDOM_NUMBER3_ and
!   GEN_RANDOM_MAT in module Random.
!                                                                              
! LATEST REVISION : 23/10/2020
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, one, seven, c30, merror, allocate_error, &
                         norm, unit_matrix, random_seed_, normal_random_number3_, singval_sort,      &
                         qr_cmp, ortho_gen_qr, svd_cmp, gen_random_mat
!
#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,
! nsvd0 IS THE RANK OF THE GENERATED MATRIX,
! nsvd IS THE TARGET RANK OF THE APPROXIMATE PARTIAL SVD, WHICH IS SOUGHT
!
    integer(i4b), parameter :: prtunit=6, m=2000, n=1000, mn=min(m,n), nsvd0=1000, nsvd=5
!
    character(len=*), parameter :: name_proc='Example 1 of random_svd'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd) :: err, err1, err2, err3, eps, elapsed_time, norma, tmp, relerr, relerr2
    real(stnd), dimension(:,:), allocatable :: a, q, qt, b, bt, leftvec, rightvec
    real(stnd), dimension(:),   allocatable :: diagr, beta, singval, singval0
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: p, np, niter, i, mat_type
!
    logical(lgl) :: failure, do_test, ortho
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : PARTIAL SVD OF A m-BY-n REAL MATRIX USING RANDOMIZED
!               POWER SUBSPACE ITERATIONS.
!
!   SPECIFY THE TYPE OF INPUT MATRIX:
!
!   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 > 3  -> VERY SLOW DECAY OF SINGULAR VALUES
!
    mat_type = 2_i4b
!
!   SET TOLERANCE FOR THE ERROR OF THE RELATIVE ERROR IN FROBENIUS NORM
!   OF THE COMPUTED PARTIAL SVD.
!
    eps = 0.001_stnd
!
!   SPECIFY IF NUMERICAL TESTS ARE PERFORMED TO TEST THE ACCURACY OF THE SINGULAR TRIPLETS.
!
    do_test = true
!
!   CHOOSE TUNING PARAMETERS FOR THE RANDOMIZED ALGORITHM.
!
!   DETERMINE THE NUMBER OF POWER ITERATIONS niter TO BE PERFORMED.
!
    niter = 5_i4b
!
!   DETERMINE THE OVERSAMPLING SIZE p .
!
    p  = 10_i4b
!
!   CHECK VALIDITY OF THE OVERSAMPLING SIZE PARAMETER.
!
    np = min( p + nsvd, mn )
!
!   SPECIFY IF ORTHONORMALIZATION IS CARRIED OUT BETWEEN EACH STEP
!   OF THE (POWER) SUBSPACE ITERATIONS, TO AVOID LOSS OF ACCURACY DUE
!   TO ROUNDING ERRORS.
!
    ortho = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(m,n), q(m,np), qt(np,m), b(n,np), bt(np,n),        &
              diagr(np), beta(np), singval0(nsvd0), singval(nsvd), &
              leftvec(m,nsvd), rightvec(n,nsvd),  stat=iok  )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A m-BY-n RANDOM REAL MATRIX a WITH A SPECIFIED DISTRIBUTION
!   OF SINGULAR VALUES.
!
!   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 SINGULAR VALUES.
!
    select case( mat_type )
!
        case( 1_i4b )
!
!           SLOW DECAY OF SINGULAR VALUES.
!
            do i = 1_i4b, nsvd0
!
                tmp = real( i, stnd )
!
                singval0(i) = one/( tmp*tmp )
!        
            end do
!
        case( 2_i4b )
!
!           FAST DECAY OF SINGULAR VALUES.
!
            do i = 1_i4b, nsvd0
!
                tmp = real( i, stnd )
!
                singval0(i) = exp( -tmp/seven )
!        
            end do
!
        case( 3_i4b )
!
!           S-SHAPED DECAY OF SINGULAR VALUES.
!
            do i = 1_i4b, nsvd0
!
                tmp = real( i, stnd )
!
                singval0(i) = 0.0001_stnd + one/( one + exp( tmp -c30 ) )
!        
            end do
!
        case default
!
!           VERY SLOW DECAY OF SINGULAR VALUES.
!
            norma = real( nsvd0 - 1_i4b, stnd )
!
            do i = 1_i4b, nsvd0
!
                tmp = real( i - 1_i4b, stnd )
!
                singval0(i) = exp( -tmp/norma )
!        
            end do
!
    end select
!
!   SORT THE SINGULAR VALUES.
!
    call singval_sort( sort, singval0(:nsvd0) )
!
!   GENERATE A m-BY-n MATRIX a OF RANK nsvd0 .
!
    call gen_random_mat( singval0(:nsvd0), a )
!
!   COMPUTE THE FROBENIUS NORM OF THE MATRIX.
!
!    norma = norm( a(:m,:n) )
    norma = sqrt(sum( singval0(:nsvd0)**2 ) )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   GENERATE A n-BY-np IID GAUSSIAN MATRIX .
!
!   GENERATE A NORMAL RANDOM REAL MATRIX USING MATRIX
!   FORM OF SUBROUTINE normal_random_number3_.
!
    call normal_random_number3_( b(:n,:np) )
!
!   GENERATE A NORMAL RANDOM REAL MATRIX USING VECTOR
!   FORM OF SUBROUTINE normal_random_number_.
!
!    do i = 1_i4b, np
!
!        call normal_random_number3_( b(:n,i) )
!
!    end do
!
!   COMPUTE RANDOM SAMPLE MATRIX.
!
    q(:m,:np) = matmul( a(:m,:n), b(:n,:np) )
!
!   DO POWER ITERATIONS.
!
    do i = 1_i4b, niter
!
        if ( ortho ) then
!
!           COMPUTE QR DECOMPOSITION OF RANDOM MATRIX TO OBTAIN AN
!           ORTHONORMAL BASIS OF RANDOM SUBSPACE.
!
            call qr_cmp( q(:m,:np), diagr(:np), beta(:np) )
!
!           GENERATE ORTHOGONAL MATRIX q OF QR DECOMPOSITION OF RANDOM MATRIX.
!           q IS ASSUMED OF FULL RANK.
!
            call ortho_gen_qr( q(:m,:np), beta(:np) )
!
        end if
!
!       COMPUTE RANDOM SUBSPACE PROJECTION.
!
        qt(:np,:m) = transpose( q(:m,:np) )
!
        bt(:np,:n) = matmul( qt(:np,:m), a(:m,:n) )
!
        b(:n,:np) = transpose( bt(:np,:n) )
!
        if ( ortho ) then
!
!           COMPUTE QR DECOMPOSITION OF RANDOM MATRIX TO OBTAIN AN
!           ORTHONORMAL BASIS OF RANDOM SUBSPACE.
!
            call qr_cmp( b(:n,:np), diagr(:np), beta(:np) )
!
!           GENERATE ORTHOGONAL MATRIX q OF QR DECOMPOSITION OF RANDOM MATRIX.
!           q IS ASSUMED OF FULL RANK.
!
            call ortho_gen_qr( b(:n,:np), beta(:np) )
!
        end if
!
!       COMPUTE RANDOM SUBSPACE PROJECTION.
!
        q(:m,:np) = matmul( a(:m,:n), b(:n,:np) )
!
    end do
!
!   COMPUTE QR DECOMPOSITION OF RANDOM MATRIX TO OBTAIN AN
!   ORTHONORMAL BASIS OF RANDOM SUBSPACE.
!
    call qr_cmp( q(:m,:np), diagr(:np), beta(:np) )
!
!   GENERATE ORTHOGONAL MATRIX q OF QR DECOMPOSITION OF RANDOM MATRIX.
!   q IS ASSUMED OF FULL RANK.
!
    call ortho_gen_qr( q(:m,:np), beta(:np) )
!
    qt(:np,:m) = transpose( q(:m,:np) )
!
    bt(:np,:n) = matmul( qt(:np,:m), a(:m,:n) )
!
!   COMPUTE SVD OF THE FINAL RANDOM MATRIX PROJECTION.
!
    call svd_cmp( bt(:np,:n), beta(:np), failure, v=b(:n,:np), sort=sort, max_francis_steps=10_i4b )
!
!   COMPUTE THE APPROXIMATE TOP nsvd LEFT SINGULAR VECTORS OF a .
!
    leftvec(:m,:nsvd) = matmul( q(:m,:np), bt(:np,:nsvd) )
!
!   EXTRACT THE APPROXIMATE TOP nsvd RIGHT SINGULAR VECTORS OF a .
!
    rightvec(:n,:nsvd) = b(:n,:nsvd)
!
!   EXTRACT THE APPROXIMATE TOP nsvd SINGULAR VALUES OF a .
!
    singval(:nsvd) = beta(:nsvd)
!
!   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 )
!
!   COMPUTE THE ESTIMATED RELATIVE ERROR.
!
    tmp = one - sum( (singval(:nsvd)/norma)**2 )
    relerr = sqrt( max( tmp, zero ) )
!
!   COMPUTE THE TRUE RELATIVE ERROR.
!
    relerr2 = sqrt(sum( (singval0(nsvd+1_i4b:nsvd0)/norma)**2 ))
!
!   COMPUTE ERROR BETWEEN THE TRUE AND ESTIMATED RELATIVE ERRORS.
!
    err = abs( relerr - relerr2 )
!
!   TEST ACCURACY OF THE SINGULAR TRIPLETS IF REQUIRED.
!
    if ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*v(:m,:nsvd) - u(:n,:nsvd)*diag(singval(:nsvd)),
!       WHERE u AND v ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a.
!
        q(:m,:nsvd) = matmul(a,rightvec) - leftvec*spread(singval(:nsvd),dim=1,ncopies=m)
        beta(:nsvd) = norm( q(:m,:nsvd), dim=2_i4b )
!
        err1 = maxval( beta(:nsvd) )/( norma*real(mn,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u(:n,:nsvd)**(t)*u(:n,:nsvd).
!
        call unit_matrix( q(:nsvd,:nsvd) )
!
        b(:nsvd,:nsvd) = abs( q(:nsvd,:nsvd) - matmul( transpose(leftvec), leftvec ) )
!
        err2 = maxval( b(:nsvd,:nsvd) )/real(m,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - v(:m,:nsvd)**(t)*v(:m,:nsvd).
!
        b(:nsvd,:nsvd) = abs( q(:nsvd,:nsvd) - matmul( transpose(rightvec), rightvec ) )
!
        err3 = maxval( b(:nsvd,:nsvd) )/real(n,stnd)
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, q, qt, b, bt, diagr, beta, singval0, singval, leftvec, rightvec )
!
!   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
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing approximate ', nsvd, ' singular values and vectors of a ', &
       m, ' by ', n,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_random_svd
! =============================
!
end program ex1_random_svd

ex1_random_svd_with_blas.F90

program ex1_random_svd_with_blas
!
!
! Purpose
! =======
!
!   This program illustrates how to compute an approximate partial SVD with randomized
!   subspace iterations using STATPACK and BLAS subroutines.
!                                                                              
!                                                     
! Further Details
! ===============
!
!   The program shows the use of subroutines SVD_CMP in module SVD_Procedures,
!   QR_CMP and ORTHO_GEN_QR in module QR_Procedures, NORMAL_RANDOM_NUMBER3_ and
!   GEN_RANDOM_MAT in module Random and gemm generic interface in module BLAS_interfaces.
!    
!                                                                              
! LATEST REVISION : 23/10/2020
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, one, seven, c30, merror, allocate_error, &
                         norm, unit_matrix, random_seed_, normal_random_number3_, singval_sort,      &
                         qr_cmp, ortho_gen_qr, svd_cmp, gen_random_mat
!
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
#ifdef _TRANSPOSE
    use Statpack, only : transpose=>transpose2
#endif
#ifdef _BLAS
    use BLAS_interfaces, only : gemm
#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 RANK OF THE GENERATED MATRIX,
! nsvd IS THE TARGET RANK OF THE APPROXIMATE PARTIAL SVD, WHICH IS SOUGHT
!
    integer(i4b), parameter :: prtunit=6, m=2000, n=2000, mn=min(m,n), nsvd0=1000, nsvd=10
!
    character(len=*), parameter :: name_proc='Example 1 of random_svd_with_blas'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd) :: err, err1, err2, err3, eps, elapsed_time, norma, tmp, relerr, relerr2
#ifdef _BLAS
    real(stnd), dimension(:,:), allocatable :: a, q, b, v, leftvec, rightvec
#else
    real(stnd), dimension(:,:), allocatable :: a, q, qt, b, bt, leftvec, rightvec
#endif
    real(stnd), dimension(:),   allocatable :: diagr, beta, singval, singval0
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: p, np, niter, i, mat_type
!
    logical(lgl) :: failure, do_test, ortho
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : PARTIAL SVD OF A m-BY-n REAL MATRIX USING RANDOMIZED
!               POWER SUBSPACE ITERATIONS.
!
!   SPECIFY THE TYPE OF INPUT MATRIX:
!
!   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 > 3  -> VERY SLOW DECAY OF SINGULAR VALUES
!
    mat_type = 2_i4b
!
!   SET TOLERANCE FOR THE ERROR OF THE RELATIVE ERROR IN FROBENIUS NORM
!   OF THE COMPUTED PARTIAL SVD.
!
    eps = 0.001_stnd
!
!   SPECIFY IF NUMERICAL TESTS ARE PERFORMED TO TEST THE ACCURACY OF THE SINGULAR TRIPLETS.
!
    do_test = true
!
!   CHOOSE TUNING PARAMETERS FOR THE RANDOMIZED ALGORITHM.
!
!   DETERMINE THE NUMBER OF POWER ITERATIONS niter TO BE PERFORMED.
!
    niter = 4_i4b
!
!   DETERMINE THE OVERSAMPLING SIZE p .
!
    p  = 10_i4b
!
!   CHECK VALIDITY OF THE OVERSAMPLING SIZE PARAMETER.
!
    np = min( p + nsvd, mn )
!
!   SPECIFY IF ORTHONORMALIZATION IS CARRIED OUT BETWEEN EACH STEP
!   OF THE (POWER) SUBSPACE ITERATIONS, TO AVOID LOSS OF ACCURACY DUE
!   TO ROUNDING ERRORS.
!
    ortho = true
!
!   ALLOCATE WORK ARRAYS.
!
#ifdef _BLAS
    allocate( a(m,n), q(m,np), b(n,np), v(np,np),                        &
              diagr(nsvd0), beta(nsvd0), singval0(nsvd0), singval(nsvd), &
              leftvec(m,nsvd), rightvec(n,nsvd),  stat=iok )
#else
    allocate( a(m,n), q(m,np), qt(np,m), b(n,np), bt(np,n),              &
              diagr(nsvd0), beta(nsvd0), singval0(nsvd0), singval(nsvd), &
              leftvec(m,nsvd), rightvec(n,nsvd),  stat=iok )
#endif
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A m-BY-n RANDOM REAL MATRIX a WITH A GEOMETRIC DISTRIBUTION
!   OF EIGENVALUES WITH APPROXIMATE CONDITION NUMBER conda AND RANK nsvd0 .
!
!   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 SINGULAR VALUES.
!
    select case( mat_type )
!
        case( 1_i4b )
!
!           SLOW DECAY OF SINGULAR VALUES.
!
            do i = 1_i4b, nsvd0
!
                tmp = real( i, stnd )
!
                singval0(i) = one/( tmp*tmp )
!        
            end do
!
        case( 2_i4b )
!
!           FAST DECAY OF SINGULAR VALUES.
!
            do i = 1_i4b, nsvd0
!
                tmp = real( i, stnd )
!
                singval0(i) = exp( -tmp/seven )
!        
            end do
!
        case( 3_i4b )
!
!           S-SHAPED DECAY OF SINGULAR VALUES.
!
            do i = 1_i4b, nsvd0
!
                tmp = real( i, stnd )
!
                singval0(i) = 0.0001_stnd + one/( one + exp( tmp -c30 ) )
!        
            end do
!
        case default
!
!           VERY SLOW DECAY OF SINGULAR VALUES.
!
            norma = real( nsvd0 - 1_i4b, stnd )
!
            do i = 1_i4b, nsvd0
!
                tmp = real( i - 1_i4b, stnd )
!
                singval0(i) = exp( -tmp/norma )
!        
            end do
!
    end select
!
!   SORT THE SINGULAR VALUES.
!
    call singval_sort( sort, singval0(:nsvd0) )
!
!   GENERATE A m-BY-n MATRIX a OF RANK nsvd0 .
!
    call gen_random_mat( singval0(:nsvd0), a )
!
!   COMPUTE THE FROBENIUS NORM OF THE MATRIX.
!
!    norma = norm( a(:m,:n) )
    norma = sqrt(sum( singval0(:nsvd0)**2 ) )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   GENERATE A n-BY-np IID GAUSSIAN MATRIX .
!
!   GENERATE A NORMAL RANDOM REAL MATRIX USING MATRIX
!   FORM OF SUBROUTINE normal_random_number3_.
!
    call normal_random_number3_( b(:n,:np) )
!
!   GENERATE A NORMAL RANDOM REAL MATRIX USING VECTOR
!   FORM OF SUBROUTINE normal_random_number_.
!
!    do i = 1_i4b, np
!
!        call normal_random_number3_( b(:n,i) )
!
!    end do
!
!   COMPUTE RANDOM SAMPLE MATRIX.
!
#ifdef _BLAS
    call gemm( 'N', 'N', m, np, n, one, a(1_i4b:m,1_i4b:n), m,       &
               b(1_i4b:n,1_i4b:np), n, zero, q(1_i4b:m,1_i4b:np), m  )
#else
    q(:m,:np) = matmul( a(:m,:n), b(:n,:np) )
#endif
!
!   DO POWER ITERATIONS.
!
    do i = 1_i4b, niter
!
        if ( ortho ) then
!
!           COMPUTE QR DECOMPOSITION OF RANDOM MATRIX TO OBTAIN AN
!           ORTHONORMAL BASIS OF RANDOM SUBSPACE.
!
            call qr_cmp( q(:m,:np), diagr(:np), beta(:np) )
!
!           GENERATE ORTHOGONAL MATRIX q OF QR DECOMPOSITION OF RANDOM MATRIX.
!           q IS ASSUMED OF FULL RANK.
!
            call ortho_gen_qr( q(:m,:np), beta(:np) )
!
        end if
!
!       COMPUTE RANDOM SUBSPACE PROJECTION.
!
#ifdef _BLAS
        call gemm( 'T', 'N', n, np, m, one, a(1_i4b:m,1_i4b:n), m,       &
                   q(1_i4b:m,1_i4b:np), m, zero, b(1_i4b:n,1_i4b:np), n  )
#else
        qt(:np,:m) = transpose( q(:m,:np) )
!
        bt(:np,:n) = matmul( qt(:np,:m), a(:m,:n) )
!
        b(:n,:np) = transpose( bt(:np,:n) )
#endif
!
        if ( ortho ) then
!
!           COMPUTE QR DECOMPOSITION OF RANDOM MATRIX TO OBTAIN AN
!           ORTHONORMAL BASIS OF RANDOM SUBSPACE.
!
            call qr_cmp( b(:n,:np), diagr(:np), beta(:np) )
!
!           GENERATE ORTHOGONAL MATRIX q OF QR DECOMPOSITION OF RANDOM MATRIX.
!           q IS ASSUMED OF FULL RANK.
!
            call ortho_gen_qr( b(:n,:np), beta(:np) )
!
        end if
!
!       COMPUTE RANDOM SUBSPACE PROJECTION.
!
#ifdef _BLAS
        call gemm( 'N', 'N', m, np, n, one, a(1_i4b:m,1_i4b:n), m,       &
                   b(1_i4b:n,1_i4b:np), n, zero, q(1_i4b:m,1_i4b:np), m  )
#else
        q(:m,:np) = matmul( a(:m,:n), b(:n,:np) )
#endif
!
    end do
!
!   COMPUTE QR DECOMPOSITION OF RANDOM MATRIX TO OBTAIN AN
!   ORTHONORMAL BASIS OF RANDOM SUBSPACE.
!
    call qr_cmp( q(:m,:np), diagr(:np), beta(:np) )
!
!   GENERATE ORTHOGONAL MATRIX q OF QR DECOMPOSITION OF RANDOM MATRIX.
!   q IS ASSUMED OF FULL RANK.
!
    call ortho_gen_qr( q(:m,:np), beta(:np) )
!
#ifdef _BLAS
    call gemm( 'T', 'N', n, np, m, one, a(1_i4b:m,1_i4b:n), m,       &
               q(1_i4b:m,1_i4b:np), m, zero, b(1_i4b:n,1_i4b:np), n  )
!
!   COMPUTE SVD OF THE FINAL RANDOM MATRIX PROJECTION.
!
    call svd_cmp( b(:n,:np), beta(:np), failure, v=v(:np,:np), sort=sort, max_francis_steps=10_i4b )
!
!   COMPUTE THE APPROXIMATE TOP nsvd LEFT SINGULAR VECTORS OF a .
!
    call gemm( 'N', 'N', m, nsvd, np, one, q(1_i4b:m,1_i4b:np), m,             &
               v(1_i4b:np,1_i4b:np), np, zero, leftvec(1_i4b:m,1_i4b:nsvd), m  )
#else
    qt(:np,:m) = transpose( q(:m,:np) )
!
    bt(:np,:n) = matmul( qt(:np,:m), a(:m,:n) )
!
!   COMPUTE SVD OF THE FINAL RANDOM MATRIX PROJECTION.
!
    call svd_cmp( bt(:np,:n), beta(:np), failure, v=b(:n,:np), sort=sort, max_francis_steps=10_i4b )
!
!   COMPUTE THE APPROXIMATE TOP nsvd LEFT SINGULAR VECTORS OF a .
!
    leftvec(:m,:nsvd) = matmul( q(:m,:np), bt(:np,:nsvd) )
#endif
!
!   EXTRACT THE APPROXIMATE TOP nsvd RIGHT SINGULAR VECTORS OF a .
!
    rightvec(:n,:nsvd) = b(:n,:nsvd)
!
!   EXTRACT THE APPROXIMATE TOP nsvd SINGULAR VALUES OF a .
!
    singval(:nsvd) = beta(:nsvd)
!
!   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 )
!
!   COMPUTE THE ESTIMATED RELATIVE ERROR.
!
    tmp = one - sum( (singval(:nsvd)/norma)**2 )
    relerr = sqrt( max( tmp, zero ) )
!
!   COMPUTE THE TRUE RELATIVE ERROR.
!
    relerr2 = sqrt(sum( (singval0(nsvd+1_i4b:nsvd0)/norma)**2 ))
!
!   COMPUTE ERROR BETWEEN THE TRUE AND ESTIMATED RELATIVE ERRORS.
!
    err = abs( relerr - relerr2 )
!
!   TEST ACCURACY OF THE SINGULAR TRIPLETS IF REQUIRED.
!
    if ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*v(:m,:nsvd) - u(:n,:nsvd)*diag(singval(:nsvd)),
!       WHERE u AND v ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a.
!
        q(:m,:nsvd) = leftvec(:m,:nsvd)*spread( singval(:nsvd), dim=1, ncopies=m)
!
#ifdef _BLAS
        call gemm( 'N', 'N', m, nsvd, n, one, a(1_i4b:m,1_i4b:n), m,                &
                   rightvec(1_i4b:n,1_i4b:nsvd), n, -one, q(1_i4b:m,1_i4b:nsvd), m  )
#else
        q(:m,:nsvd) = matmul( a(:m,:n), rightvec(:n,:nsvd) ) - q(:m,:nsvd)
#endif
!
        beta(:nsvd) = norm( q(:m,:nsvd), dim=2_i4b )
!
        err1 = maxval( beta(:nsvd) )/( norma*real(mn,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u(:n,:nsvd)**(t)*u(:n,:nsvd).
!
        call unit_matrix( q(:nsvd,:nsvd) )
!
        b(:nsvd,:nsvd) = abs( q(:nsvd,:nsvd) - matmul( transpose(leftvec), leftvec ) )
!
        err2 = maxval( b(:nsvd,:nsvd) )/real(m,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - v(:m,:nsvd)**(t)*v(:m,:nsvd).
!
        b(:nsvd,:nsvd) = abs( q(:nsvd,:nsvd) - matmul( transpose(rightvec), rightvec ) )
!
        err3 = maxval( b(:nsvd,:nsvd) )/real(n,stnd)
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
#ifdef _BLAS
    deallocate( a, q, b, v, diagr, beta, singval0, singval, leftvec, rightvec )
#else
    deallocate( a, q, qt, b, bt, diagr, beta, singval0, singval, leftvec, rightvec )
#endif
!
!   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
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing approximate ', nsvd, ' singular values and vectors of a ', &
       m, ' by ', n,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_random_svd_with_blas
! =======================================
!
end program ex1_random_svd_with_blas

ex1_real_fft.F90

program ex1_real_fft
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine REAL_FFT
!   in module FFT_Procedures .
!                                                                              
! LATEST REVISION : 15/06/2018
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, true, false, init_fft, fft, real_fft, end_fft, &
                         merror, allocate_error
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT, n IS AN EVEN POSITIVE INTEGER.
!
    integer(i4b), parameter :: prtunit=6, n=100000
!
    character(len=*), parameter :: name_proc='Example 1 of real_fft'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                            :: err, eps, elapsed_time
    real(stnd), dimension(:), allocatable :: y, y2
!
    complex(stnd), dimension(:), allocatable :: yt
!
    integer(i4b) :: nd2
    integer      :: iok, istart, iend, irate, imax, itime
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : FORWARD FFT OF A REAL SEQUENCE.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = sqrt( epsilon( err ) )
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( y(n), y2(n), yt(n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM REAL NUMBER SEQUENCE OF EVEN LENGTH n .
!
    call random_number( y(:n) )
!
!   INITIALIZE THE REAL_FFT SUBROUTINE.
!
    nd2   = n/2
!
    call init_fft( nd2 )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   TRANSFORM THE REAL SEQUENCE.
!
    call real_fft( y(:n), yt(:nd2+1), forward=true  )
!
!   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 )
!
    call end_fft()
!
!   COMPUTE THE REMAINING VALUES OF THE FOURIER TRANSFORM.
!
    yt(n:nd2+2:-1) = conjg( yt(2:nd2) )
!
!   INITIALIZE THE FFT SUBROUTINE FOR THE BACKWARD TRANSFORM.
!
    call init_fft( n )
!
!   INVERT THE SEQUENCE BACK.
!
    call fft( yt(:n), forward=false )
!
    call end_fft()
!
!   CHECK THAT INVERSE(TRANSFORM(SEQUENCE)) = SEQUENCE.
!
    y2(:n) = real( yt(:n) )
!
    err = maxval(abs(y(:n)-y2(:n)))/maxval(abs(y(:n)))
!
!   DEALLOCATE ARRAYS.
!
    deallocate( y, y2, yt )
!
    if ( err<=eps  ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    write (prtunit,*)
    write (*,'(a,i8,a,0pd12.4,a)')    &
      'The elapsed time for computing the forward FFT of a real sequence of size ', &
       n, ' is', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_real_fft
! ===========================
!
end program ex1_real_fft

ex1_real_fft_forward.F90

program ex1_real_fft_forward
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine REAL_FFT_FORWARD 
!   and REAL_FFT_BACKWARD in module FFT_Procedures .
!                                                                              
! LATEST REVISION : 15/06/2018
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, real_fft_forward, real_fft_backward, merror, allocate_error
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT, n IS THE LENGTH OF THE TIME SERIES.
!
    integer(i4b), parameter :: prtunit=6, n=4000
!
    character(len=*), parameter :: name_proc='Example 1 of real_fft_forward'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                            :: err, eps, elapsed_time
    real(stnd), dimension(:), allocatable :: y, y2, yi, yr
!
    integer(i4b) :: nd2p1
    integer      :: iok, istart, iend, irate, imax, itime
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : FORWARD AND BACWARD FFTS OF A REAL SEQUENCE BY THE GOERTZEL METHOD.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = sqrt( epsilon( err ) )
!
    nd2p1 = (n/2) + 1
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( y(n), y2(n), yi(nd2p1), yr(nd2p1), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM REAL NUMBER SEQUENCE.
!
    call random_number( y(:n) )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   TRANSFORM THE REAL SEQUENCE.
!
    call real_fft_forward( y(:n), yr(:nd2p1), yi(:nd2p1)  )
!
!   INVERT THE SEQUENCE BACK.
!
    call real_fft_backward( yr(:nd2p1), yi(:nd2p1), y2(:n) )
!
!   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 INVERSE(TRANSFORM(SEQUENCE)) = SEQUENCE.
!
    err = maxval(abs(y(:n)-y2(:n)))/maxval(abs(y(:n)))
!
!   DEALLOCATE ARRAYS.
!
    deallocate( y, y2, yi, yr )
!
    if ( err<=eps  ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    write (prtunit,*)
    write (*,'(a,i8,a,0pd12.4,a)')    &
      'The elapsed time for computing the forward and backward FFTs of a real sequence of size ', &
       n, ' is', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_real_fft_forward
! ===================================
!
end program ex1_real_fft_forward

ex1_reig_cmp.F90

program ex1_reig_cmp
!
!
! Purpose
! =======
!
!   This program illustrates how to compute an approximate partial EigenValue Decomposition (EVD)
!   of a symmetric matrix with randomized power, subspace or block Krylov iterations using
!   subroutine REIG_CMP in module Eig_Procedures.
!                                                                              
! LATEST REVISION : 23/10/2020
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, half, one, seven, c30, merror, allocate_error, &
                         norm, unit_matrix, random_seed_, random_number_, normal_random_number3_,          &
                         eigval_abs_sort, reig_cmp, gen_random_sym_mat
!
#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, neig IS THE TARGET RANK OF THE APPROXIMATE PARTIAL EVD DECOMPOSITION,
! neig0 IS THE RANK OF THE GENERATED MATRIX,
! n IS THE DIMENSION OF THE GENERATED SYMMETRIC MATRIX.
!
    integer(i4b), parameter :: prtunit=6, n=2000, neig=5, neig0=1000
!
    character(len=*), parameter :: name_proc='Example 1 of reig_cmp'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd) :: err, err1, err2, eps, elapsed_time, tmp, norma, relerr, relerr2
    real(stnd), dimension(:,:), allocatable :: a, eigvec, res, id
    real(stnd), dimension(:),   allocatable :: eigval0, eigval, beta
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: i, niter, nover, mat_type
!
    logical(lgl) :: failure, extd_samp, do_test, ortho
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : PARTIAL EIGENVALUE DECOMPOSITION OF A n-BY-n REAL SYMMETRIC
!               MATRIX USING RANDOMIZED POWER SUBSPACE OR BLOCK KRYLOV ITERATIONS.
!
!   SPECIFY THE TYPE OF INPUT MATRIX:
!
!   mat_type = 1  -> SLOW DECAY OF EIGENVALUES      (IN ABSOLUTE MAGNITUDE)
!   mat_type = 2  -> FAST DECAY OF EIGENVALUES      (IN ABSOLUTE MAGNITUDE)
!   mat_type = 3  -> S-SHAPED DECAY OF EIGENVALUES  (IN ABSOLUTE MAGNITUDE)
!   mat_type > 3  -> VERY SLOW DECAY OF EIGENVALUES (IN ABSOLUTE MAGNITUDE)
!
    mat_type = 2_i4b
!
!   SET TOLERANCE FOR THE ERROR OF THE RELATIVE ERROR IN FROBENIUS NORM
!   OF THE COMPUTED PARTIAL EVD.
!
    eps = 0.001_stnd
!
!   SPECIFY IF NUMERICAL TESTS ARE PERFORMED TO TEST THE ACCURACY OF THE EIGEN COUPLETS.
!
    do_test = true
!
!   CHOOSE TUNING PARAMETERS FOR THE RANDOMIZED EVD ALGORITHM.
!
!   DETERMINE THE NUMBER OF POWER SUBSPACE OR BLOCK KRYLOV ITERATIONS niter .
!
    niter = 6_i4b
!
!   DETERMINE THE OVERSAMPLING SIZE nover .
!
    nover = 10_i4b
!
!   SPECIFY IF POWER SUBSPACE OR BLOCK KRYLOV ITERATIONS ARE USED.
!
    extd_samp = false
!
!   DETERMINE IF ORTHONORMALIZATION IS CARRIED OUT BETWEEN EACH STEP
!   OF THE (POWER) SUBSPACE OR BLOCK KRYLOV ITERATIONS, TO AVOID LOSS
!   OF ACCURACY DUE TO ROUNDING ERRORS. THIS IS NOT NEEDED NORMALLY
!   FOR SEMI-DEFINITE POSITIVE MATRIX.
!
    ortho = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), eigvec(n,neig), eigval(neig),  &
              eigval0(neig0), beta(neig0), stat=iok  )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-BY-n RANDOM REAL SYMMETRIC MATRIX a WITH
!   A SPECIFIED DISTRIBUTION OF EIGENVALUES.
!
!   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 EIGENVALUES.
!
    select case( mat_type )
!
        case( 1_i4b )
!
!           SLOW DECAY OF EIGENVALUES.
!
            do i = 1_i4b, neig0
!
                tmp = real( i, stnd )
!
                eigval0(i) = one/( tmp*tmp )
!        
            end do
!
        case( 2_i4b )
!
!           FAST DECAY OF EIGENVALUES.
!
            do i = 1_i4b, neig0
!
                tmp = real( i, stnd )
!
                eigval0(i) = exp( -tmp/seven )
!        
            end do
!
        case( 3_i4b )
!
!           S-SHAPED DECAY OF EIGENVALUES.
!
            do i = 1_i4b, neig0
!
                tmp = real( i, stnd )
!
                eigval0(i) = 0.0001_stnd + one/( one + exp( tmp -c30 ) )
!        
            end do
!
        case default
!
!           VERY SLOW DECAY OF EIGENVALUES.
!
            norma = real( neig0 - 1_i4b, stnd )
!
            do i = 1_i4b, neig0
!
                tmp = real( i - 1_i4b, stnd )
!
                eigval0(i) = exp( -tmp/norma )
!        
            end do
!
    end select
!  
!   CHANGE SIGN OF HALF OF THE EIGENVALUES.
!
    call random_number_( beta(:neig0) )
!
    where ( beta(:neig0)>half ) eigval0(:neig0) = -eigval0(:neig0)
!
!   SORT THE EIGENVALUES BY DECREASING ABSOLUTE MAGNITUDE.
!
    call eigval_abs_sort( sort, eigval0(:neig0) )
!
!   GENERATE A SYMMETRIC MATRIX a WITH THE SPECIFIED EIGENVALUES
!   AND RANK neig0.
!
    call gen_random_sym_mat( eigval0(:neig0), a )
!
!   COMPUTE THE FROBENIUS NORM OF THE SYMMETRIC MATRIX.
!
!    norma = norm( a(:n,:n) )
    norma = sqrt(sum( eigval0(:neig0)**2 ) )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   reig_cmp COMPUTES A PARTIAL EIGENVALUE DECOMPOSITION (EVD) OF A REAL
!   n-BY-n SYMMETRIC MATRIX a. THE PARTIAL EVD IS WRITTEN
!
!                       U * S * U**(t)
!
!   WHERE S IS AN neig-BY-neig MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   DIAGONAL ELEMENTS, U IS AN n-BY-neig ORTHONORMAL MATRIX. THE DIAGONAL
!   ELEMENTS OF S ARE THE neig LARGEST EIGENVALUES OF a IN DECREASING ABSOLUTE
!   MAGNITUDE ORDER. THE COLUMNS OF U ARE THE ASSOCIATED EIGENVECTORS OF a.
!
    call reig_cmp( a(:n,:n), eigval(:neig), eigvec(:n,:neig), failure=failure, &
                   niter=niter, nover=nover, ortho=ortho, extd_samp=extd_samp    )
!
!   THE ROUTINE RETURNS THE neig LARGEST EIGENVALUES (IN ABSOLUTE MAGNITUDE) AND THE
!   ASSOCIATED EIGENVECTORS.
!
!   ON EXIT OF reig_cmp :
!
!       eigval CONTAINS THE neig LARGEST EIGENVALUES OF a IN DECREASING ORDER OF
!       ABSOLUTE MAGNITUDE.
!
!       eigvec CONTAINS THE ASSOCIATED neig EIGENVECTORS,
!       STORED COLUMNWISE;
!
!       failure= false :  INDICATES SUCCESSFUL EXIT.
!       failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                         THAT FULL ACCURACY WAS NOT ATTAINED IN THE RANDOMIZED
!                         POWER SUBSPACE OR BLOCK KRYLOV ITERATIONS. THE RESULTS
!                         CAN BE STILL USEFUL, BUT THE APPROXIMATIONS OF THE neig
!                         TOP EIGEN COUPLETS CAN BE POOR.
!
!   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 )
!
!   COMPUTE THE ESTIMATED RELATIVE ERROR.
!
    tmp = one - sum( (eigval(1_i4b:neig)/norma)**2 )
    relerr = sqrt( max( tmp, zero ) )
!
!   COMPUTE THE TRUE RELATIVE ERROR.
!
    relerr2 = sqrt( sum( (eigval0(neig+1_i4b:neig0)/norma)**2 ) )
!
!   COMPUTE ERROR BETWEEN THE TRUE AND ESTIMATED RELATIVE ERRORS.
!
    err = abs( relerr - relerr2 )
!
!   TEST ACCURACY OF THE EIGEN COUPLETS IF REQUIRED.
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( res(n,neig), id(neig,neig), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*u(:n,:neig) - u(:n,:neig)*diag(eigval(:neig)),
!       WHERE u ARE THE EIGENVECTORS OF a.
!
        res(:n,:neig)   = matmul(a,eigvec) - eigvec*spread(eigval(:neig),dim=1,ncopies=n)
        id(:neig,1_i4b) = norm( res(:n,:neig), dim=2_i4b )
!
        err1 = maxval( id(:neig,1_i4b) )/( norma*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u(:n,:neig)**(t)*u(:n,:neig).
!
        call unit_matrix( id(:neig,:neig) )
!
        res(:neig,:neig) = abs( id(:neig,:neig) - matmul( transpose(eigvec), eigvec ) )
!
        err2 = maxval( res(:neig,:neig) )/real(n,stnd)
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( res, id )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, eigval0, eigval, eigvec, beta )
!
!   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
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing approximate ', neig, ' eigenvalues and eigenvectors of a ', &
       n, ' by ', n,' real symmetric matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_reig_cmp
! ===========================
!
end program ex1_reig_cmp

ex1_reig_pos_cmp.F90

program ex1_reig_pos_cmp
!
!
! Purpose
! =======
!
!   This program illustrates how to compute an approximate partial EigenValue Decomposition (EVD)
!   of a symmetric positive semi-definite matrix with randomized power, subspace or block Krylov
!   iterations, and the Nystrom method, using subroutine REIG_POS_CMP in module SVD_Procedures.
!                                                                              
! LATEST REVISION : 23/10/2020
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, one, seven, c30, merror, allocate_error,  &
                         norm, unit_matrix, random_seed_, random_number_, normal_random_number3_,     &
                         eigval_sort, reig_pos_cmp, gen_random_sym_mat
!
#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, neig IS THE TARGET RANK OF THE APPROXIMATE PARTIAL EVD DECOMPOSITION,
! neig0 IS THE RANK OF THE GENERATED MATRIX,
! n IS THE DIMENSION OF THE GENERATED SYMMETRIC POSITIVE SEMI-DEFINITE MATRIX.
!
    integer(i4b), parameter :: prtunit=6, n=2000, neig=5, neig0=1000
!
    character(len=*), parameter :: name_proc='Example 1 of reig_pos_cmp'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd) :: err, err1, err2, eps, elapsed_time, tmp, norma, relerr, relerr2
    real(stnd), dimension(:,:), allocatable :: a, eigvec, res, id
    real(stnd), dimension(:),   allocatable :: eigval0, eigval
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: i, niter, nover, mat_type
!
    logical(lgl) :: failure, extd_samp, do_test, ortho, use_nystrom
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : PARTIAL EIGENVALUE DECOMPOSITION OF A n-BY-n REAL SYMMETRIC POSITIVE
!               SEMI-DEFINITE MATRIX USING RANDOMIZED POWER SUBSPACE OR BLOCK KRYLOV
!               ITERATIONS AND THE NYSTROM METHOD.
!
!   SPECIFY THE TYPE OF INPUT MATRIX:
!
!   mat_type = 1  -> SLOW DECAY OF EIGENVALUES
!   mat_type = 2  -> FAST DECAY OF EIGENVALUES
!   mat_type = 3  -> S-SHAPED DECAY OF EIGENVALUES
!   mat_type > 3  -> VERY SLOW DECAY OF EIGENVALUES
!
    mat_type = 2_i4b
!
!   SET TOLERANCE FOR THE ERROR OF THE RELATIVE ERROR IN FROBENIUS NORM
!   OF THE COMPUTED PARTIAL EVD.
!
    eps = 0.001_stnd
!
!   SPECIFY IF NUMERICAL TESTS ARE PERFORMED TO TEST THE ACCURACY OF THE EIGEN COUPLETS.
!
    do_test = true
!
!   CHOOSE TUNING PARAMETERS FOR THE RANDOMIZED EVD ALGORITHM.
!
!   CHOOSE TUNING PARAMETERS FOR THE ALGORITHM.
!
!   DETERMINE THE NUMBER OF POWER SUBSPACE OR BLOCK KRYLOV ITERATIONS niter .
!
    niter = 8_i4b
!
!   DETERMINE THE OVERSAMPLING SIZE nover .
!
    nover = 10_i4b
!
!   SPECIFY IF POWER SUBSPACE OR BLOCK KRYLOV ITERATIONS ARE USED.
!
    extd_samp = true
!
!   DETERMINE IF ORTHONORMALIZATION IS CARRIED OUT BETWEEN EACH STEP
!   OF THE (POWER) SUBSPACE OR BLOCK KRYLOV ITERATIONS, TO AVOID LOSS
!   OF ACCURACY DUE TO ROUNDING ERRORS. THIS IS NOT NEEDED NORMALLY
!   FOR SEMI-DEFINITE POSITIVE MATRIX.
!
    ortho = true
!
!   SPECIFY IF LAST STEP OF THE ALGORITHM IS PERFORMED WITH THE NYSTROM
!   METHOD (AND A SVD) OR AN EIGENVALUE DECOMPOSITION.
!
    use_nystrom = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), eigvec(n,neig), eigval(neig), eigval0(neig0), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-BY-n RANDOM REAL SYMMETRIC POSITIVE SEMI-DEFINITE MATRIX a WITH A
!   SPECIFIED DISTRIBUTION OF EIGENVALUES.
!
!   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 EIGENVALUES.
!
    select case( mat_type )
!
        case( 1_i4b )
!
!           SLOW DECAY OF EIGENVALUES.
!
            do i = 1_i4b, neig0
!
                tmp = real( i, stnd )
!
                eigval0(i) = one/( tmp*tmp )
!        
            end do
!
        case( 2_i4b )
!
!           FAST DECAY OF EIGENVALUES.
!
            do i = 1_i4b, neig0
!
                tmp = real( i, stnd )
!
                eigval0(i) = exp( -tmp/seven )
!        
            end do
!
        case( 3_i4b )
!
!           S-SHAPED DECAY OF EIGENVALUES.
!
            do i = 1_i4b, neig0
!
                tmp = real( i, stnd )
!
                eigval0(i) = 0.0001_stnd + one/( one + exp( tmp -c30 ) )
!        
            end do
!
        case default
!
!           VERY SLOW DECAY OF EIGENVALUES.
!
            norma = real( neig0 - 1_i4b, stnd )
!
            do i = 1_i4b, neig0
!
                tmp = real( i - 1_i4b, stnd )
!
                eigval0(i) = exp( -tmp/norma )
!        
            end do
!
    end select
!
!   SORT THE EIGENVALUES BY DECREASING MAGNITUDE.
!
    call eigval_sort( sort, eigval0(:neig0) )
!
!   GENERATE A SYMMETRIC MATRIX a WITH THE SPECIFIED EIGENVALUES AND RANK neig0.
!
    call gen_random_sym_mat( eigval0(:neig0), a )
!
!   COMPUTE THE FROBENIUS NORM OF THE SYMMETRIC POSITIVE MATRIX.
!
!    norma = norm( a(:n,:n) )
    norma = sqrt(sum( eigval0(:neig0)**2 ) )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   reig_pos_cmp COMPUTES A PARTIAL EIGENVALUE DECOMPOSITION (EVD) OF A REAL
!   n-BY-n SYMMETRIC POSITIVE SEMI-DEFINITE MATRIX a. THE PARTIAL EVD IS WRITTEN
!
!                       U * S * U**(t)
!
!   WHERE S IS AN neig-BY-neig MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   DIAGONAL ELEMENTS, U IS AN n-BY-neig ORTHONORMAL MATRIX. THE DIAGONAL
!   ELEMENTS OF S ARE THE neig LARGEST EIGENVALUES OF a IN DECREASING MAGNITUDE ORDER.
!   THE COLUMNS OF U ARE THE ASSOCIATED EIGENVECTORS OF a.
!
    call reig_pos_cmp( a(:n,:n), eigval(:neig), eigvec(:n,:neig), failure=failure,  &
                       niter=niter, nover=nover, ortho=ortho, extd_samp=extd_samp,  &
                       use_nystrom=use_nystrom, max_francis_steps=10_i4b )
!
!   THE ROUTINE RETURNS THE neig LARGEST EIGENVALUES AND THE ASSOCIATED EIGENVECTORS.
!
!   ON EXIT OF reig_pos_cmp :
!
!       eigval CONTAINS THE neig LARGEST EIGENVALUES OF a IN DECREASING ORDER.
!
!       eigvec CONTAINS THE ASSOCIATED neig EIGENVECTORS,
!       STORED COLUMNWISE;
!
!       failure= false :  INDICATES SUCCESSFUL EXIT.
!       failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                         THAT FULL ACCURACY WAS NOT ATTAINED IN THE RANDOMIZED
!                         POWER SUBSPACE OR BLOCK KRYLOV ITERATIONS. THE RESULTS
!                         CAN BE STILL USEFUL, BUT THE APPROXIMATIONS OF THE neig
!                         TOP EIGEN COUPLETS CAN BE POOR.
!
!   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 )
!
!   COMPUTE THE ESTIMATED RELATIVE ERROR.
!
    tmp = one - sum( (eigval(1_i4b:neig)/norma)**2 )
    relerr = sqrt( max( tmp, zero ) )
!
!   COMPUTE THE TRUE RELATIVE ERROR.
!
    relerr2 = sqrt( sum( (eigval0(neig+1_i4b:neig0)/norma)**2 ) )
!
!   COMPUTE ERROR BETWEEN THE TRUE AND ESTIMATED RELATIVE ERRORS.
!
    err = abs( relerr - relerr2 )
!
!   TEST ACCURACY OF THE EIGEN COUPLETS IF REQUIRED.
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( res(n,neig), id(neig,neig), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*u(:n,:neig) - u(:n,:neig)*diag(eigval(:neig)),
!       WHERE u ARE THE EIGENVECTORS OF a.
!
        res(:n,:neig)   = matmul(a,eigvec) - eigvec*spread(eigval(:neig),dim=1,ncopies=n)
        id(:neig,1_i4b) = norm( res(:n,:neig), dim=2_i4b )
!
        err1 = maxval( id(:neig,1_i4b) )/( norma*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u(:n,:neig)**(t)*u(:n,:neig).
!
        call unit_matrix( id(:neig,:neig) )
!
        res(:neig,:neig) = abs( id(:neig,:neig) - matmul( transpose(eigvec), eigvec ) )
!
        err2 = maxval( res(:neig,:neig) )/real(n,stnd)
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( res, id )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, eigval0, eigval, eigvec )
!
!   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
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing approximate ', neig, ' eigenvalues and eigenvectors of a ', &
       n, ' by ', n,' real symmetric positive semi-definite matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_reig_pos_cmp
! ===============================
!
end program ex1_reig_pos_cmp

ex1_reorder.F90

program ex1_reorder
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines DO_INDEX and REORDER
!   in module Sort_Procedures.
!                                                                              
! LATEST REVISION : 06/07/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, false, arth, do_index, reorder
!   
!
! STRONG TYPING IMPOSED
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=100
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd), dimension(n) :: x
!
    integer(i4b)               :: i, j, k, i1, i2
    integer(i4b), dimension(n) :: y, indexx, indexy
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of reorder'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE RANDOM REAL DATA TO SORT.
!
    call random_number( x )
!
!   INITIALIZE PERMUTATION TO THE IDENTITY.
!
    y = arth( 1_i4b, 1_i4b, n ) 
!    
!   GENERATE A RANDOM ORDERING OF THE INTEGERS 1 TO n.
!   STARTING AT THE END, SWAP THE CURRENT LAST INDICATOR WITH ONE
!   RANDOMLY CHOSEN FROM THOSE PRECEEDING IT.

    do i = n, 2, -1
        j = 1 + i * x(i)
        if (j < i) then
            k    = y(i)
            y(i) = y(j)
            y(j) = k
        end if
    end do
!
!   COMPUTE INDEX FOR EACH ARRAY.
!
    call do_index( x, indexx)
    call do_index( y, indexy)
!
!   EXAMPLE 1 : SORT THE REAL DATA IN ASCENDING ORDER 
!               BY MEANS OF THE INDEX .
!
    call reorder( indexx, x  )
!
!   CHECK THAT THE SORTED ARRAY IS NON-DECREASING.
!
    i1 = count( x(1:n-1) > x(2:n) )
!
!   EXAMPLE 2 : SORT THE INTEGER DATA IN DECREASING ORDER
!            BY MEANS OF THE INDEX .
!
    call reorder( indexy, y, ascending=false )
!
!   CHECK THAT THE SORTED ARRAY IS NON-INCREASING.
!
    i2 = count( y(1:n-1) < y(2:n) )
!
!   PRINT THE RESULT OF THE TESTS.
!
    if ( i1==0 .and. i2==0 ) then
        write (prtunit,*) 'Example 1 of REORDER is correct'
    else
        write (prtunit,*) 'Example 1 of REORDER is incorrect'
    end if
!
!
! END OF PROGRAM ex1_reorder
! ==========================
!
end program ex1_reorder

ex1_rsvd_cmp.F90

program ex1_rsvd_cmp
!
!
! Purpose
! =======
!
!   This program illustrates how to compute an approximate partial SVD with randomized power,
!   subspace or block Krylov iterations using subroutine RSVD_CMP in module SVD_Procedures.
!                                                                              
!                                                                              
! LATEST REVISION : 26/11/2020
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, one, seven, ten, c30, merror, allocate_error,  &
                         norm, unit_matrix, random_seed_, random_number_, normal_random_number3_,          &
                         singval_sort, rsvd_cmp, gen_random_mat
!
#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,
! nsvd0 IS THE RANK OF THE GENERATED MATRIX,
! nsvd IS THE TARGET RANK OF THE APPROXIMATE PARTIAL SVD, WHICH IS SOUGHT.
!
    integer(i4b), parameter :: prtunit=6, m=10000, n=10000, mn=min(m,n), nsvd0=1000, nsvd=10
!
    character(len=*), parameter :: name_proc='Example 1 of rsvd_cmp'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd) :: err, err1, err2, err3, eps, elapsed_time, norma, tmp, relerr, relerr2
    real(stnd), dimension(:,:), allocatable :: a, leftvec, rightvec, res, id
    real(stnd), dimension(:),   allocatable :: singval, singval0
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: niter, nover, i, mat_type
!
    logical(lgl) :: failure, extd_samp, ortho, do_test
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : PARTIAL SVD OF A m-BY-n REAL MATRIX USING RANDOMIZED
!               POWER SUBSPACE OR BLOCK KRYLOV ITERATIONS.
!
!   SPECIFY THE TYPE OF INPUT MATRIX:
!
!   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 > 3  -> VERY SLOW DECAY OF SINGULAR VALUES
!
    mat_type = 2_i4b
!
!   SET TOLERANCE FOR THE ERROR OF THE RELATIVE ERROR IN FROBENIUS NORM
!   OF THE COMPUTED PARTIAL SVD.
!
    eps = 0.01_stnd
!
!   SPECIFY IF NUMERICAL TESTS ARE PERFORMED TO TEST THE ACCURACY OF THE SINGULAR TRIPLETS.
!
    do_test = true
!
!   CHOOSE TUNING PARAMETERS FOR THE RANDOMIZED ALGORITHM.
!
!   DETERMINE THE NUMBER OF POWER SUBSPACE OR BLOCK KRYLOV ITERATIONS niter TO BE PERFORMED.
!
    niter = 2_i4b
!
!   DETERMINE THE OVERSAMPLING SIZE nover .
!
    nover = 5_i4b
!
!   SPECIFY IF POWER SUBSPACE OR BLOCK KRYLOV ITERATIONS ARE USED.
!
    extd_samp = false
!
!   DETERMINE IF ORTHONORMALIZATION IS CARRIED OUT BETWEEN EACH STEP
!   OF THE (POWER) SUBSPACE OR BLOCK KRYLOV ITERATIONS, TO AVOID LOSS
!   OF ACCURACY DUE TO ROUNDING ERRORS.
!
    ortho = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(m,n), singval(nsvd), leftvec(m,nsvd), rightvec(n,nsvd),   &
              singval0(nsvd0), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A m-BY-n RANDOM REAL MATRIX a WITH A SPECIFIED DISTRIBUTION
!   OF SINGULAR VALUES.
!
!   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 SINGULAR VALUES.
!
    select case( mat_type )
!
        case( 1_i4b )
!
!           SLOW DECAY OF SINGULAR VALUES.
!
            do i = 1_i4b, nsvd0
!
                tmp = real( i, stnd )
!
                singval0(i) = one/( tmp*tmp )
!        
            end do
!
        case( 2_i4b )
!
!           FAST DECAY OF SINGULAR VALUES.
!
            do i = 1_i4b, nsvd0
!
                tmp = real( i, stnd )
!
                singval0(i) = exp( -tmp/seven )
!        
            end do
!
        case( 3_i4b )
!
!           S-SHAPED DECAY OF SINGULAR VALUES.
!
            do i = 1_i4b, nsvd0
!
                tmp = real( i, stnd )
!
                singval0(i) = 0.0001_stnd + one/( one + exp( tmp -c30 ) )
!        
            end do
!
        case default
!
!           VERY SLOW DECAY OF SINGULAR VALUES.
!
            norma = real( nsvd0 - 1_i4b, stnd )
!
            do i = 1_i4b, nsvd0
!
                tmp = real( i - 1_i4b, stnd )
!
                singval0(i) = exp( -tmp/norma )
!        
            end do
!
    end select
!
!   SORT THE SINGULAR VALUES.
!
    call singval_sort( sort, singval0(:nsvd0) )
!
!   GENERATE A m-BY-n MATRIX a OF RANK nsvd0 .
!
    call gen_random_mat( singval0(:nsvd0), a )
!
!   COMPUTE THE FROBENIUS NORM OF THE MATRIX.
!
!    norma = norm( a(:m,:n) )
    norma = sqrt(sum( singval0(:nsvd0)**2 ) )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   rsvd_cmp COMPUTES A PARTIAL SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL
!   m-BY-n MATRIX a. THE PARTIAL SVD IS WRITTEN
!
!                       U * S * V**(t)
!
!   WHERE S IS AN nsvd-BY-nsvd MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   DIAGONAL ELEMENTS, U IS AN m-BY-nsvd ORTHONORMAL MATRIX, AND
!   V IS AN n-BY-nsvd ORTHONORMAL MATRIX.  THE DIAGONAL ELEMENTS OF S
!   ARE THE nsvd LARGEST SINGULAR VALUES OF a; THEY ARE REAL AND NON-NEGATIVE.
!   THE COLUMNS OF U AND V ARE THE ASSOCIATED LEFT AND RIGHT SINGULAR VECTORS OF a.
!
    call rsvd_cmp( a(:m,:n), singval(:nsvd), leftvec(:m,:nsvd), rightvec(:n,:nsvd),    &
                   failure=failure, niter=niter, nover=nover, extd_samp=extd_samp,     &
                   ortho=ortho, max_francis_steps=10_i4b )
!
!   THE ROUTINE RETURNS THE nsvd LARGEST SINGULAR VALUES AND THE ASSOCIATED LEFT
!   AND RIGHT SINGULAR VECTORS.
!
!   ON EXIT OF rsvd_cmp :
!
!       singval CONTAINS THE nsvd LARGEST SINGULAR VALUES OF a IN DECREASING ORDER.
!
!       leftvec CONTAINS THE ASSOCIATED nsvd LEFT SINGULAR VECTORS,
!       STORED COLUMNWISE;
!   
!       rightvec CONTAINS THE ASSOCIATED nsvd RIGHT SINGULAR VECTORS,
!       STORED COLUMNWISE;
!
!       failure= false :  INDICATES SUCCESSFUL EXIT.
!       failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                         THAT FULL ACCURACY WAS NOT ATTAINED IN THE RANDOMIZED
!                         SUBSPACE ITERATIONS. THE RESULTS CAN BE STILL USEFUL,
!                         BUT THE APPROXIMATIONS OF SOME OF THE nsvd TOP SINGULAR
!                         TRIPLETS CAN BE POOR.
!
!   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 )
!
!   COMPUTE THE ESTIMATED RELATIVE ERROR.
!
    tmp = one - sum( (singval(:nsvd)/norma)**2 )
    relerr = sqrt( max( tmp, zero ) )
!
!   COMPUTE THE TRUE RELATIVE ERROR.
!
    relerr2 = sqrt(sum( (singval0(nsvd+1_i4b:nsvd0)/norma)**2 ))
!
!   COMPUTE ERROR BETWEEN THE TRUE AND ESTIMATED RELATIVE ERRORS.
!
    err = abs( relerr - relerr2 )
!
!   TEST ACCURACY OF THE SINGULAR TRIPLETS IF REQUIRED.
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( res(m,nsvd), id(nsvd,nsvd), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*v(:m,:nsvd) - u(:n,:nsvd)*diag(singval(:nsvd)),
!       WHERE u AND v ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a.
!
        res(:m,:nsvd) = matmul(a,rightvec) - leftvec*spread(singval(:nsvd),dim=1,ncopies=m)
        id(:nsvd,1_i4b) = norm( res(:m,:nsvd), dim=2_i4b )
!
        err1 = maxval( id(:nsvd,1_i4b) )/( norma*real(mn,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u(:n,:nsvd)**(t)*u(:n,:nsvd).
!
        call unit_matrix( id(:nsvd,:nsvd) )
!
        res(:nsvd,:nsvd) = abs( id(:nsvd,:nsvd) - matmul( transpose(leftvec), leftvec ) )
!
        err2 = maxval( res(:nsvd,:nsvd) )/real(m,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - v(:m,:nsvd)**(t)*v(:m,:nsvd).
!
        res(:nsvd,:nsvd) = abs( id(:nsvd,:nsvd) - matmul( transpose(rightvec), rightvec ) )
!
        err3 = maxval( res(:nsvd,:nsvd) )/real(n,stnd)
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( res, id )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, singval0, singval, leftvec, rightvec )
!
!   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
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing approximate ', nsvd, ' singular values and vectors of a ', &
       m, ' by ', n,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_rsvd_cmp
! ===========================
!
end program ex1_rsvd_cmp

ex1_rsvd_cmp_fixed_precision.F90

program ex1_rsvd_cmp_fixed_precision
!
!
! Purpose
! =======
!
!   This program illustrates how to compute an approximate reduced SVD with randomized
!   subspace iterations, which fullfills a given relative error in Frobenius norm using
!   subroutine RSVD_CMP_FIXED_PRECISION in module SVD_Procedures.
!                                                                              
!                                                                              
! LATEST REVISION : 26/11/2020
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, one, two, three, seven, c30, allocate_error,  &
                         merror, norm, unit_matrix, random_seed_, normal_random_number3_, singval_sort,   &
                         gen_random_mat, rsvd_cmp_fixed_precision
!
#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,
! nsvd0 IS THE RANK OF THE GENERATED MATRIX,
! relerr0 IS THE REQUESTED RELATIVE ERROR OF THE RESTRICTED SVD IN FROBENIUS NORM.
!
    integer(i4b), parameter :: prtunit=6, m=10000, n=5000, mn=min(m,n), nsvd0=1000
!   
    real(stnd), parameter  :: relerr0=0.5_stnd
!
    character(len=*), parameter :: name_proc='Example 1 of rsvd_cmp_fixed_precision'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd) :: err, err1, err2, err3, eps, elapsed_time, norma, relerr, relerr2, tmp
    real(stnd), dimension(:,:), allocatable :: a, res, id
    real(stnd), dimension(:),   allocatable :: singval0
!
    real(stnd), dimension(:,:), pointer :: leftvec, rightvec
    real(stnd), dimension(:),   pointer :: singval
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: blk_size, niter, niter_qb, maxiter_qb, i, nsvd, mat_type
!
    logical(lgl) :: failure_relerr, failure, do_test, ortho, reortho
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : PARTIAL SVD OF A m-BY-n REAL MATRIX USING RANDOMIZED
!               POWER SUBSPACE ITERATIONS.
!
!   SPECIFY THE TYPE OF INPUT MATRIX:
!
!   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 > 3  -> VERY SLOW DECAY OF SINGULAR VALUES
!
    mat_type = 2_i4b
!
!   SET TOLERANCE FOR THE ERROR OF THE RELATIVE ERROR IN FROBENIUS NORM
!   OF THE COMPUTED PARTIAL SVD.
!
    eps = 0.01_stnd
!
!   SPECIFY IF NUMERICAL TESTS ARE PERFORMED TO TEST THE ACCURACY OF THE SINGULAR TRIPLETS.
!
    do_test = true
!
!   CHOOSE TUNING PARAMETERS FOR THE RANDOMIZED SVD ALGORITHM.
!   blk_size*maxiter_qb IS THE MAXIMUM ALLOWABLE RANK OF THE
!   PARTIAL SVD, WHICH IS SOUGHT.
!
    blk_size   = 10_i4b
    maxiter_qb = 20_i4b
!
!   DETERMINE THE NUMBER OF POWER OR SUBSPACE ITERATIONS niter TO BE PERFORMED
!   IN THE FIRST STEP OF THE QB FACTORIZATION.
!
    niter = 5_i4b
!
!   SPECIFY IF ORTHONORMALIZATION IS CARRIED OUT BETWEEN EACH STEP
!   OF THE (POWER) SUBSPACE ITERATIONS, TO AVOID LOSS OF ACCURACY DUE
!   TO ROUNDING ERRORS.
!
    ortho = true
!
!   SPECIFY IF REORTHONORMALIZATION IS CARRIED OUT TO AVOID LOSS OF ORTHOGONALITY
!   IN THE BLOCK GRAM-SCHMIDT ORTHOGONALISATION SCHEME USED TO BUILD THE ORTHOGONAL
!   MATRIX OF THE QB DECOMPOSITION OF THE INPUT MATRIX.
!
    reortho = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(m,n), singval0(nsvd0), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   DETERMINE THE NUMBER OF SUBSPACE ITERATIONS niter_qb TO BE PERFORMED
!   IN THE LAST STEP OF THE QB FACTORIZATION.
!
    niter_qb = 4_i4b
!
!   GENERATE A m-BY-n RANDOM REAL MATRIX a WITH A SPECIFIED DISTRIBUTION
!   OF SINGULAR VALUES.
!
!   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 SINGULAR VALUES.
!
    select case( mat_type )
!
        case( 1_i4b )
!
!           SLOW DECAY OF SINGULAR VALUES.
!
            do i = 1_i4b, nsvd0
!
                tmp = real( i, stnd )
!
                singval0(i) = one/( tmp*tmp )
!        
            end do
!
        case( 2_i4b )
!
!           FAST DECAY OF SINGULAR VALUES.
!
            do i = 1_i4b, nsvd0
!
                tmp = real( i, stnd )
!
                singval0(i) = exp( -tmp/seven )
!        
            end do
!
        case( 3_i4b )
!
!           S-SHAPED DECAY OF SINGULAR VALUES.
!
            do i = 1_i4b, nsvd0
!
                tmp = real( i, stnd )
!
                singval0(i) = 0.0001_stnd + one/( one + exp( tmp -c30 ) )
!        
            end do
!
        case default
!
!           VERY SLOW DECAY OF SINGULAR VALUES.
!
            norma = real( nsvd0 - 1_i4b, stnd )
!
            do i = 1_i4b, nsvd0
!
                tmp = real( i - 1_i4b, stnd )
!
                singval0(i) = exp( -tmp/norma )
!        
            end do
!
    end select
!
!   SORT THE SINGULAR VALUES.
!
    call singval_sort( sort, singval0(:nsvd0) )
!
!   GENERATE A m-BY-n MATRIX a OF RANK nsvd0 .
!
    call gen_random_mat( singval0(:nsvd0), a )
!
!   COMPUTE THE FROBENIUS NORM OF THE MATRIX.
!
!    norma = norm( a(:m,:n) )
    norma = sqrt(sum( singval0(:nsvd0)**2 ) )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   rsvd_cmp_fixed_precision COMPUTES A PARTIAL SINGULAR VALUE DECOMPOSITION (SVD)
!   OF A REAL m-BY-n MATRIX a, WITH A RANK AS SMALL AS POSSIBLE, BUT WHICH FULFILLS A PRESET
!   TOLERANCE FOR ITS RELATIVE ERROR IN THE FROBENIUS NORM:
!
!            ||A-rSVD||_F <= ||A||_F * relerr
!
!   , WHERE rSVD IS THE COMPUTED PARTIAL SVD APPROXIMATION, || ||_F IS THE FROBENIUS NORM AND
!   relerr IS A PRESCRIBED ACCURACY TOLERANCE FOR THE RELATIVE ERROR OF THE COMPUTED PARTIAL SVD
!   APPROXIMATION, SPECIFIED IN THE INPUT ARGUMENT relerr.
!
!   THE PARTIAL SVD IS WRITTEN
!
!                       U * S * V**(t)
!
!   WHERE S IS AN nsvd-BY-nsvd MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   DIAGONAL ELEMENTS, U IS AN m-BY-nsvd ORTHONORMAL MATRIX, AND
!   V IS AN n-BY-nsvd ORTHONORMAL MATRIX.  THE DIAGONAL ELEMENTS OF S
!   ARE THE nsvd LARGEST SINGULAR VALUES OF a; THEY ARE REAL AND NON-NEGATIVE.
!   THE COLUMNS OF U AND V ARE THE ASSOCIATED LEFT AND RIGHT SINGULAR VECTORS OF a.
!
!   HERE THE RANK OF THE PARTIAL SVD IS NOT KNOWN IN ADVANCE AND THE ARGUMENTS singval, leftvec
!   AND rightvec, WHICH WILL CONTAIN THE SINGULAR TRIPLETS MUST BE SPECIFIED AS REAL ARRAY
!   POINTERS. On EXIT, nsvd = size( singval ) IS THE RANK OF THE COMPUTED PARTIAL SVD.
!
!   SET THE TOLERANCE FOR THE RELATIVE ERROR IN FROBENIUS NORM.
!
    relerr = relerr0
!
!   NULLIFY THE POINTERS singval, leftvec AND rightvec SO THAT THEIR STATUT CAN BE CHECKED INSIDE
!   rsvd_cmp_fixed_precision SUBROUTINE.
!
    nullify( singval, leftvec, rightvec )
!
    call rsvd_cmp_fixed_precision( a(:m,:n), relerr, singval, leftvec, rightvec,          &
                                   failure_relerr=failure_relerr, failure=failure,        &
                                   niter=niter, blk_size=blk_size, maxiter_qb=maxiter_qb, &
                                   ortho=ortho, reortho=reortho, niter_qb=niter_qb,       &
                                   max_francis_steps=10_i4b )
!
!   THE ROUTINE RETURNS THE nsvd LARGEST SINGULAR VALUES AND THE ASSOCIATED LEFT
!   AND RIGHT SINGULAR VECTORS, WHICH FULFILLS THE PRESET TOLERANCE SPECIFIED IN ARGUMENT
!   relerr.
!
!   ON EXIT OF rsvd_cmp_fixed_precision :
!
!       relerr CONTAINS THE RELATIVE ERROR IN FROBENIUS NORM OF THE COMPUTED PARTIAL SVD.
!
!       POINTER singval CONTAINS THE nsvd = size(singval) LARGEST SINGULAR VALUES OF a
!       IN DECREASING ORDER.
!
!       POINTER leftvec CONTAINS THE ASSOCIATED nsvd LEFT SINGULAR VECTORS
!       STORED COLUMNWISE.
!   
!       POINTER rightvec CONTAINS THE ASSOCIATED nsvd RIGHT SINGULAR VECTORS,
!       STORED COLUMNWISE.
!
!       failure_relerr = false : INDICATES SUCCESSFUL EXIT AND THE COMPUTED PARTIAL
!       SVD FULFILLS THE REQUESTED RELATIVE ERROR SPECIFIED ON ENTRY IN THE ARGUMENT relerr.
!
!       failure_relerr = true  : INDICATES THAT THE COMPUTED PARTIAL SVD HAS A RELATIVE ERROR
!       LARGER THAN THE REQUESTED RELATIVE ERROR. THIS MEANS THAT THE REQUESTED ACCURACY TOLERANCE
!       FOR THE RELATIVE ERROR IS TOO SMALL (I.E., relerr < 2 * sqrt( epsilon( relerr )/relerr )
!       OR THAT THE INPUT PARAMETERS blk_size AND/OR maxiter_qb HAVE A TOO SMALL VALUE (E.G., THE
!       PRODUCT blk_size*maxiter_qb SETS THE MAXIMUM ALLOWABLE RANK FOR THE PARTIAL SVD, WHICH IS SOUGHT),
!       GIVEN THE DISTRIBUTION OF THE SINGULAR VALUES OF mat, AND MUST BE INCREASED TO FULLFILL THE PRESET
!       ACCURACY TOLERANCE FOR THE RELATIVE ERROR OF THE PARTIAL SVD APPROXIMATION.
!
!       failure = false : INDICATES SUCCESSFUL EXIT AND AN ACCURATE APPROXIMATION OF THE SINGULAR TRIPLETS
!
!       failure = true  : INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                         THAT FULL ACCURACY WAS NOT ATTAINED IN THE RANDOMIZED
!                         SUBSPACE ITERATIONS. THE RESULTS CAN BE STILL USEFUL, ESPECIALLY
!                         IF failure_relerr = false IS FALSE ON EXIT, BUT THE
!                         APPROXIMATIONS OF THE TOP nsvd SINGULAR TRIPLETS
!                         CAN BE POOR.
!
!   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 )
!
!   GET THE RANK OF THE COMPUTED PARTIAL SVD.
!
    nsvd = size( singval )
!
!   COMPUTE THE TRUE RELATIVE ERROR.
!
    relerr2 = sqrt(sum( (singval0(nsvd+1_i4b:nsvd0)/norma)**2 ))
!
!   COMPUTE ERROR BETWEEN THE TRUE AND ESTIMATED RELATIVE ERRORS.
!
    err = abs( relerr - relerr2 )
!
!   TEST ACCURACY OF THE SINGULAR TRIPLETS IF REQUIRED.
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( res(m,nsvd), id(nsvd,nsvd), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*v(:m,:nsvd) - u(:n,:nsvd)*diag(singval(:nsvd)),
!       WHERE u AND v ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a.
!
        res(:m,:nsvd) = matmul(a,rightvec) - leftvec*spread(singval(:nsvd),dim=1,ncopies=m)
        id(:nsvd,1_i4b) = norm( res(:m,:nsvd), dim=2_i4b )
!
        if ( norma==zero ) then
            norma = one
        end if
!
        err1 = maxval( id(:nsvd,1_i4b) )/( norma*real(mn,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u(:n,:nsvd)**(t)*u(:n,:nsvd).
!
        call unit_matrix( id(:nsvd,:nsvd) )
!
        res(:nsvd,:nsvd) = abs( id(:nsvd,:nsvd) - matmul( transpose(leftvec), leftvec ) )
!
        err2 = maxval( res(:nsvd,:nsvd) )/real(m,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - v(:m,:nsvd)**(t)*v(:m,:nsvd).
!
        res(:nsvd,:nsvd) = abs( id(:nsvd,:nsvd) - matmul( transpose(rightvec), rightvec ) )
!
        err3 = maxval( res(:nsvd,:nsvd) )/real(n,stnd)
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( res, id )
!
    end if
!
!   DEALLOCATE WORK ARRAYS AND POINTERS.
!
    deallocate( a, singval0, singval, leftvec, rightvec )
!
!   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
!
    if ( failure_relerr ) then
!
        write (prtunit,*) 
        write (prtunit,*) 'Fail to converge within ', maxiter_qb,   &
                          ' iterations! ||A-rSVD||_F / ||A||_F = ', relerr, ' >= ', relerr0
        write (prtunit,*) 
!
    else
!
        write (prtunit,*) 
        write (prtunit,*) 'Converge within less than ', maxiter_qb ,' iterations! ||A-rSVD||_F / ||A||_F = ', &
                          relerr, ' < ', relerr0
        write (prtunit,*) 
!
    end if
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing approximate ', nsvd, ' singular values and vectors of a ', &
       m, ' by ', n,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_rsvd_cmp_fixed_precision
! ===========================================
!
end program ex1_rsvd_cmp_fixed_precision

ex1_rtsw.F90

program ex1_rtsw
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of functions RTSW and TIME_TO_STRING
!   in module Time_Procedures .
!                                                                              
! LATEST REVISION : 06/07/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, extd, rtsw, time_to_string
!   
!
! STRONG TYPING IMPOSED
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT.
!
    integer(i4b), parameter :: prtunit=6
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(extd)   :: tim1, tim2
!
    integer(i4b)  :: i, j
!
    character(len=13) :: string
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of rtsw'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   FUNCTION rtsw CAN BE USED TO COMPUTE THE TIME LAPSE BETWEEN
!   FUNCTIONS CALLS ACCORDING TO THE SYSTEM (WALL) CLOCK.
!
!   FUNCTION rtsw OBTAINS, FROM THE INTRINSIC ROUTINE DATE_AND_TIME,
!   THE CURRENT DATE AND TIME. THESE VALUES ARE THEN CONVERTED TO SECONDS 
!   AND RETURNED AS AN EXTENDED PRECISION REAL VALUE.
!
!   THIS FUNCTION WORKS ACROSS MONTH AND YEAR BOUNDARIES, BUT WILL NOT WORK
!   PROPERLY WITH OPENMP (USE FUNCTION elapsed_time IN THIS CASE).
!
!   SINCE THIS ROUTINE USES THE SYSTEM CLOCK, THE ELAPSED TIME COMPUTED
!   WITH THIS ROUTINE MAY NOT (PROBABLY WON'T BE IN A MULTI-TASKING OS)
!   AN ACCURATE REFLECTION OF THE NUMBER OF CPU CYCLES REQUIRED TO
!   PERFORM A CALCULATION. THEREFORE CARE SHOULD BE EXERCISED WHEN
!   USING THIS TO PROFILE A CODE.
!
!   A TYPICAL USE OF THIS FUNCTION IS AS FOLLOWS :
!
    tim1 = rtsw()
    j    = 0
    do i=1, 1000000000
        j = j + 1
    end do
    tim2 = rtsw()
!
!   CONVERT THE ELAPSED TIME tim2-tim1 TO A STRING FORMAT FOR PRINTING AS
!
!           'milliseconds.seconds.minutes.hours'
!
!   WITH SUBROUTINE time_to_string .
!
    string = time_to_string( tim2-tim1 )
!
!   PRINT THE RESULT.
!
    write (prtunit, *)  " Elapsed Time (s): " // string //  " => milliseconds.seconds.minutes.hours "
!
!
! END OF PROGRAM ex1_rtsw
! =======================
!
end program ex1_rtsw

ex1_select_eigval_cmp.F90

program ex1_select_eigval_cmp
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SELECT_EIGVAL_CMP
!   in module Eig_Procedures.
!                                                                              
! LATEST REVISION : 20/01/2020
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, select_eigval_cmp, &
                         trid_inviter, merror, allocate_error, norm, 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 MATRIX AND m IS THE NUMBER
! OF THE COMPUTED EIGENVALUES/EIGENVECTORS
!
    integer(i4b), parameter :: prtunit=6, n=2000, m=100
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of select_eigval_cmp'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, eps, elapsed_time
    real(stnd), dimension(:), allocatable   :: d, res
    real(stnd), dimension(:,:), allocatable :: a, a2, eigvec, d_e
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: maxiter=2
!
    logical(lgl) :: failure, failure2, do_test, small
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : PARTIAL EIGENVALUES/EIGENVECTORS DECOMPOSITION OF A n-BY-n REAL
!               SYMMETRIC MATRIX USING A RATIONAL QR ALGORITHM FOR THE EIGENVALUES
!               AND THE INVERSE ITERATION TECHNIQUE FOR THE EIGENVECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
!
    err = zero
    do_test = true
!
!   DETERMINE IF YOU WANT TO COMPUTE THE m SMALLEST OR LARGEST EIGENVALUES.
!
    small = false
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), eigvec(n,m), d(m), d_e(n,2), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM DATA MATRIX AND FROM IT
!   A SELF-ADJOINT MATRIX a .
!
    call random_number( a )
    a = a + transpose( a ) 
!
    if ( do_test ) then
!
        allocate( a2(n,n), res(m), 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 )
!
!   COMPUTE THE FIRST m LARGEST OR SMALLEST EIGENVALUES OF THE SELF-ADJOINT MATRIX a
!   AND SAVE THE INTERMEDIATE TRIDIAGONAL MATRIX IN PARAMETER d_e .
!
    call select_eigval_cmp( a(:n,:n), d(:m), small, failure, d_e=d_e )
!
    if ( .not. failure ) then
!
!       COMPUTE THE ASSOCIATED m EIGENVECTORS OF THE SELF-ADJOINT MATRIX a BY
!       maxiter INVERSE ITERATIONS ON THE INTERMEDIATE TRIDIAGONAL MATRIX
!       d_e AND BACK-TRANSFORMATION.
!
        call trid_inviter( d_e(:n,1), d_e(:n,2), d(:m), eigvec(:n,:m), failure2,     &
                           mat=a(:n,:n), maxiter=maxiter )
!
    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 ( do_test .and. .not.failure ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*eigvec - eigvec*d
!       WHERE d ARE THE EIGENVALUES AND eigvec THE EIGENVECTORS OF a.
!
        a(:n,:m) = matmul( a2(:n,:n), eigvec(:n,:m)) - eigvec(:n,:m)*spread( d(:m), dim=1, ncopies=n)
        res(:m) = norm( a(:n,:m), dim=2_i4b )
!
        err1 = maxval( res(:m) )/( norm( a2 )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - eigvec**(t)*eigvec.
!
        call unit_matrix( a(:m,:m) )
!
        a2(:m,:m) = abs( a(:m,:m) - matmul( transpose(eigvec(:n,:m)), eigvec(: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, eigvec, d_e, d, a2, res )
!
    else
!
        deallocate( a, eigvec, d_e, d )
!
    end if
!
    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
!
    if ( do_test  .and. .not.failure ) then
        write (prtunit,*) 
        write (prtunit,*) 'Accuracy of the computed eigenvalues/eigenvectors couplets = ', err1
        write (prtunit,*) 'Orthogonality of the computed eigenvectors                 = ', err2
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,a,i5,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_select_eigval_cmp
! ====================================
!
end program ex1_select_eigval_cmp

ex1_select_eigval_cmp2.F90

program ex1_select_eigval_cmp2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SELECT_EIGVAL_CMP2
!   in module Eig_Procedures.
!                                                                              
! LATEST REVISION : 20/01/2020
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, two, c50, allocate_error,   &
                         merror, norm, get_diag, select_eigval_cmp2, trid_inviter,      &
                         norm, 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 MATRIX.
!
    integer(i4b), parameter :: prtunit=6, n=1000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of select_eigval_cmp2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, eps, val, elapsed_time
    real(stnd), pointer ,    dimension(:)   :: d
    real(stnd), allocatable, dimension(:)   :: res
    real(stnd), allocatable, dimension(:,:) :: eigvec, a, a2, d_e
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: m, maxiter=2
!
    logical(lgl) :: failure, failure2, do_test, small
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : PARTIAL EIGENVALUES/EIGENVECTORS DECOMPOSITION OF A n-BY-n REAL
!               SYMMETRIC MATRIX USING A RATIONAL QR ALGORITHM FOR THE EIGENVALUES
!               AND THE INVERSE ITERATION TECHNIQUE FOR THE EIGENVECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
!
    err = zero
    do_test = true
!
!   DETERMINE IF YOU WANT TO COMPUTE THE m SMALLEST OR LARGEST EIGENVALUES.
!
    small = false
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), d_e(n,2), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM DATA MATRIX AND FROM IT
!   A SEMI-POSITIVE MATRIX a2 .
!
    call random_number( a )
    a = matmul( a, transpose( a ) )
!
    if ( do_test ) then
!
        allocate( a2(n,n), res(m), 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
!
!   DETERMINE TRESHOLD FOR THE SUM OF THE EIGENVALUES.
!
    val = sum( get_diag(a) )/two
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   COMPUTE THE LARGEST OR SMALLEST m EIGENVALUES OF THE SELF-ADJOINT MATRIX a 
!   IN ALGEBRAIC VALUE WHOSE SUM EXCEEDS val AND SAVE THE INTERMEDIATE 
!   TRIDIAGONAL MATRIX IN PARAMETER d_e .
!
    call select_eigval_cmp2( a, d, small, val, failure, d_e=d_e )
!
!   DETERMINE THE NUMBER OF COMPUTED EIGENVALUES AND ALLOCATE WORK ARRAY FOR
!   COMPUTING THE ASSOCIATED EIGENVECTORS .
!
    m = size( d )
!
    allocate( eigvec(n,m), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
    if ( .not. failure ) then
!
!       COMPUTE THE ASSOCIATED m EIGENVECTORS OF THE SELF-ADJOINT MATRIX a BY
!       maxiter INVERSE ITERATIONS ON THE INTERMEDIATE TRIDIAGONAL MATRIX
!       d_e AND BACK-TRANSFORMATION.
!
        call trid_inviter( d_e(:n,1), d_e(:n,2), d(:m), eigvec(:n,:m), failure2,     &
                           mat=a(:n,:n), maxiter=maxiter )
!
    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 ( do_test .and. .not.failure ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*eigvec - eigvec*d
!       WHERE d ARE THE EIGENVALUES AND eigvec THE EIGENVECTORS OF a.
!
        a(:n,:m) = matmul( a2(:n,:n), eigvec(:n,:m)) - eigvec(:n,:m)*spread( d(:m), dim=1, ncopies=n)
        res(:m) = norm( a(:n,:m), dim=2_i4b )
!
        err1 = maxval( res(:m) )/( norm( a2 )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - eigvec**(t)*eigvec.
!
        call unit_matrix( a(:m,:m) )
!
        a2(:m,:m) = abs( a(:m,:m) - matmul( transpose(eigvec(:n,:m)), eigvec(: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, eigvec, d_e, d, a2, res )
!
    else
!
        deallocate( a, eigvec, d_e, d )
!
    end if
!
    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
!
    if ( do_test  .and. .not.failure ) then
        write (prtunit,*) 
        write (prtunit,*) 'Accuracy of the computed eigenvalues/eigenvectors couplets = ', err1
        write (prtunit,*) 'Orthogonality of the computed eigenvectors                 = ', err2
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,a,i5,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_select_eigval_cmp2
! =====================================
!
end program ex1_select_eigval_cmp2

ex1_select_eigval_cmp3.F90

program ex1_select_eigval_cmp3
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SELECT_EIGVAL_CMP3
!   in module Eig_Procedures.
!                                                                              
! LATEST REVISION : 20/01/2020
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, select_eigval_cmp3, trid_inviter, &
                         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 MATRIX AND
! le IS THE NUMBER OF THE WANTED EIGENVALUES/EIGENVECTORS
!
    integer(i4b), parameter :: prtunit=6, n=3000, le=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of select_eigval_cmp3'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, eps, elapsed_time
    real(stnd), dimension(:),   allocatable :: eigval, res
    real(stnd), dimension(:,:), allocatable :: a, a2, eigvec, d_e
!
    integer(i4b) :: maxiter=4, neig
    integer      :: iok, istart, iend, irate, imax, itime
!
    logical(lgl) :: failure, failure2, do_test, small
!   
    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 : PARTIAL EIGENVALUES/EIGENVECTORS DECOMPOSITION OF A n-BY-n REAL
!               SYMMETRIC MATRIX USING A BISECTION ALGORITHM FOR THE EIGENVALUES
!               AND THE INVERSE ITERATION TECHNIQUE FOR THE EIGENVECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
!
    err = zero
    do_test = true
!
!   DETERMINE IF YOU WANT TO COMPUTE THE m SMALLEST OR LARGEST EIGENVALUES.
!
    small = false
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), eigval(n), d_e(n,2), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM DATA MATRIX AND FROM IT
!   A SELF-ADJOINT MATRIX a .
!
    call random_number( a )
    a = a + transpose( a ) 
!
    if ( do_test ) then
!
        allocate( a2(n,n), res(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 )
!
!   COMPUTE THE FIRST le EIGENVALUES OF THE SELF-ADJOINT MATRIX a BY BISECTION AND SAVE
!   THE INTERMEDIATE TRIDIAGONAL MATRIX IN PARAMETER d_e .
!
    call select_eigval_cmp3( a, neig, eigval, small, failure, sort=sort, le=le, d_e=d_e )
!
    if ( .not. failure .and. neig>0  ) then
!
!       ALLOCATE WORK ARRAY NEEDED TO STORE THE EIGENVECTORS.
!
        allocate( eigvec(n,neig), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE THE ASSOCIATED neig EIGENVECTORS OF THE SELF-ADJOINT MATRIX a BY
!       maxiter INVERSE ITERATIONS ON THE INTERMEDIATE TRIDIAGONAL MATRIX
!       d_e AND BACK-TRANSFORMATION.
!
        call trid_inviter( d_e(:n,1), d_e(:n,2), eigval(:neig), eigvec, failure2,     &
                           mat=a, maxiter=maxiter )
!
    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 ( do_test .and. .not.failure .and. neig>0 ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*eigvec - eigvec*d
!       WHERE eigval ARE THE EIGENVALUES AND eigvec THE EIGENVECTORS OF a.
!
        a(:n,:neig) = matmul( a2(:n,:n), eigvec(:n,:neig)) - eigvec(:n,:neig)*spread( eigval(:neig), dim=1, ncopies=n)
        res(:neig)  = norm( a(:n,:neig), dim=2_i4b )
!
        err1 = maxval( res(:neig) )/( norm( a2 )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - eigvec**(t)*eigvec.
!
        call unit_matrix( a(:neig,:neig) )
!
        a2(:neig,:neig) = abs( a(:neig,:neig) - matmul( transpose(eigvec(:n,:neig)), eigvec(:n,:neig) ) )
!
        err2 = maxval( a2(:neig,:neig) )/real(n,stnd)
!
        err = max( err1, err2 )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( do_test ) then
!
        deallocate( a, d_e, eigval, a2, res )
!
    else
!
        deallocate( a, d_e, eigval )
!
    end if
!
    if ( allocated( eigvec ) )  deallocate( eigvec )
!
    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
!
    if ( do_test  .and. .not.failure .and. neig>0 ) then
        write (prtunit,*) 
        write (prtunit,*) 'Accuracy of the computed eigenvalues/eigenvectors couplets = ', err1
        write (prtunit,*) 'Orthogonality of the computed eigenvectors                 = ', err2
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', neig, ' eigenvalues and eigenvectors of a ', &
       n, ' by ', n,' real symmetric matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_select_eigval_cmp3
! =====================================
!
end program ex1_select_eigval_cmp3

ex1_select_singval_cmp.F90

program ex1_select_singval_cmp
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SELECT_SINGVAL_CMP
!   in module SVD_Procedures.
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine BD_INVITER2 in module SVD_Procedures.
!                                                                              
! LATEST REVISION : 25/10/2019
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c0_9, c1_5, c50, lamch, bd_inviter2, &
                         select_singval_cmp, merror, allocate_error, norm, 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
!
    integer(i4b), parameter :: prtunit=6, n=3000, m=3000, mn=min(m,n), ls=100
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of select_singval_cmp'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, err3, eps, abstol, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, a2, leftvec, rightvec, resid, rla
    real(stnd), dimension(:),   allocatable :: s, d, e, tauo, tauq, taup, resid2
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: maxiter=2, nsing, mnthr, mnthr_nsing
!
    logical(lgl) :: failure1, failure2, gen_q, do_test, two_stage
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : PARTIAL SVD OF A n-BY-m REAL MATRIX USING THE CHAN-GOLUB-REINSCH
!               BIDIAGONAL REDUCTION ALGORITHM, A BISECTION ALGORITHM FOR
!               SINGULAR VALUES AND THE INVERSE ITERATION TECHNIQUE FOR
!               SINGULAR VECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps    = fudge*epsilon( err )
    abstol = sqrt( lamch('S') )
    err    = zero
!
!   SPECIFY IF NUMERICAL TESTS ARE PERFORMED.
!
    do_test = true
!
!   CHOOSE TUNING PARAMETERS FOR THE ALGORITHM.
!
!   DETERMINE CROSSOVER POINT FOR THE SVD WHEN REDUCING
!   a TO BIDIAGONAL FORM. IF max(n,m) EXCEEDS mnthr ,
!   A QR OR LQ FACTORIZATION IS USED FIRST TO REDUCE THE
!   n-BY-m MATRIX a TO A TRIANGULAR FORM.
!    
    mnthr = int( real( mn, stnd )*c1_5, i4b )
!
    two_stage = max( n, m )>=mnthr
!    two_stage = true
!    two_stage = false
!
!   DETERMINE CROSSOVER POINT FOR THE BACK-TRANSFORMATION
!   ALGORITHM WHEN COMPUTING SINGULAR VECTORS. IF max(n,m)
!   EXCEEDS mnthr (E.G. A PRELIMINARY QR OR QL IS DONE) AND ls
!   EXCEEDS mnthr_nsing, THE ORTHOGONAL MATRIX q OF THE QR OR
!   QL FACTORIZATION IS GENERATED AND THE SINGULAR VECTORS
!   ARE COMPUTED BY A MATRIX MULTIPLICATION.
!
    mnthr_nsing = int( real( mn, stnd )*c0_9, i4b )
!
    gen_q = ls>=mnthr_nsing .and. two_stage
!    gen_q = true
!    gen_q = false
!
!   ALLOCATE WORK ARRAYS.
!
    if ( two_stage ) then
        if ( gen_q ) then
            allocate( a(n,m), rla(mn,mn), s(mn), d(mn), e(mn), &
                      tauq(mn), taup(mn), stat=iok )
        else
            allocate( a(n,m), rla(mn,mn), s(mn), d(mn), e(mn), &
                      tauo(mn), tauq(mn), taup(mn), stat=iok )
        end if
    else
        allocate( a(n,m), s(mn), d(mn), e(mn), tauq(mn), taup(mn), stat=iok )
    end if
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-BY-m RANDOM REAL MATRIX a.
!
    call random_number( a )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( a2(n,m), resid(n,mn), resid2(mn), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       MAKE A COPY OF THE RANDOM DATA MATRIX .
!
        a2(:n,:m) = a(:n,:m)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL n-BY-m MATRIX a
!   IS WRITTEN
!
!                       a = U * S * V**(t)
!
!   WHERE S IS AN n-BY-m MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   min(m,n) DIAGONAL ELEMENTS, U IS AN n-BY-n ORTHOGONAL MATRIX, AND
!   V IS AN m-BY-m 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.
!
!   THIS PROGRAM ILLUSTRATES HOW TO COMPUTE THE ls LARGEST SINGULAR VALUES OF a AND THE
!   ASSOCIATED LEFT AND RIGHT SINGULAR VECTORS OF a (EG A PARTIAL SVD DECOMPOSITION OF a)
!   IN TWO STEPS:
!
!   STEP1 : COMPUTE THE ls LARGEST SINGULAR VALUES OF a BY THE GOLUB AND REINSCH
!   BIDIAGONAL REDUCTION ALGORITHM APPLIED TO a, A BISECTION METHOD APPLIED TO THE
!   GOLUB-KAHAN TRIDIAGONAL FORM OF THE RESULTING BIDIAGONAL MATRIX AND STORE INTERMEDIATE
!   RESULTS WITH SUBROUTINE select_singval_cmp.
!
!   THE OPTIONAL ARGUMENT ls OF select_singval_cmp MAY BE USED TO DETERMINE HOW MANY
!   SINGULAR VALUES MUST BE COMPUTED.
!
!   THE OPTIONAL ARGUMENT abstol OF select_singval_cmp MAY BE USED TO SET THE REQUIRED
!   PRECISION FOR THE SINGULAR VALUES. A SINGULAR VALUE IS CONSIDERED TO BE LOCATED
!   IF IT HAS BEEN DETERMINED TO LIE IN AN INTERVAL WHOSE WIDTH IS EQUAL OR LESS
!   THAN abstol. SINGULAR VALUES WILL BE COMPUTED MOST ACCURATELY WHEN abstol IS SET
!   TO THE SQUARE ROOT OF THE UNDERFLOW THRESHOLD (EG sqrt(LAMCH('S')) ).
!
    if ( two_stage ) then
!
!       STEP1A : REDUCE THE MATRIX a TO BIDIAGONAL FORM BY A TWO-STAGE ALGORITHM.
!       THE MATRIX a IS FIRST REDUCED TO TRIANGULAR FORM BY A QR OR LQ FACTORIZATION
!       IN A FIRST STAGE. THE TRIANGULAR MATRIX IS REDUCED TO BIDIAGONAL FORM IN A
!       SECOND STAGE.
!       THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!       THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM IN THE TWO-STAGE 
!       ALGORITHM ARE STORED IN a, rla, tauo, tauq AND taup.
!
        if ( gen_q ) then
!
            call select_singval_cmp( a, rla, nsing, s, failure=failure1, sort=sort, d=d, e=e, &
                                     ls=ls, abstol=abstol, tauq=tauq, taup=taup )
!
        else
!
            call select_singval_cmp( a, rla, nsing, s, failure=failure1, sort=sort, d=d, e=e, &
                                     ls=ls, abstol=abstol, tauo=tauo, tauq=tauq, taup=taup )
!
        end if
!
    else
!
!       STEP1B : REDUCE THE MATRIX a TO BIDIAGONAL FORM WITHOUT A QR OR LQ FACTORIZATION.
!       THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!       THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM
!       ARE STORED IN a, tauq, taup.
!
        call select_singval_cmp( a, nsing, s, failure=failure1, sort=sort, d=d, e=e, &
                                 ls=ls, abstol=abstol, tauq=tauq, taup=taup )
!
    end if
!
!   ON EXIT OF select_singval_cmp :
!
!   failure= false :  INDICATES SUCCESSFUL EXIT
!   failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                     THAT FULL ACCURACY WAS NOT ATTAINED IN THE
!                     COMPUTATION OF THE SINGULAR VALUES OF a.
!
!   THE SINGULAR VALUES ARE STORED IN s IN DECREASING ORDER (IF sort='d').
!
!   THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!   THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM d_e
!   ARE STORED IN PACKED FORM IN a, tauq, taup AND ALSO rla AND tauo IF A
!   TWO-STAGE ALGORITHM HAS BEEN USED.
!
!   nsing GIVES THE NUMBER OF SINGULAR VALUES REALLY COMPUTED BY select_singval_cmp.
!   nsing MAY BE GREATER THAN ls IF CLUSTERS OF SINGULAR VALUES ARE PRESENT.
!   THE nsing LARGEST SINGULAR VALUES ARE STORED IN THE FIRST nsing POSITIONS OF s
!   IN DECREASING ORDER IF sort='d'.
!
!   STEP2 : COMPUTE THE nsing ASSOCIATED SINGULAR VALUES OF a BY INVERSE ITERATION
!   WITH SUBROUTINE bd_inviter2 :
!
    if ( nsing>0 ) then
!
!       ALLOCATE WORK VARIABLES NEEDED TO STORE THE SINGULAR VECTORS.
!
        allocate( leftvec(n,nsing),    &
                  rightvec(m,nsing),   &
                  stat = iok    )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE THE FIRST nsing LEFT AND RIGHT SINGULAR VECTORS OF a BY maxiter
!       INVERSE ITERATIONS ON THE INTERMEDIATE BIDIAGONAL MATRIX
!       d_e AND BACK-TRANSFORMATION WITH SUBROUTINE bd_inviter2 .
!
!       ON ENTRY, PARAMETER s CONTAINS SELECTED SINGULAR VALUES OF THE BIDIAGONAL MATRIX d_e (OR a).
!       THE SINGULAR VALUES MUST BE GIVEN IN DECREASING ORDER.
!
        if ( two_stage ) then
!
            if ( gen_q ) then
!
                call bd_inviter2( a, tauq, taup, rla, d, e, s(:nsing), leftvec, rightvec, &
                                 failure=failure2, maxiter=maxiter )
!
            else
!
                call bd_inviter2( a, tauq, taup, rla, d, e, s(:nsing), leftvec, rightvec,  &
                                  failure=failure2, tauo=tauo, maxiter=maxiter )
!
            end if
!
        else
!
            call bd_inviter2( a, tauq, taup, d, e, s(:nsing), leftvec, rightvec,   &
                              failure=failure2, maxiter=maxiter )
!
        end if
!
!       ON EXIT OF bd_inviter2 :
!
!       failure= false :  INDICATES SUCCESSFUL EXIT
!       failure= true  :  INDICATES THAT THE ALGORITHM FAILS TO CONVERGE
!
!       THE SINGULAR VECTORS OF THE BIDIAGONAL FORM d_e ARE COMPUTED USING maxiter INVERSE ITERATIONS
!       FOR ALL THE SINGULAR VALUES AT ONE STEP. THE SINGULAR VECTORS OF d_e ARE THEN ORTHOGONALIZED BY 
!       THE MODIFIED GRAM-SCHMIDT ALGORITHM IF THE SINGULAR VALUES ARE NOT WELL SEPARATED.
!       THE SINGULAR VECTORS OF a ARE FINALLY COMPUTED BY BACK TRANSFORMATIONS.
!       ON EXIT, leftvec AND rightvec CONTAIN THE FIRST nsing LEFT AND RIGHT SINGULAR VECTORS OF a, RESPECTIVELY.
!
!       bd_inviter2 MAY FAIL IF SOME THE SINGULAR VALUES SPECIFIED IN PARAMETER s ARE NEARLY
!       IDENTICAL FOR SOME PATHOLOGICAL MATRICES.
!
    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 ( do_test .and. nsing>0 ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*v(:m,:nsing) - u(:n,:nsing)*s(:nsing,:nsing),
!       WHERE u AND v ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a.
!
        resid(:n,:nsing) = matmul(a2,rightvec) - leftvec*spread(s(:nsing),dim=1,ncopies=n)
        resid2(:nsing) = norm( resid(:n,:nsing), dim=2_i4b )
!
        err1 = maxval( resid2(:nsing) )/( norm( a2 )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u(:n,:nsing)**(t)*u(:n,:nsing).
!
        call unit_matrix( a2(:nsing,:nsing) )
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(leftvec), leftvec ) )
!
        err2 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - v(:m,:nsing)**(t)*v(:m,:nsing).
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(rightvec), rightvec ) )
!
        err3 = maxval( resid(:nsing,:nsing) )/real(m,stnd)
!
        err = max( err1, err2, err3 )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( do_test ) then
!
        deallocate( a2, resid, resid2 )
!
    end if
!
    if ( nsing>0 ) then
!
        deallocate( a, s, d, e, tauq, taup, leftvec, rightvec )
!
    else
!
        deallocate( a, s, d, e, tauq, taup )
!
    end if
!
    if ( two_stage ) then
!
        if ( gen_q ) then
            deallocate( rla )
        else
            deallocate( rla, tauo )
        end if
!
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. .not.failure1 .and. .not.failure2 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test .and. nsing>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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', nsing, ' singular values and vectors of a ', &
       n, ' by ', m,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_select_singval_cmp
! =====================================
!
end program ex1_select_singval_cmp

ex1_select_singval_cmp2.F90

program ex1_select_singval_cmp2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SELECT_SINGVAL_CMP2
!   in module SVD_Procedures.
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine BD_INVITER2 in module SVD_Procedures.
!                                                                              
! LATEST REVISION : 25/10/2019
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c0_9, c1_5, c50, lamch, bd_inviter2,   &
                         select_singval_cmp2, merror, allocate_error, norm, 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
!
    integer(i4b), parameter :: prtunit=6, n=3000, m=3000, mn=min(m,n), ls=10
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of select_singval_cmp2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, err3, eps, abstol, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, a2, leftvec, rightvec, resid, rla
    real(stnd), dimension(:),   allocatable :: s, d, e, tauo, tauq, taup, resid2
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: maxiter=2, nsing, mnthr, mnthr_nsing
!
    logical(lgl) :: failure1, failure2, gen_q, do_test, two_stage
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : PARTIAL SVD OF A n-BY-m REAL MATRIX USING THE CHAN-GOLUB-REINSCH
!               BIDIAGONAL REDUCTION ALGORITHM, A BISECTION ALGORITHM FOR
!               SINGULAR VALUES AND THE INVERSE ITERATION TECHNIQUE FOR
!               SINGULAR VECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps    = fudge*epsilon( err )
    abstol = sqrt( lamch('S') )
    err    = zero
!
!   SPECIFY IF NUMERICAL TESTS ARE PERFORMED.
!
    do_test = false
!
!   CHOOSE TUNING PARAMETERS FOR THE ALGORITHM.
!
!   DETERMINE CROSSOVER POINT FOR THE SVD WHEN REDUCING
!   a TO BIDIAGONAL FORM. IF max(n,m) EXCEEDS mnthr ,
!   A QR OR LQ FACTORIZATION IS USED FIRST TO REDUCE THE
!   n-BY-m MATRIX a TO A TRIANGULAR FORM.
!    
    mnthr = int( real( mn, stnd )*c1_5, i4b )
!
    two_stage = max( n, m )>=mnthr
!    two_stage = true
!    two_stage = false
!
!   DETERMINE CROSSOVER POINT FOR THE BACK-TRANSFORMATION
!   ALGORITHM WHEN COMPUTING SINGULAR VECTORS. IF max(n,m)
!   EXCEEDS mnthr (E.G. A PRELIMINARY QR OR QL IS DONE) AND ls
!   EXCEEDS mnthr_nsing, THE ORTHOGONAL MATRIX q OF THE QR OR
!   QL FACTORIZATION IS GENERATED AND THE SINGULAR VECTORS
!   ARE COMPUTED BY A MATRIX MULTIPLICATION.
!
    mnthr_nsing = int( real( mn, stnd )*c0_9, i4b )
!
    gen_q = ls>=mnthr_nsing .and. two_stage
!    gen_q = true
!    gen_q = false
!
!   ALLOCATE WORK ARRAYS.
!
    if ( two_stage ) then
        if ( gen_q ) then
            allocate( a(n,m), rla(mn,mn), s(mn), d(mn), e(mn), &
                      tauq(mn), taup(mn), stat=iok )
        else
            allocate( a(n,m), rla(mn,mn), s(mn), d(mn), e(mn), &
                      tauo(mn), tauq(mn), taup(mn), stat=iok )
        end if
    else
        allocate( a(n,m), s(mn), d(mn), e(mn), tauq(mn), taup(mn), stat=iok )
    end if
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-BY-m RANDOM REAL MATRIX a.
!
    call random_number( a )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( a2(n,m), resid(n,mn), resid2(mn), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       MAKE A COPY OF THE RANDOM DATA MATRIX .
!
        a2(:n,:m) = a(:n,:m)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL n-BY-m MATRIX a
!   IS WRITTEN
!
!                       a = U * S * V**(t)
!
!   WHERE S IS AN n-BY-m MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   min(m,n) DIAGONAL ELEMENTS, U IS AN n-BY-n ORTHOGONAL MATRIX, AND
!   V IS AN m-BY-m 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.
!
!   THIS PROGRAM ILLUSTRATES HOW TO COMPUTE THE ls LARGEST SINGULAR VALUES OF a AND THE
!   ASSOCIATED LEFT AND RIGHT SINGULAR VECTORS OF a (EG A PARTIAL SVD DECOMPOSITION OF a)
!   IN TWO STEPS:
!
!   STEP1 : COMPUTE THE ls LARGEST SINGULAR VALUES OF a BY THE GOLUB AND REINSCH
!   BIDIAGONAL REDUCTION ALGORITHM APPLIED TO a, A BISECTION METHOD APPLIED TO THE
!   RESULTING BIDIAGONAL MATRIX AND STORE INTERMEDIATE RESULTS WITH SUBROUTINE
!   select_singval_cmp2.
!
!   THE OPTIONAL ARGUMENT ls OF select_singval_cmp2 MAY BE USED TO DETERMINE HOW MANY
!   SINGULAR VALUES MUST BE COMPUTED.
!
!   THE OPTIONAL ARGUMENT abstol OF select_singval_cmp2 MAY BE USED TO SET THE REQUIRED
!   PRECISION FOR THE SINGULAR VALUES. A SINGULAR VALUE IS CONSIDERED TO BE LOCATED
!   IF IT HAS BEEN DETERMINED TO LIE IN AN INTERVAL WHOSE WIDTH IS EQUAL OR LESS
!   THAN abstol. SINGULAR VALUES WILL BE COMPUTED MOST ACCURATELY WHEN abstol IS SET
!   TO THE SQUARE ROOT OF THE UNDERFLOW THRESHOLD (EG sqrt(LAMCH('S')) ).
!
!   select_singval_cmp2 IS FASTER THAN select_singval_cmp, BUT MAY BE LESS ACCURATE FOR SOME
!   MATRICES.
!
    if ( two_stage ) then
!
!       STEP1A : REDUCE THE MATRIX a TO BIDIAGONAL FORM BY A TWO-STAGE ALGORITHM.
!       THE MATRIX a IS FIRST REDUCED TO TRIANGULAR FORM BY A QR OR LQ FACTORIZATION
!       IN A FIRST STAGE. THE TRIANGULAR MATRIX IS REDUCED TO BIDIAGONAL FORM IN A
!       SECOND STAGE.
!       THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!       THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM IN THE TWO-STAGE 
!       ALGORITHM ARE STORED IN a, rla, tauo, tauq AND taup.
!
        if ( gen_q ) then
!
            call select_singval_cmp2( a, rla, nsing, s, failure=failure1, sort=sort, d=d, e=e, &
                                      ls=ls, abstol=abstol, tauq=tauq, taup=taup )
!
        else
!
            call select_singval_cmp2( a, rla, nsing, s, failure=failure1, sort=sort, d=d, e=e, &
                                      ls=ls, abstol=abstol, tauo=tauo, tauq=tauq, taup=taup )
!
        end if
!
    else
!
!       STEP1B : REDUCE THE MATRIX a TO BIDIAGONAL FORM WITHOUT A QR OR LQ FACTORIZATION.
!       THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!       THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM
!       ARE STORED IN a, tauq, taup.
!
        call select_singval_cmp2( a, nsing, s, failure=failure1, sort=sort, d=d, e=e, &
                                  ls=ls, abstol=abstol, tauq=tauq, taup=taup )
!
    end if
!
!   ON EXIT OF select_singval_cmp2 :
!
!   failure= false :  INDICATES SUCCESSFUL EXIT
!   failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                      THAT FULL ACCURACY WAS NOT ATTAINED IN THE
!                      COMPUTATION OF THE SINGULAR VALUES OF a.
!
!   THE SINGULAR VALUES ARE STORED IN s IN DECREASING ORDER (IF sort='d').
!
!   THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!   THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM d_e
!   ARE STORED IN PACKED FORM IN a, tauq, taup AND ALSO rla AND tauo IF A
!   TWO-STAGE ALGORITHM HAS BEEN USED.
!
!   nsing GIVES THE NUMBER OF SINGULAR VALUES REALLY COMPUTED BY select_singval_cmp2.
!   nsing MAY BE GREATER THAN ls IF CLUSTERS OF SINGULAR VALUES ARE PRESENT.
!   THE nsing LARGEST SINGULAR VALUES ARE STORED IN THE FIRST nsing POSITIONS OF s
!   IN DECREASING ORDER IF sort='d'.
!
!   STEP2 : COMPUTE THE nsing ASSOCIATED SINGULAR VALUES OF a BY INVERSE ITERATION WITH SUBROUTINE
!   bd_inviter2 :
!
    if ( nsing>0 ) then
!
!       ALLOCATE WORK VARIABLES NEEDED TO STORE THE SINGULAR VECTORS.
!
        allocate( leftvec(n,nsing),    &
                  rightvec(m,nsing),   &
                  stat = iok    )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE THE FIRST nsing LEFT AND RIGHT SINGULAR VECTORS OF a BY maxiter
!       INVERSE ITERATIONS ON THE INTERMEDIATE BIDIAGONAL MATRIX
!       d_e AND BACK-TRANSFORMATION WITH SUBROUTINE bd_inviter2 .
!
!       ON ENTRY, PARAMETER s CONTAINS SELECTED SINGULAR VALUES OF THE BIDIAGONAL MATRIX d_e (OR a).
!       THE SINGULAR VALUES MUST BE GIVEN IN DECREASING ORDER.
!
        if ( two_stage ) then
!
            if ( gen_q ) then
!
                call bd_inviter2( a, tauq, taup, rla, d, e, s(:nsing), leftvec, rightvec, &
                                 failure=failure2, maxiter=maxiter )
!
            else
!
                call bd_inviter2( a, tauq, taup, rla, d, e, s(:nsing), leftvec, rightvec,  &
                                  failure=failure2, tauo=tauo, maxiter=maxiter )
!
            end if
!
        else
!
            call bd_inviter2( a, tauq, taup, d, e, s(:nsing), leftvec, rightvec,   &
                              failure=failure2, maxiter=maxiter )
!
        end if
!
!       ON EXIT OF bd_inviter2 :
!
!       failure= false :  INDICATES SUCCESSFUL EXIT
!       failure= true  :  INDICATES THAT THE ALGORITHM FAILS TO CONVERGE
!
!       THE SINGULAR VECTORS OF THE BIDIAGONAL FORM d_e ARE COMPUTED USING maxiter INVERSE ITERATIONS
!       FOR ALL THE SINGULAR VALUES AT ONE STEP. THE SINGULAR VECTORS OF d_e ARE THEN ORTHOGONALIZED BY 
!       THE MODIFIED GRAM-SCHMIDT ALGORITHM IF THE SINGULAR VALUES ARE NOT WELL SEPARATED.
!       THE SINGULAR VECTORS OF a ARE FINALLY COMPUTED BY BACK TRANSFORMATIONS.
!       ON EXIT, leftvec AND rightvec CONTAIN THE FIRST nsing SINGULAR VECTORS OF a .
!
!       bd_inviter2 MAY FAIL IF SOME THE SINGULAR VALUES SPECIFIED IN PARAMETER s ARE NEARLY
!       IDENTICAL FOR SOME PATHOLOGICAL MATRICES.
!
    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 ( do_test .and. nsing>0 ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*V(:m,:nsing) - U(:n,:nsing)*S(:nsing,:nsing),
!       WHERE leftvec AND rightvec ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a.
!
        resid(:n,:nsing) = matmul(a2,rightvec) - leftvec*spread(s(:nsing),dim=1,ncopies=n)
        resid2(:nsing) = norm( resid(:n,:nsing), dim=2_i4b )
!
        err1 = maxval( resid2(:nsing) )/ ( norm( a2 )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U(:n,:nsing)**(t)*U(:n,:nsing).
!
        call unit_matrix( a2(:nsing,:nsing) )
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(leftvec), leftvec ) )
!
        err2 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - V(:m,:nsing)**(t)*V(:m,:nsing).
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(rightvec), rightvec ) )
        err3 = maxval( resid(:nsing,:nsing) )/real(m,stnd)
!
        err = max( err1, err2, err3 )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( do_test ) then
!
        deallocate( a2, resid, resid2 )
!
    end if
!
    if ( nsing>0 ) then
!
        deallocate( leftvec, rightvec )
!
    end if
!
!
    if ( two_stage ) then
!
        if ( gen_q ) then
            deallocate( a, rla, s, d, e, tauq, taup )
        else
            deallocate( a, rla, s, d, e, tauo, tauq, taup )
        end if
!
    else
!
        deallocate( a, s, d, e, tauq, taup )
!
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. .not.failure1 .and. .not.failure2 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test .and. nsing>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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', nsing, ' singular values and vectors of a ', &
       n, ' by ', m,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_select_singval_cmp2
! ======================================
!
end program ex1_select_singval_cmp2

ex1_select_singval_cmp3.F90

program ex1_select_singval_cmp3
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SELECT_SINGVAL_CMP3
!   in module SVD_Procedures.
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine BD_INVITER2 in module SVD_Procedures.
!                                                                              
! LATEST REVISION : 25/10/2019
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c0_9, c1_5, c50, lamch, bd_inviter2,  &
                         select_singval_cmp3, merror, allocate_error, norm, 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
!
    integer(i4b), parameter :: prtunit=6, n=3000, m=3000, ls=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of select_singval_cmp3'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, err3, eps, abstol, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, a2, p, leftvec, rightvec, resid, ra
    real(stnd), dimension(:),   allocatable :: s, d, e, tauo, resid2
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: maxiter=2, nsing, mnthr, mnthr_nsing
!
    logical(lgl) :: failure1, failure2, gen_p, gen_q, do_test, two_stage
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : PARTIAL SVD OF A n-BY-m REAL MATRIX WITH n>=m USING THE RHALA-BARLOW
!               ONE-SIDED BIDIAGONAL REDUCTION ALGORITHM, A BISECTION ALGORITHM FOR
!               SINGULAR VALUES AND THE INVERSE ITERATION TECHNIQUE FOR SINGULAR VECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps    = fudge*epsilon( err )
    abstol = sqrt( lamch('S') )
    err    = zero
!
!   SPECIFY IF NUMERICAL TESTS ARE PERFORMED.
!
    do_test = true
!
!   CHOOSE TUNING PARAMETERS FOR THE ALGORITHM.
!
!   DETERMINE CROSSOVER POINT FOR THE SVD WHEN REDUCING
!   a TO BIDIAGONAL FORM. IF n EXCEEDS mnthr ,
!   A QR FACTORIZATION IS USED FIRST TO REDUCE THE
!   n-BY-m MATRIX a TO A TRIANGULAR FORM.
!    
    mnthr = int( real( m, stnd )*c1_5, i4b )
!
    two_stage = n>=mnthr
!    two_stage = true
!    two_stage = false
!
!   DETERMINE CROSSOVER POINT FOR THE BACK-TRANSFORMATION
!   ALGORITHM WHEN COMPUTING RIGHT SINGULAR VECTORS. IF
!   ls EXCEEDS mnthr_nsing, THE RIGHT ORTHOGONAL MATRIX p
!   OF THE ONE-SIDED BIDIAGONAL REDUCTION ALGORITHM IS GENERATED
!   AND BACK-TRANSFORMATION IS DONE BY A MATRIX MULTIPLICATION.
!
    mnthr_nsing = int( real( m, stnd )*c0_9, i4b )
!
    gen_p = ls>=mnthr_nsing
!    gen_p = true
!    gen_p = false
!
!   DETERMINE CROSSOVER POINT FOR THE BACK-TRANSFORMATION
!   ALGORITHM WHEN COMPUTING LEFT SINGULAR VECTORS. IF n
!   EXCEEDS mnthr (E.G. A PRELIMINARY QR IS DONE) AND ls
!   EXCEEDS mnthr_nsing, THE ORTHOGONAL MATRIX q OF THE QR
!   FACTORIZATION IS GENERATED AND THE LEFT SINGULAR VECTORS
!   ARE COMPUTED BY A MATRIX MULTIPLICATION.
!
    gen_q = ls>=mnthr_nsing .and. two_stage
!    gen_q = true
!    gen_q = false
!
!   ALLOCATE WORK ARRAYS.
!
    if ( two_stage ) then
        if ( gen_q ) then
            allocate( a(n,m), ra(m,m), s(m), d(m), e(m), p(m,m), stat=iok )
        else
            allocate( a(n,m), ra(m,m), s(m), d(m), e(m), tauo(m), p(m,m), stat=iok )
        end if
    else
        allocate( a(n,m), s(m), d(m), e(m), p(m,m), stat=iok )
    end if
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-BY-m RANDOM REAL MATRIX a.
!
    call random_number( a )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( a2(n,m), resid(n,m), 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,:m) = a(:n,:m)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL n-BY-m MATRIX a
!   IS WRITTEN
!
!                       a = U * S * V**(t)
!
!   WHERE S IS AN n-BY-m MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   min(m,n) DIAGONAL ELEMENTS, U IS AN n-BY-n ORTHOGONAL MATRIX, AND
!   V IS AN m-BY-m 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.
!
!   THIS PROGRAM ILLUSTRATES HOW TO COMPUTE THE ls LARGEST SINGULAR VALUES OF a AND THE
!   ASSOCIATED LEFT AND RIGHT SINGULAR VECTORS OF a (EG A PARTIAL SVD DECOMPOSITION OF a)
!   IN TWO STEPS:
!
!   STEP1 : COMPUTE THE ls LARGEST SINGULAR VALUES OF a BY THE RHALA-BARLOW ONE-SIDED
!   BIDIAGONAL REDUCTION ALGORITHM APPLIED TO a, A BISECTION METHOD APPLIED TO THE
!   GOLUB-KAHAN TRIDIAGONAL FORM OF THE RESULTING BIDIAGONAL MATRIX AND STORE INTERMEDIATE
!   RESULTS WITH SUBROUTINE select_singval_cmp3.
!
!   THE OPTIONAL ARGUMENT ls OF select_singval_cmp3 MAY BE USED TO DETERMINE HOW MANY
!   SINGULAR VALUES MUST BE COMPUTED.
!
!   THE OPTIONAL ARGUMENT abstol OF select_singval_cmp3 MAY BE USED TO SET THE REQUIRED
!   PRECISION FOR THE SINGULAR VALUES. A SINGULAR VALUE IS CONSIDERED TO BE LOCATED
!   IF IT HAS BEEN DETERMINED TO LIE IN AN INTERVAL WHOSE WIDTH IS EQUAL OR LESS
!   THAN abstol. SINGULAR VALUES WILL BE COMPUTED MOST ACCURATELY WHEN abstol IS SET
!   TO THE SQUARE ROOT OF THE UNDERFLOW THRESHOLD (EG sqrt(LAMCH('S')) ).
!
    if ( two_stage ) then
!
!       STEP1A : REDUCE THE MATRIX a TO BIDIAGONAL FORM BY A TWO-STAGE ALGORITHM.
!       THE MATRIX a IS FIRST REDUCED TO TRIANGULAR FORM BY A QR FACTORIZATION
!       IN A FIRST STAGE. THE TRIANGULAR MATRIX IS REDUCED TO BIDIAGONAL FORM IN A
!       SECOND STAGE.
!       THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!       THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM IN THE TWO-STAGE 
!       ALGORITHM ARE STORED IN a, ra, tauo AND p.
!
        if ( gen_q ) then
!
            call select_singval_cmp3( a, ra, nsing, s, failure=failure1, sort=sort, d=d, e=e, &
                                      ls=ls, abstol=abstol, p=p, gen_p=gen_p )
!
        else
!
            call select_singval_cmp3( a, ra, nsing, s, failure=failure1, sort=sort, d=d, e=e, &
                                      ls=ls, abstol=abstol, tauo=tauo, p=p, gen_p=gen_p )
!
        end if
!
    else
!
!       STEP1B : REDUCE THE MATRIX a TO BIDIAGONAL FORM WITHOUT A QR OR LQ FACTORIZATION.
!       THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!       THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM ARE STORED IN a AND p .
!
        call select_singval_cmp3( a, nsing, s, failure=failure1, sort=sort, d=d, e=e, &
                                  ls=ls, abstol=abstol, p=p, gen_p=gen_p )
!
    end if
!
!   ON EXIT OF select_singval_cmp3 :
!
!   failure= false :  INDICATES SUCCESSFUL EXIT
!   failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                     THAT FULL ACCURACY WAS NOT ATTAINED IN THE
!                     COMPUTATION OF THE SINGULAR VALUES OF a.
!
!   THE SINGULAR VALUES ARE STORED IN s IN DECREASING ORDER (IF sort='d').
!
!   nsing GIVES THE NUMBER OF SINGULAR VALUES REALLY COMPUTED BY select_singval_cmp3.
!   nsing MAY BE GREATER THAN ls IF CLUSTERS OF SINGULAR VALUES ARE PRESENT.
!   THE nsing LARGEST SINGULAR VALUES ARE STORED IN THE FIRST nsing POSITIONS OF s
!   IN DECREASING ORDER IF sort='d'.
!
!   STEP2 : COMPUTE THE nsing ASSOCIATED SINGULAR VALUES OF a BY INVERSE ITERATION
!   WITH SUBROUTINE bd_inviter2 :
!
    if ( nsing>0 ) then
!
!       ALLOCATE WORK VARIABLES NEEDED TO STORE THE SINGULAR VECTORS.
!
        allocate( leftvec(n,nsing),    &
                  rightvec(m,nsing),   &
                  stat = iok    )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE THE FIRST nsing LEFT AND RIGHT SINGULAR VECTORS OF a BY maxiter
!       INVERSE ITERATIONS ON THE INTERMEDIATE BIDIAGONAL MATRIX
!       d_e AND BACK-TRANSFORMATION WITH SUBROUTINE bd_inviter2 .
!
!       ON ENTRY, PARAMETER s CONTAINS SELECTED SINGULAR VALUES OF THE BIDIAGONAL MATRIX d_e (OR a).
!       THE SINGULAR VALUES MUST BE GIVEN IN DECREASING ORDER.
!
        if ( two_stage ) then
!
            if ( gen_q ) then
!
                call bd_inviter2( a, ra, p, d, e, s(:nsing), leftvec, rightvec,  &
                                  failure=failure2, maxiter=maxiter   )
!
            else
!
                call bd_inviter2( a, ra, p, d, e, s(:nsing), leftvec, rightvec,  &
                                  failure=failure2, tauo=tauo, maxiter=maxiter   )
!
            end if
!
        else
!
            call bd_inviter2( a, p, d, e, s(:nsing), leftvec, rightvec,  &
                              failure=failure2, maxiter=maxiter )
!
        end if
!
!       ON EXIT OF bd_inviter2 :
!
!       failure= false :  INDICATES SUCCESSFUL EXIT
!       failure= true  :  INDICATES THAT THE ALGORITHM FAILS TO CONVERGE
!
!       THE SINGULAR VECTORS OF THE BIDIAGONAL FORM d_e ARE COMPUTED USING maxiter INVERSE ITERATIONS
!       FOR ALL THE SINGULAR VALUES AT ONE STEP. THE SINGULAR VECTORS OF d_e ARE THEN ORTHOGONALIZED BY 
!       THE MODIFIED GRAM-SCHMIDT ALGORITHM IF THE SINGULAR VALUES ARE NOT WELL SEPARATED.
!       THE SINGULAR VECTORS OF a ARE FINALLY COMPUTED BY BACK TRANSFORMATIONS OR MATRIX MULTIPLICATIONS.
!       ON EXIT, leftvec AND rightvec CONTAIN THE FIRST nsing LEFT AND RIGHT SINGULAR VECTORS OF a, RESPECTIVELY.
!
!       bd_inviter2 MAY FAIL IF SOME THE SINGULAR VALUES SPECIFIED IN PARAMETER s ARE NEARLY
!       IDENTICAL FOR SOME PATHOLOGICAL MATRICES.
!
    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 ( do_test .and. nsing>0 ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*v(:m,:nsing) - u(:n,:nsing)*s(:nsing,:nsing),
!       WHERE u AND v ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a.
!
        resid(:n,:nsing) = matmul(a2,rightvec) - leftvec*spread(s(:nsing),dim=1,ncopies=n)
        resid2(:nsing) = norm( resid(:n,:nsing), dim=2_i4b )
!
        err1 = maxval( resid2(:nsing) )/( norm( a2 )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u(:n,:nsing)**(t)*u(:n,:nsing).
!
        call unit_matrix( a2(:nsing,:nsing) )
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(leftvec), leftvec ) )
!
        err2 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - v(:m,:nsing)**(t)*v(:m,:nsing).
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(rightvec), rightvec ) )
!
        err3 = maxval( resid(:nsing,:nsing) )/real(m,stnd)
!
        err = max( err1, err2, err3 )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( do_test ) then
!
        deallocate( a2, resid, resid2 )
!
    end if
!
    if ( nsing>0 ) then
!
        deallocate( a, s, d, e, p, leftvec, rightvec )
!
    else
!
        deallocate( a, s, d, e, p )
!
    end if
!
    if ( two_stage ) then
!
        if ( gen_q ) then
            deallocate( ra )
        else
            deallocate( ra, tauo )
        end if
!
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. .not.failure1 .and. .not.failure2 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test .and. nsing>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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', nsing, ' singular values and vectors of a ', &
       n, ' by ', m,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_select_singval_cmp3
! ======================================
!
end program ex1_select_singval_cmp3

ex1_select_singval_cmp3_bis.F90

program ex1_select_singval_cmp3
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SELECT_SINGVAL_CMP3
!   in module SVD_Procedures.
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine BD_INVITER2 in module SVD_Procedures.
!                                                                              
! LATEST REVISION : 25/10/2019
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c0_9, c50, lamch, bd_inviter2,   &
                         select_singval_cmp3, merror, allocate_error, norm, 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
!
    integer(i4b), parameter :: prtunit=6, n=3000, m=3000, ls=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of select_singval_cmp3'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, err3, eps, abstol, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, a2, p, leftvec, rightvec, resid, ra
    real(stnd), dimension(:),   allocatable :: s, d, e, tauo, resid2
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: maxiter=2, nsing, mnthr_nsing
!
    logical(lgl) :: failure1, failure2, gen_p, do_test
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : PARTIAL SVD OF A n-BY-m REAL MATRIX WITH n>=m USING THE RHALA-BARLOW
!               ONE-SIDED BIDIAGONAL REDUCTION ALGORITHM, A BISECTION ALGORITHM FOR
!               SINGULAR VALUES AND THE INVERSE ITERATION TECHNIQUE FOR SINGULAR VECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps    = fudge*epsilon( err )
    abstol = sqrt( lamch('S') )
    err    = zero
!
!   SPECIFY IF NUMERICAL TESTS ARE PERFORMED.
!
    do_test = true
!
!   CHOOSE TUNING PARAMETERS FOR THE ALGORITHM.
!
!   DETERMINE CROSSOVER POINT FOR THE BACK-TRANSFORMATION
!   ALGORITHM WHEN COMPUTING RIGHT SINGULAR VECTORS. IF
!   ls EXCEEDS mnthr_nsing, THE RIGHT ORTHOGONAL MATRIX p
!   OF THE ONE-SIDED BIDIAGONAL REDUCTION ALGORITHM IS GENERATED
!   AND BACK-TRANSFORMATION IS DONE BY A MATRIX MULTIPLICATION.
!
    mnthr_nsing = int( real( m, stnd )*c0_9, i4b )
!
    gen_p = ls>=mnthr_nsing
!    gen_p = true
!    gen_p = false
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,m), s(m), d(m), e(m), p(m,m), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-BY-m RANDOM REAL MATRIX a.
!
    call random_number( a )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( a2(n,m), resid(n,m), 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,:m) = a(:n,:m)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL n-BY-m MATRIX a
!   IS WRITTEN
!
!                       a = U * S * V**(t)
!
!   WHERE S IS AN n-BY-m MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   min(m,n) DIAGONAL ELEMENTS, U IS AN n-BY-n ORTHOGONAL MATRIX, AND
!   V IS AN m-BY-m 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.
!
!   THIS PROGRAM ILLUSTRATES HOW TO COMPUTE THE ls LARGEST SINGULAR VALUES OF a AND THE
!   ASSOCIATED LEFT AND RIGHT SINGULAR VECTORS OF a (EG A PARTIAL SVD DECOMPOSITION OF a)
!   IN TWO STEPS:
!
!   STEP1 : COMPUTE THE ls LARGEST SINGULAR VALUES OF a BY THE RHALA-BARLOW ONE-SIDED
!   BIDIAGONAL REDUCTION ALGORITHM APPLIED TO a, A BISECTION METHOD APPLIED TO THE
!   GOLUB-KAHAN TRIDIAGONAL FORM OF THE RESULTING BIDIAGONAL MATRIX AND STORE INTERMEDIATE
!   RESULTS WITH SUBROUTINE select_singval_cmp3.
!
!   THE OPTIONAL ARGUMENT ls OF select_singval_cmp3 MAY BE USED TO DETERMINE HOW MANY
!   SINGULAR VALUES MUST BE COMPUTED.
!
!   THE OPTIONAL ARGUMENT abstol OF select_singval_cmp3 MAY BE USED TO SET THE REQUIRED
!   PRECISION FOR THE SINGULAR VALUES. A SINGULAR VALUE IS CONSIDERED TO BE LOCATED
!   IF IT HAS BEEN DETERMINED TO LIE IN AN INTERVAL WHOSE WIDTH IS EQUAL OR LESS
!   THAN abstol. SINGULAR VALUES WILL BE COMPUTED MOST ACCURATELY WHEN abstol IS SET
!   TO THE SQUARE ROOT OF THE UNDERFLOW THRESHOLD (EG sqrt(LAMCH('S')) ).
!
    call select_singval_cmp3( a, nsing, s, failure=failure1, sort=sort, d=d, e=e, &
                              ls=ls, abstol=abstol, p=p, gen_p=gen_p )
!
!   ON EXIT OF select_singval_cmp3 :
!
!   failure= false :  INDICATES SUCCESSFUL EXIT
!   failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                     THAT FULL ACCURACY WAS NOT ATTAINED IN THE
!                     COMPUTATION OF THE SINGULAR VALUES OF a.
!
!   THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!   THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM ARE STORED IN a AND p .
!
!   THE SINGULAR VALUES ARE STORED IN s IN DECREASING ORDER (IF sort='d').
!
!   nsing GIVES THE NUMBER OF SINGULAR VALUES REALLY COMPUTED BY select_singval_cmp3.
!   nsing MAY BE GREATER THAN ls IF CLUSTERS OF SINGULAR VALUES ARE PRESENT.
!   THE nsing LARGEST SINGULAR VALUES ARE STORED IN THE FIRST nsing POSITIONS OF s
!   IN DECREASING ORDER IF sort='d'.
!
!   STEP2 : COMPUTE THE nsing ASSOCIATED SINGULAR VALUES OF a BY INVERSE ITERATION
!   WITH SUBROUTINE bd_inviter2 :
!
    if ( nsing>0 ) then
!
!       ALLOCATE WORK VARIABLES NEEDED TO STORE THE SINGULAR VECTORS.
!
        allocate( leftvec(n,nsing),    &
                  rightvec(m,nsing),   &
                  stat = iok    )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE THE FIRST nsing LEFT AND RIGHT SINGULAR VECTORS OF a BY maxiter
!       INVERSE ITERATIONS ON THE INTERMEDIATE BIDIAGONAL MATRIX
!       d_e AND BACK-TRANSFORMATION WITH SUBROUTINE bd_inviter2 .
!
!       ON ENTRY, PARAMETER s CONTAINS SELECTED SINGULAR VALUES OF THE BIDIAGONAL MATRIX d_e (OR a).
!       THE SINGULAR VALUES MUST BE GIVEN IN DECREASING ORDER.
!
        call bd_inviter2( a, p, d, e, s(:nsing), leftvec, rightvec,  &
                          failure=failure2, maxiter=maxiter )
!
!       ON EXIT OF bd_inviter2 :
!
!       failure= false :  INDICATES SUCCESSFUL EXIT
!       failure= true  :  INDICATES THAT THE ALGORITHM FAILS TO CONVERGE
!
!       THE SINGULAR VECTORS OF THE BIDIAGONAL FORM d_e ARE COMPUTED USING maxiter INVERSE ITERATIONS
!       FOR ALL THE SINGULAR VALUES AT ONE STEP. THE SINGULAR VECTORS OF d_e ARE THEN ORTHOGONALIZED BY 
!       THE MODIFIED GRAM-SCHMIDT ALGORITHM IF THE SINGULAR VALUES ARE NOT WELL SEPARATED.
!       THE SINGULAR VECTORS OF a ARE FINALLY COMPUTED BY BACK TRANSFORMATIONS OR MATRIX MULTIPLICATIONS.
!       ON EXIT, leftvec AND rightvec CONTAIN THE FIRST nsing LEFT AND RIGHT SINGULAR VECTORS OF a, RESPECTIVELY.
!
!       bd_inviter2 MAY FAIL IF SOME THE SINGULAR VALUES SPECIFIED IN PARAMETER s ARE NEARLY
!       IDENTICAL FOR SOME PATHOLOGICAL MATRICES.
!
    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 ( do_test .and. nsing>0 ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*v(:m,:nsing) - u(:n,:nsing)*s(:nsing,:nsing),
!       WHERE u AND v ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a.
!
        resid(:n,:nsing) = matmul(a2,rightvec) - leftvec*spread(s(:nsing),dim=1,ncopies=n)
        resid2(:nsing) = norm( resid(:n,:nsing), dim=2_i4b )
!
        err1 = maxval( resid2(:nsing) )/( norm( a2 )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u(:n,:nsing)**(t)*u(:n,:nsing).
!
        call unit_matrix( a2(:nsing,:nsing) )
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(leftvec), leftvec ) )
!
        err2 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - v(:m,:nsing)**(t)*v(:m,:nsing).
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(rightvec), rightvec ) )
!
        err3 = maxval( resid(:nsing,:nsing) )/real(m,stnd)
!
        err = max( err1, err2, err3 )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( do_test ) then
!
        deallocate( a2, resid, resid2 )
!
    end if
!
    if ( nsing>0 ) then
!
        deallocate( a, s, d, e, p, leftvec, rightvec )
!
    else
!
        deallocate( a, s, d, e, p )
!
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. .not.failure1 .and. .not.failure2 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test .and. nsing>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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', nsing, ' singular values and vectors of a ', &
       n, ' by ', m,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_select_singval_cmp3
! ======================================
!
end program ex1_select_singval_cmp3

ex1_select_singval_cmp4.F90

program ex1_select_singval_cmp4
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SELECT_SINGVAL_CMP4
!   in module SVD_Procedures.
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine BD_INVITER2 in module SVD_Procedures.
!                                                                              
! LATEST REVISION : 25/10/2019
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c0_9, c1_5, c50, lamch, bd_inviter2,  &
                         select_singval_cmp4, merror, allocate_error, norm, 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
!
    integer(i4b), parameter :: prtunit=6, n=3000, m=3000, ls=10
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of select_singval_cmp4'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, err3, eps, abstol, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, a2, p, leftvec, rightvec, resid, ra
    real(stnd), dimension(:),   allocatable :: s, d, e, tauo, resid2
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: maxiter=2, nsing, mnthr, mnthr_nsing
!
    logical(lgl) :: failure1, failure2, gen_p, gen_q, do_test, two_stage
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : PARTIAL SVD OF A n-BY-m REAL MATRIX WITH n>=m USING THE RHALA-BARLOW
!               ONE-SIDED BIDIAGONAL REDUCTION ALGORITHM, A BISECTION ALGORITHM FOR
!               SINGULAR VALUES AND THE INVERSE ITERATION TECHNIQUE FOR SINGULAR VECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps    = fudge*epsilon( err )
    abstol = sqrt( lamch('S') )
    err    = zero
!
!   SPECIFY IF NUMERICAL TESTS ARE PERFORMED.
!
    do_test = false
!
!   CHOOSE TUNING PARAMETERS FOR THE ALGORITHM.
!
!   DETERMINE CROSSOVER POINT FOR THE SVD WHEN REDUCING
!   a TO BIDIAGONAL FORM. IF n EXCEEDS mnthr ,
!   A QR FACTORIZATION IS USED FIRST TO REDUCE THE
!   n-BY-m MATRIX a TO A TRIANGULAR FORM.
!    
    mnthr = int( real( m, stnd )*c1_5, i4b )
!
    two_stage = n>=mnthr
!    two_stage = true
!    two_stage = false
!
!   DETERMINE CROSSOVER POINT FOR THE BACK-TRANSFORMATION
!   ALGORITHM WHEN COMPUTING RIGHT SINGULAR VECTORS. IF
!   ls EXCEEDS mnthr_nsing, THE RIGHT ORTHOGONAL MATRIX p
!   OF THE ONE-SIDED BIDIAGONAL REDUCTION ALGORITHM IS GENERATED
!   AND BACK-TRANSFORMATION IS DONE BY A MATRIX MULTIPLICATION.
!
    mnthr_nsing = int( real( m, stnd )*c0_9, i4b )
!
    gen_p = ls>=mnthr_nsing
!    gen_p = true
!    gen_p = false
!
!   DETERMINE CROSSOVER POINT FOR THE BACK-TRANSFORMATION
!   ALGORITHM WHEN COMPUTING LEFT SINGULAR VECTORS. IF n
!   EXCEEDS mnthr (E.G. A PRELIMINARY QR IS DONE) AND ls
!   EXCEEDS mnthr_nsing, THE ORTHOGONAL MATRIX q OF THE QR
!   FACTORIZATION IS GENERATED AND THE LEFT SINGULAR VECTORS
!   ARE COMPUTED BY A MATRIX MULTIPLICATION.
!
    gen_q = ls>=mnthr_nsing .and. two_stage
!    gen_q = true
!    gen_q = false
!
!   ALLOCATE WORK ARRAYS.
!
    if ( two_stage ) then
        if ( gen_q ) then
            allocate( a(n,m), ra(m,m), s(m), d(m), e(m), p(m,m), stat=iok )
        else
            allocate( a(n,m), ra(m,m), s(m), d(m), e(m), tauo(m), p(m,m), stat=iok )
        end if
    else
        allocate( a(n,m), s(m), d(m), e(m), p(m,m), stat=iok )
    end if
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-BY-m RANDOM REAL MATRIX a.
!
    call random_number( a )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( a2(n,m), resid(n,m), 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,:m) = a(:n,:m)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL n-BY-m MATRIX a
!   IS WRITTEN
!
!                       a = U * S * V**(t)
!
!   WHERE S IS AN n-BY-m MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   min(m,n) DIAGONAL ELEMENTS, U IS AN n-BY-n ORTHOGONAL MATRIX, AND
!   V IS AN m-BY-m 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.
!
!   THIS PROGRAM ILLUSTRATES HOW TO COMPUTE THE ls LARGEST SINGULAR VALUES OF a AND THE
!   ASSOCIATED LEFT AND RIGHT SINGULAR VECTORS OF a (EG A PARTIAL SVD DECOMPOSITION OF a)
!   IN TWO STEPS:
!
!   STEP1 : COMPUTE THE ls LARGEST SINGULAR VALUES OF a BY THE RHALA-BARLOW ONE-SIDED
!   BIDIAGONAL REDUCTION ALGORITHM APPLIED TO a, A BISECTION METHOD APPLIED TO THE
!   THE RESULTING BIDIAGONAL MATRIX AND STORE INTERMEDIATE RESULTS WITH SUBROUTINE
!   select_singval_cmp4.
!
!   THE OPTIONAL ARGUMENT ls OF select_singval_cmp4 MAY BE USED TO DETERMINE HOW MANY
!   SINGULAR VALUES MUST BE COMPUTED.
!
!   THE OPTIONAL ARGUMENT abstol OF select_singval_cmp4 MAY BE USED TO SET THE REQUIRED
!   PRECISION FOR THE SINGULAR VALUES. A SINGULAR VALUE IS CONSIDERED TO BE LOCATED
!   IF IT HAS BEEN DETERMINED TO LIE IN AN INTERVAL WHOSE WIDTH IS EQUAL OR LESS
!   THAN abstol. SINGULAR VALUES WILL BE COMPUTED MOST ACCURATELY WHEN abstol IS SET
!   TO THE SQUARE ROOT OF THE UNDERFLOW THRESHOLD (EG sqrt(LAMCH('S')) ).
!
!   select_singval_cmp4 IS FASTER THAN select_singval_cmp3, BUT MAY BE LESS ACCURATE
!   FOR SOME MATRICES.
!
    if ( two_stage ) then
!
!       STEP1A : REDUCE THE MATRIX a TO BIDIAGONAL FORM BY A TWO-STAGE ALGORITHM.
!       THE MATRIX a IS FIRST REDUCED TO TRIANGULAR FORM BY A QR FACTORIZATION
!       IN A FIRST STAGE. THE TRIANGULAR MATRIX IS REDUCED TO BIDIAGONAL FORM IN A
!       SECOND STAGE.
!       THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!       THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM IN THE TWO-STAGE 
!       ALGORITHM ARE STORED IN a, ra, tauo AND p.
!
        if ( gen_q ) then
!
            call select_singval_cmp4( a, ra, nsing, s, failure=failure1, sort=sort, d=d, e=e, &
                                      ls=ls, abstol=abstol, p=p, gen_p=gen_p )
!
        else
!
            call select_singval_cmp4( a, ra, nsing, s, failure=failure1, sort=sort, d=d, e=e, &
                                      ls=ls, abstol=abstol, tauo=tauo, p=p, gen_p=gen_p )
!
        end if
!
    else
!
!       STEP1B : REDUCE THE MATRIX a TO BIDIAGONAL FORM WITHOUT A QR OR LQ FACTORIZATION.
!       THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!       THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM ARE STORED IN a AND p .
!
        call select_singval_cmp4( a, nsing, s, failure=failure1, sort=sort, d=d, e=e, &
                                  ls=ls, abstol=abstol, p=p, gen_p=gen_p )
!
    end if
!
!   ON EXIT OF select_singval_cmp4 :
!
!   failure= false :  INDICATES SUCCESSFUL EXIT
!   failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                     THAT FULL ACCURACY WAS NOT ATTAINED IN THE
!                     COMPUTATION OF THE SINGULAR VALUES OF a.
!
!   THE SINGULAR VALUES ARE STORED IN s IN DECREASING ORDER (IF sort='d').
!
!   nsing GIVES THE NUMBER OF SINGULAR VALUES REALLY COMPUTED BY select_singval_cmp4.
!   nsing MAY BE GREATER THAN ls IF CLUSTERS OF SINGULAR VALUES ARE PRESENT.
!   THE nsing LARGEST SINGULAR VALUES ARE STORED IN THE FIRST nsing POSITIONS OF s
!   IN DECREASING ORDER IF sort='d'.
!
!   STEP2 : COMPUTE THE nsing ASSOCIATED SINGULAR VALUES OF a BY INVERSE ITERATION
!   WITH SUBROUTINE bd_inviter2 :
!
    if ( nsing>0 ) then
!
!       ALLOCATE WORK VARIABLES NEEDED TO STORE THE SINGULAR VECTORS.
!
        allocate( leftvec(n,nsing),    &
                  rightvec(m,nsing),   &
                  stat = iok    )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE THE FIRST nsing LEFT AND RIGHT SINGULAR VECTORS OF a BY maxiter
!       INVERSE ITERATIONS ON THE INTERMEDIATE BIDIAGONAL MATRIX
!       d_e AND BACK-TRANSFORMATION WITH SUBROUTINE bd_inviter2 .
!
!       ON ENTRY, PARAMETER s CONTAINS SELECTED SINGULAR VALUES OF THE BIDIAGONAL MATRIX d_e (OR a).
!       THE SINGULAR VALUES MUST BE GIVEN IN DECREASING ORDER.
!
!
        if ( two_stage ) then
!
            if ( gen_q ) then
!
                call bd_inviter2( a, ra, p, d, e, s(:nsing), leftvec, rightvec,  &
                                  failure=failure2, maxiter=maxiter   )
!
            else
!
                call bd_inviter2( a, ra, p, d, e, s(:nsing), leftvec, rightvec,  &
                                  failure=failure2, tauo=tauo, maxiter=maxiter   )
!
            end if
!
        else
!
            call bd_inviter2( a, p, d, e, s(:nsing), leftvec, rightvec,  &
                              failure=failure2, maxiter=maxiter )
!
        end if
!
!       ON EXIT OF bd_inviter2 :
!
!       failure= false :  INDICATES SUCCESSFUL EXIT
!       failure= true  :  INDICATES THAT THE ALGORITHM FAILS TO CONVERGE
!
!       THE SINGULAR VECTORS OF THE BIDIAGONAL FORM d_e ARE COMPUTED USING maxiter INVERSE ITERATIONS
!       FOR ALL THE SINGULAR VALUES AT ONE STEP. THE SINGULAR VECTORS OF d_e ARE THEN ORTHOGONALIZED BY 
!       THE MODIFIED GRAM-SCHMIDT ALGORITHM IF THE SINGULAR VALUES ARE NOT WELL SEPARATED.
!       THE SINGULAR VECTORS OF a ARE FINALLY COMPUTED BY BACK TRANSFORMATIONS OR MATRIX MULTIPLICATIONS.
!       ON EXIT, leftvec AND rightvec CONTAIN THE FIRST nsing LEFT AND RIGHT SINGULAR VECTORS OF a, RESPECTIVELY.
!
!       bd_inviter2 MAY FAIL IF SOME THE SINGULAR VALUES SPECIFIED IN PARAMETER s ARE NEARLY
!       IDENTICAL FOR SOME PATHOLOGICAL MATRICES.
!
    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 ( do_test .and. nsing>0 ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*v(:m,:nsing) - u(:n,:nsing)*s(:nsing,:nsing),
!       WHERE u AND v ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a.
!
        resid(:n,:nsing) = matmul(a2,rightvec) - leftvec*spread(s(:nsing),dim=1,ncopies=n)
        resid2(:nsing) = norm( resid(:n,:nsing), dim=2_i4b )
!
        err1 = maxval( resid2(:nsing) )/( norm( a2 )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u(:n,:nsing)**(t)*u(:n,:nsing).
!
        call unit_matrix( a2(:nsing,:nsing) )
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(leftvec), leftvec ) )
!
        err2 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - v(:m,:nsing)**(t)*v(:m,:nsing).
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(rightvec), rightvec ) )
!
        err3 = maxval( resid(:nsing,:nsing) )/real(m,stnd)
!
        err = max( err1, err2, err3 )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( do_test ) then
!
        deallocate( a2, resid, resid2 )
!
    end if
!
    if ( nsing>0 ) then
!
        deallocate( a, s, d, e, p, leftvec, rightvec )
!
    else
!
        deallocate( a, s, d, e, p )
!
    end if
!
    if ( two_stage ) then
!
        if ( gen_q ) then
            deallocate( ra )
        else
            deallocate( ra, tauo )
        end if
!
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. .not.failure1 .and. .not.failure2 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test .and. nsing>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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', nsing, ' singular values and vectors of a ', &
       n, ' by ', m,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_select_singval_cmp4
! ======================================
!
end program ex1_select_singval_cmp4

ex1_select_singval_cmp4_bis.F90

program ex1_select_singval_cmp4
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SELECT_SINGVAL_CMP4
!   in module SVD_Procedures.
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine BD_INVITER2 in module SVD_Procedures.
!                                                                              
! LATEST REVISION : 25/10/2019
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c0_9, c50, lamch, bd_inviter2, &
                         select_singval_cmp4, merror, allocate_error, norm, 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
!
    integer(i4b), parameter :: prtunit=6, n=5000, m=1000, ls=150
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of select_singval_cmp4'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, err3, eps, abstol, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, a2, p, leftvec, rightvec, resid, ra
    real(stnd), dimension(:),   allocatable :: s, d, e, tauo, resid2
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: maxiter=2, nsing, mnthr_nsing
!
    logical(lgl) :: failure1, failure2, gen_p, do_test
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : PARTIAL SVD OF A n-BY-m REAL MATRIX WITH n>=m USING THE RHALA-BARLOW
!               ONE-SIDED BIDIAGONAL REDUCTION ALGORITHM, A BISECTION ALGORITHM FOR
!               SINGULAR VALUES AND THE INVERSE ITERATION TECHNIQUE FOR SINGULAR VECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps    = fudge*epsilon( err )
    abstol = sqrt( lamch('S') )
    err    = zero
!
!   SPECIFY IF NUMERICAL TESTS ARE PERFORMED.
!
    do_test = false
!
!   CHOOSE TUNING PARAMETERS FOR THE ALGORITHM.
!
!   DETERMINE CROSSOVER POINT FOR THE BACK-TRANSFORMATION
!   ALGORITHM WHEN COMPUTING RIGHT SINGULAR VECTORS. IF
!   ls EXCEEDS mnthr_nsing, THE RIGHT ORTHOGONAL MATRIX p
!   OF THE ONE-SIDED BIDIAGONAL REDUCTION ALGORITHM IS GENERATED
!   AND BACK-TRANSFORMATION IS DONE BY A MATRIX MULTIPLICATION.
!
    mnthr_nsing = int( real( m, stnd )*c0_9, i4b )
!
    gen_p = ls>=mnthr_nsing
!    gen_p = true
!    gen_p = false
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,m), s(m), d(m), e(m), p(m,m), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-BY-m RANDOM REAL MATRIX a.
!
    call random_number( a )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( a2(n,m), resid(n,m), 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,:m) = a(:n,:m)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL n-BY-m MATRIX a
!   IS WRITTEN
!
!                       a = U * S * V**(t)
!
!   WHERE S IS AN n-BY-m MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   min(m,n) DIAGONAL ELEMENTS, U IS AN n-BY-n ORTHOGONAL MATRIX, AND
!   V IS AN m-BY-m 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.
!
!   THIS PROGRAM ILLUSTRATES HOW TO COMPUTE THE ls LARGEST SINGULAR VALUES OF a AND THE
!   ASSOCIATED LEFT AND RIGHT SINGULAR VECTORS OF a (EG A PARTIAL SVD DECOMPOSITION OF a)
!   IN TWO STEPS:
!
!   STEP1 : COMPUTE THE ls LARGEST SINGULAR VALUES OF a BY THE RHALA-BARLOW ONE-SIDED
!   BIDIAGONAL REDUCTION ALGORITHM APPLIED TO a, A BISECTION METHOD APPLIED TO THE
!   THE RESULTING BIDIAGONAL MATRIX AND STORE INTERMEDIATE RESULTS WITH SUBROUTINE
!   select_singval_cmp4.
!
!   THE OPTIONAL ARGUMENT ls OF select_singval_cmp4 MAY BE USED TO DETERMINE HOW MANY
!   SINGULAR VALUES MUST BE COMPUTED.
!
!   THE OPTIONAL ARGUMENT abstol OF select_singval_cmp4 MAY BE USED TO SET THE REQUIRED
!   PRECISION FOR THE SINGULAR VALUES. A SINGULAR VALUE IS CONSIDERED TO BE LOCATED
!   IF IT HAS BEEN DETERMINED TO LIE IN AN INTERVAL WHOSE WIDTH IS EQUAL OR LESS
!   THAN abstol. SINGULAR VALUES WILL BE COMPUTED MOST ACCURATELY WHEN abstol IS SET
!   TO THE SQUARE ROOT OF THE UNDERFLOW THRESHOLD (EG sqrt(LAMCH('S')) ).
!
!   select_singval_cmp4 IS FASTER THAN select_singval_cmp3, BUT MAY BE LESS ACCURATE
!   FOR SOME MATRICES.
!
    call select_singval_cmp4( a, nsing, s, failure=failure1, sort=sort, d=d, e=e, &
                              ls=ls, abstol=abstol, p=p, gen_p=gen_p )
!
!   ON EXIT OF select_singval_cmp4 :
!
!   failure= false :  INDICATES SUCCESSFUL EXIT
!   failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                     THAT FULL ACCURACY WAS NOT ATTAINED IN THE
!                     COMPUTATION OF THE SINGULAR VALUES OF a.
!
!   THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!   THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM ARE STORED IN a AND p .
!
!   THE SINGULAR VALUES ARE STORED IN s IN DECREASING ORDER (IF sort='d').
!
!   nsing GIVES THE NUMBER OF SINGULAR VALUES REALLY COMPUTED BY select_singval_cmp4.
!   nsing MAY BE GREATER THAN ls IF CLUSTERS OF SINGULAR VALUES ARE PRESENT.
!   THE nsing LARGEST SINGULAR VALUES ARE STORED IN THE FIRST nsing POSITIONS OF s
!   IN DECREASING ORDER IF sort='d'.
!
!   STEP2 : COMPUTE THE nsing ASSOCIATED SINGULAR VALUES OF a BY INVERSE ITERATION
!   WITH SUBROUTINE bd_inviter2 :
!
    if ( nsing>0 ) then
!
!       ALLOCATE WORK VARIABLES NEEDED TO STORE THE SINGULAR VECTORS.
!
        allocate( leftvec(n,nsing),    &
                  rightvec(m,nsing),   &
                  stat = iok    )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE THE FIRST nsing LEFT AND RIGHT SINGULAR VECTORS OF a BY maxiter
!       INVERSE ITERATIONS ON THE INTERMEDIATE BIDIAGONAL MATRIX
!       d_e AND BACK-TRANSFORMATION WITH SUBROUTINE bd_inviter2 .
!
!       ON ENTRY, PARAMETER s CONTAINS SELECTED SINGULAR VALUES OF THE BIDIAGONAL MATRIX d_e (OR a).
!       THE SINGULAR VALUES MUST BE GIVEN IN DECREASING ORDER.
!
        call bd_inviter2( a, p, d, e, s(:nsing), leftvec, rightvec,  &
                          failure=failure2, maxiter=maxiter )
!
!       ON EXIT OF bd_inviter2 :
!
!       failure= false :  INDICATES SUCCESSFUL EXIT
!       failure= true  :  INDICATES THAT THE ALGORITHM FAILS TO CONVERGE
!
!       THE SINGULAR VECTORS OF THE BIDIAGONAL FORM d_e ARE COMPUTED USING maxiter INVERSE ITERATIONS
!       FOR ALL THE SINGULAR VALUES AT ONE STEP. THE SINGULAR VECTORS OF d_e ARE THEN ORTHOGONALIZED BY 
!       THE MODIFIED GRAM-SCHMIDT ALGORITHM IF THE SINGULAR VALUES ARE NOT WELL SEPARATED.
!       THE SINGULAR VECTORS OF a ARE FINALLY COMPUTED BY BACK TRANSFORMATIONS OR MATRIX MULTIPLICATIONS.
!       ON EXIT, leftvec AND rightvec CONTAIN THE FIRST nsing LEFT AND RIGHT SINGULAR VECTORS OF a, RESPECTIVELY.
!
!       bd_inviter2 MAY FAIL IF SOME THE SINGULAR VALUES SPECIFIED IN PARAMETER s ARE NEARLY
!       IDENTICAL FOR SOME PATHOLOGICAL MATRICES.
!
    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 ( do_test .and. nsing>0 ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*v(:m,:nsing) - u(:n,:nsing)*s(:nsing,:nsing),
!       WHERE u AND v ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a.
!
        resid(:n,:nsing) = matmul(a2,rightvec) - leftvec*spread(s(:nsing),dim=1,ncopies=n)
        resid2(:nsing) = norm( resid(:n,:nsing), dim=2_i4b )
!
        err1 = maxval( resid2(:nsing) )/( norm( a2 )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u(:n,:nsing)**(t)*u(:n,:nsing).
!
        call unit_matrix( a2(:nsing,:nsing) )
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(leftvec), leftvec ) )
!
        err2 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - v(:m,:nsing)**(t)*v(:m,:nsing).
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(rightvec), rightvec ) )
!
        err3 = maxval( resid(:nsing,:nsing) )/real(m,stnd)
!
        err = max( err1, err2, err3 )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( do_test ) then
!
        deallocate( a2, resid, resid2 )
!
    end if
!
    if ( nsing>0 ) then
!
        deallocate( a, s, d, e, p, leftvec, rightvec )
!
    else
!
        deallocate( a, s, d, e, p )
!
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. .not.failure1 .and. .not.failure2 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test .and. nsing>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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', nsing, ' singular values and vectors of a ', &
       n, ' by ', m,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_select_singval_cmp4
! ======================================
!
end program ex1_select_singval_cmp4

ex1_singvalues.F90

program ex1_singvalues
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of function SINGVALUES 
!   in module SVD_Procedures . 
!                                                                              
! LATEST REVISION : 06/07/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, svd_cmp, singvalues
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit = 6, m=1000, n=100
!   
!   
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                 :: err
    real(stnd), dimension(n)   :: s, s2
    real(stnd), dimension(m,n) :: a, u
    real(stnd), dimension(n,n) :: v
!
    logical(lgl)   :: failure
!   
    character      :: sort='a'
!   
!
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of singvalues'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A RANDOM DATA MATRIX.
!
    call random_number( a )
!
!   SAVE RANDOM DATA MATRIX .
!
    u(:m,:n) = a(:m,:n)
!
!   COMPUTE FULL SVD OF RANDOM DATA MATRIX.
!
    call svd_cmp( u, s, failure, v, sort=sort )
!
!   CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*v(:,:k) - u(:,:k)*s.
!
    err =  sum( abs(matmul(a,v) - u*spread(s,dim=1,ncopies=m)) )/sum( abs(s) )
!
    if ( err<=sqrt(epsilon(err)) .and. .not.failure ) then
!
!       COMPUTE ONLY SINGULAR VALUES OF RANDOM DATA MATRIX.
!
        s2 = singvalues( a, sort=sort )
!
!       CHECK THE RESULTS WITH THE PREVIOUS COMPUTATIONS.
!
        if ( sum(abs(s2-s))<=sqrt(epsilon(err))*maxval(abs(s)) ) then
            write (prtunit,*) 'Example 1 of SINGVALUES is correct'
        else
            write (prtunit,*) 'Example 1 of SINGVALUES is incorrect'
        end if
    else
        write (prtunit,*) 'Example 1 of SINGVALUES is not done'
    end if
!
!
! END OF PROGRAM ex1_singvalues
! =============================
!
end program ex1_singvalues

ex1_solve_lin.F90

program ex1_solve_lin
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of fonction SOLVE_LIN
!   in module Lin_Procedures . 
!                                                                              
! LATEST REVISION : 04/10/2014
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, lgl, stnd, true, false, zero, solve_lin, merror, allocate_error
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=4000
!
    character(len=*), parameter :: name_proc='Example 1 of solve_lin'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, eps, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a
    real(stnd), dimension(:), allocatable   :: b, x, x2, res
!
    integer        :: iok, istart, iend, irate
!
    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 : REAL MATRIX AND ONE RIGHT HAND-SIDE.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = sqrt( epsilon( err ) )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), b(n), x(n), x2(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 RANDOM SOLUTION VECTOR x .
!
    call random_number( x )
!
!   COMPUTE THE MATRIX-VECTOR PRODUCT b = a*x .
!
    b = matmul( a, x )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count=istart, count_rate=irate )
!
!   COMPUTE THE SOLUTION VECTOR FOR LINEAR SYSTEM
!
!            a*x = b .
!
!   BY COMPUTING THE LU DECOMPOSITION WITH PARTIAL PIVOTING AND
!   IMPLICIT ROW SCALING OF MATRIX a WITH FUNCTION solve_lin.
!   ARGUMENTS a AND b ARE NOT MODIFIED BY THE FUNCTION.
!
    x2 = solve_lin( a, b )
!
!   STOP THE TIMER.
!
    call system_clock( count=iend )
!
    elapsed_time = real( iend - istart, stnd )/real( irate, stnd )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAY .
!
        allocate( res(n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       CHECK THE RESULTS FOR SMALL RESIDUALS.
!
        res(:n) = x2(:n) - x(:n)
        err     = sum( abs(res) ) / sum( abs(x) ) 
!
!       DEALLOCATE WORK ARRAY.
!
        deallocate( res )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, b, x, x2 )
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing the solution of a linear real system of size ', &
       n, ' is', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_solve_lin
! ============================
!
end program ex1_solve_lin

ex1_solve_llsq.F90

program ex1_solve_llsq
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of fonction SOLVE_LLSQ
!   in module LLSQ_Procedures . 
!                                                                              
! LATEST REVISION : 06/07/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, solve_llsq
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=100, m=1000
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                 :: err
    real(stnd), dimension(m)   :: b, res
    real(stnd), dimension(n)   :: x
    real(stnd), dimension(m,n) :: a
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of solve_llsq'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : LINEAR LEAST SQUARES SYSTEM AND ONE RIGHT HAND-SIDE.
!
!
!   GENERATE A RANDOM COEFFICIENT MATRIX a .
!
    call random_number( a )
!
!   GENERATE A RANDOM RIGHT HAND-SIDE vector b .
!
    call random_number( b )
!
!   COMPUTE SOLUTION VECTOR FOR LINEAR LEAST SQUARES SYSTEM
!
!             a*x(:)=b(:) .
!
    x = solve_llsq( a, b )
!
!   CHECK THAT THE RESIDUALS ARE ORTHOGONAL TO THE COLUMN VECTORS OF a .
!
    res = b - matmul( a, x )
    err = sum(abs(matmul(res,a)) )/ sum( abs(a) )
!
    if ( err<=sqrt(epsilon(err)) ) then
        write (prtunit,*) 'Example 1 of SOLVE_LLSQ is correct'
    else
        write (prtunit,*) 'Example 1 of SOLVE_LLSQ is incorrect'
    end if
!
!
! END OF PROGRAM ex1_solve_llsq
! =============================
!
end program ex1_solve_llsq

ex1_svd_cmp.F90

program ex1_svd_cmp
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SVD_CMP 
!   in module SVD_Procedures . 
!                                                                              
! LATEST REVISION : 01/06/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, svd_cmp, 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
!
    integer(i4b), parameter :: prtunit = 6, m=3000, n=3000, k=min(m,n)
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of svd_cmp'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, err3, eps, ulp, elapsed_time
    real(stnd), allocatable, dimension(:)   :: s
    real(stnd), allocatable, dimension(:,:) :: a, u, v, resid
!
    integer      :: iok, istart, iend, irate, imax, itime
!
    logical(lgl)   :: failure, do_test
!   
    character      :: sort='a'
!   
!
! 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 BIDIAGONAL QR IMPLICIT METHOD WITH
!               A WAVE-FRONT ALGORITHM FOR APPLYING GIVENS ROTATIONS IN THE BIDIAGONAL
!               QR ALGORITHM AND, OPTIONALLY, A PERFECT SHIFT FOR THE SINGULAR VECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    ulp = epsilon( err )
    eps = fudge*ulp
    err = zero
!
    do_test = false
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( u(m,n), v(n,k), s(k), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A m-by-n RANDOM DATA MATRIX .
!
    call random_number( u )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( a(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.
!
        a(:m,:n) = u(:m,:n)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   svd_cmp 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.
!
!   BY DEFAULT, svd_cmp USES A PERFECT SHIFT STRATEGY FOR THE SINGULAR VECTORS
!   SINCE IT IS USUALLY FASTER.
!   IF YOU DONT WANT TO USE THIS STRATEGY, YOU CAN SPECIFY THE OPTIONAL LOGICAL
!   PARAMETER perfect_shift WITH THE VALUE false.
!
    call svd_cmp( u, s, failure, v=v, sort=sort, max_francis_steps=10_i4b )
!
!   THE ROUTINE RETURNS THE SINGULAR VALUES AND THE FIRST min(m,n) LEFT
!   AND RIGHT SINGULAR VECTORS.
!
!   ON EXIT OF svd_cmp :
!
!       failure= false :  INDICATES SUCCESSFUL EXIT.
!       failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                         THAT FULL ACCURACY WAS NOT ATTAINED IN THE BIDIAGONAL
!                         SVD OF AN INTERMEDIATE BIDIAGONAL FORM B OF a.
!
!       u IS OVERWRITTEN WITH THE FIRST min(m,n) LEFT SINGULAR VECTORS,
!       STORED COLUMNWISE;
!   
!       v CONTAINS THE FIRST min(m,n) RIGHT SINGULAR VECTORS,
!       STORED COLUMNWISE;
!
!       s IS OVERWRITTEN WITH THE SINGULAR VALUES OF a.
!
!   IF SORT = 'a' OR 'A', THE SINGULAR VALUES ARE SORTED INTO ASCENDING ORDER.
!   IF SORT = 'd' OR 'D', THE SINGULAR VALUES ARE SORTED INTO DESCENDING ORDER.
!   THE SINGULAR VECTORS ARE REARRANGED ACCORDINGLY.
!                
!   IF THE PARAMETER v IS ABSENT, svd_cmp COMPUTES ONLY THE SINGULAR VALUES OF a             
!   AND, OPTIONALLY, STORES THE INTERMEDIATE BIDIAGONAL FORM OF a AND THE ORTHOGONAL
!   MATRICES USED TO REDUCE a TO BIDIAGONAL FORM. SEE EXAMPLES ex2_svd_cmp.f90 OR 
!   ex1_bd_inviter2.f90, WHICH SHOW HOW TO COMPUTE A PARTIAL SVD, FOR MORE DETAILS.
!
!   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 ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*V(:,:k) - U(:,:k)*S(:k,:k).
!
        resid(:m,:k) = matmul(a,v) - u(:,:k)*spread(s,dim=1,ncopies=m)
        a(:k,1_i4b) = norm( resid(:m,:k), dim=2_i4b )
        err1 =  maxval( a(:k,1_i4b) )/( sum( abs(s) )*real(m,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U.
!
        call unit_matrix( a(:k,:k) )
!
        resid(:k,:k) = abs( a(:k,:k) - matmul( transpose(u(:m,:k)), u(:m,:k) ) )
        err2 = maxval( resid(:k,:k) )/real(m,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - V**(t)*V.
!
        resid(:k,:k) = abs( a(:k,:k) - matmul( transpose(v(:n,:k)), v(:n,:k) ) )
        err3 = maxval( resid(:k,:k) )/real(n,stnd)
!
        err = max( err1, err2, err3 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, resid )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( u, v, s )
!
!   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
!
    if ( do_test ) 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,i5,a,i5,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_svd_cmp
! ==========================
!
end program ex1_svd_cmp

ex1_svd_cmp2.F90

program ex1_svd_cmp2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SVD_CMP2 
!   in module SVD_Procedures . 
!                                                                              
! LATEST REVISION : 01/06/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, svd_cmp2,   &
                         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
!
    integer(i4b), parameter :: prtunit = 6, m=3000, n=3000, k=min(m,n)
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of svd_cmp2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, err3, eps, elapsed_time
    real(stnd), allocatable, dimension(:)   :: s
    real(stnd), allocatable, dimension(:,:) :: a2, a, c, resid
!
    integer        :: iok, istart, iend, irate, imax, itime
!
    logical(lgl)   :: 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 : FULL SVD OF A REAL MATRIX USING THE BIDIAGONAL QR IMPLICIT METHOD WITH
!               A WAVE-FRONT ALGORITHM FOR APPLYING GIVENS ROTATIONS IN THE BIDIAGONAL
!               QR ALGORITHM AND, OPTIONALLY, A PERFECT SHIFT FOR THE SINGULAR VECTORS.
!               THE SINGULAR VECTORS ARE OUTPUT IN LAPACK-STYLE FORMAT INSTEAD OF COLUMNWISE.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    do_test = true
!
!   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 m-by-n RANDOM DATA MATRIX .
!
    call random_number( a )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAY.
!
        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)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   svd_cmp2 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.
!
!   BY DEFAULT, svd_cmp2 USES A PERFECT SHIFT STRATEGY FOR THE SINGULAR VECTORS
!   SINCE IT IS USUALLY FASTER.
!   IF YOU DONT WANT TO USE THIS STRATEGY, YOU CAN SPECIFY THE OPTIONAL LOGICAL
!   PARAMETER perfect_shift WITH THE VALUE false.
!
    call svd_cmp2( a, s, failure, u_vt=c, sort=sort )
!
!   THE ROUTINE RETURNS THE SINGULAR VALUES, THE LEFT AND RIGHT
!   SINGULAR VECTORS. THE RIGHT SINGULAR VECTORS ARE RETURNED ROWWISE.
!
!   ON EXIT OF svd_cmp2 :
!
!       failure= false :  INDICATES SUCCESSFUL EXIT.
!       failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                         THAT FULL ACCURACY WAS NOT ATTAINED IN THE BIDIAGONAL
!                         SVD OF AN INTERMEDIATE BIDIAGONAL FORM B OF a.
!
!         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.
!
!   IF SORT = 'a' OR 'A', THE SINGULAR VALUES ARE SORTED INTO ASCENDING ORDER.
!   IF SORT = 'd' OR 'D', THE SINGULAR VALUES ARE SORTED INTO DESCENDING ORDER.
!   THE SINGULAR VECTORS ARE REARRANGED ACCORDINGLY.
!                
!   IF THE PARAMETER u_vt IS ABSENT, svd_cmp2 COMPUTES ONLY THE SINGULAR VALUES OF a             
!   AND, OPTIONALLY, STORES THE INTERMEDIATE BIDIAGONAL FORM OF a AND THE ORTHOGONAL
!   MATRICES USED TO REDUCE a TO BIDIAGONAL FORM. SEE EXAMPLE ex2_svd_cmp2.f90, WHICH
!   SHOWS HOW TO COMPUTE A PARTIAL SVD, FOR MORE DETAILS.
!
!   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 ( 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(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) )/( sum( abs(s) )*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) )/( sum( abs(s) )*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 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a2, resid )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, c, s )
!
!   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
!
    if ( do_test ) 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,i5,a,i5,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_svd_cmp2
! ===========================
!
end program ex1_svd_cmp2

ex1_svd_cmp3.F90

program ex1_svd_cmp3
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SVD_CMP3
!   in module SVD_Procedures . 
!                                                                              
! LATEST REVISION : 01/06/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, svd_cmp3, 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
!
    integer(i4b), parameter :: prtunit = 6, m=5000, n=5000, k=min(m,n)
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of svd_cmp3'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, err3, eps, elapsed_time
    real(stnd), allocatable, dimension(:)   :: s
    real(stnd), allocatable, dimension(:,:) :: a2, a, c, resid
!
    integer        :: iok, istart, iend, irate, imax, itime
!
    logical(lgl)   :: 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 : FULL SVD OF A REAL MATRIX USING THE ONE-SIDED
!               RALHA-BARLOW BIDIAGONAL REDUCTION ALGORITHM AND
!               THE BIDIAGONAL QR IMPLICIT METHOD WITH A WAVE-FRONT
!               ALGORITHM FOR APPLYING GIVENS ROTATIONS IN THE
!               BIDIAGONAL QR ALGORITHM AND, OPTIONALLY, A PERFECT
!               SHIFT FOR THE SINGULAR VECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    do_test = false
!
!   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 m-by-n RANDOM DATA MATRIX .
!
    call random_number( a )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAY.
!
        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)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   svd_cmp3 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.
!
!   BY DEFAULT, svd_cmp3 USES A PERFECT SHIFT STRATEGY FOR THE SINGULAR VECTORS
!   SINCE IT IS USUALLY FASTER.
!   IF YOU DONT WANT TO USE THIS STRATEGY, YOU CAN SPECIFY THE OPTIONAL LOGICAL
!   PARAMETER perfect_shift WITH THE VALUE false.
!
    call svd_cmp3( a, s, failure, c, sort=sort, max_francis_steps=10_i4b )
!
!   THE ROUTINE RETURNS THE SINGULAR VALUES AND THE FIRST min(m,n) LEFT AND
!   RIGHT SINGULAR VECTORS. THE RIGHT SINGULAR VECTORS ARE RETURNED ROWWISE
!   IF m<n.
!
!   ON EXIT OF svd_cmp3 :
!
!       failure= false :  INDICATES SUCCESSFUL EXIT
!       failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                         THAT FULL ACCURACY WAS NOT ATTAINED IN THE BIDIAGONAL
!                         SVD OF AN INTERMEDIATE BIDIAGONAL FORM B OF a OR THAT
!                         SOME LOSS OF ACCURACY CAN BE EXPECTED IN THE RALHA-BARLOW
!                         ONE-SIDED BIDIAGONALIZATION BECAUSE a IS NEARLY SINGULAR.
!
!   ON EXIT OF svd_cmp3 :
!
!         IF m>=n,    a IS OVERWRITTEN WITH THE FIRST n
!                     COLUMNS OF U (THE LEFT SINGULAR VECTORS,
!                     STORED COLUMNWISE);
!                     c CONTAINS THE n-BY-n ORTHOGONAL MATRIX V .
!
!         IF m<n,     a IS OVERWRITTEN WITH THE FIRST m 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.
!
!   IF SORT = 'a' OR 'A', THE SINGULAR VALUES ARE SORTED INTO ASCENDING ORDER.
!   IF SORT = 'd' OR 'D', THE SINGULAR VALUES ARE SORTED INTO DESCENDING ORDER.
!   THE SINGULAR VECTORS ARE REARRANGED ACCORDINGLY.
!
!   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 ( 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), 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) )/( sum( abs(s) )*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( transpose(c(:n,:n)), 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) )/( sum( abs(s) )*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 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a2, resid )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, c, s )
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps ) then
!    if ( err<=eps .and. .not.failure ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) 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,i5,a,i5,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_svd_cmp3
! ===========================
!
end program ex1_svd_cmp3

ex1_svd_cmp4.F90

program ex1_svd_cmp4
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SVD_CMP4
!   in module SVD_Procedures .
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine BD_INVITER2 in module SVD_Procedures.
!                                                                              
! LATEST REVISION : 09/07/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, zero, true, false, bd_inviter2, svd_cmp4, &
                         norm, unit_matrix, 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
!
    integer(i4b), parameter :: prtunit=6, n=3000, m=3000, nsing=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of svd_cmp4'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, err3, eps, elapsed_time
    real(stnd), allocatable, dimension(:)   :: s, d, e
    real(stnd), allocatable, dimension(:,:) :: a, a2, p, leftvec, rightvec, resid
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: maxiter=2
!
    logical(lgl) :: failure1, failure2, do_test
!   
    character    :: sort='d'
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : ALL SINGULAR VALUES AND nsing SINGULAR VECTORS OF A n-BY-m REAL MATRIX WITH n>=m
!               USING THE RHALA-BARLOW ONE-SIDED BIDIAGONAL REDUCTION ALGORITHM, THE BIDIAGONAL QR
!               ALGORITHM FOR THE SINGULAR VALUES AND THE INVERSE ITERATION METHOD FOR THE
!               SINGULAR VECTORS (eg PARTIAL SVD DECOMPOSITION).
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,m), leftvec(n,nsing), rightvec(m,nsing),      &
              p(m,m), s(m), d(m), e(m), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-BY-m RANDOM REAL MATRIX a.
!
    call random_number( a )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( a2(n,m), resid(n,nsing), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       MAKE A COPY OF THE RANDOM DATA MATRIX .
!
        a2(:n,:m) = a(:n,:m)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL n-BY-m MATRIX a
!   IS WRITTEN
!
!                       a = U * S * V**(t)
!
!   WHERE S IS AN n-BY-m MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   min(m,n) DIAGONAL ELEMENTS, U IS AN n-BY-n ORTHOGONAL MATRIX, AND
!   V IS AN m-BY-m 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.
!
!   THIS PROGRAM ILLUSTRATES HOW TO COMPUTE ALL THE SINGULAR VALUES OF a AND
!   ONLY nsing LEFT AND RIGHT SINGULAR VECTORS OF a (EG A PARTIAL SVD DECOMPOSITION
!   OF a) IN TWO STEPS:
!
!   STEP1 : COMPUTE ALL SINGULAR VALUES OF a AND STORE INTERMEDIATE RESULTS WITH SUBROUTINE svd_cmp4.
!
    call svd_cmp4( a, s, failure=failure1, v=p, sort=sort, d=d, e=e, sing_vec=false, gen_p=false )
!
!   ON EXIT OF svd_cmp4 :
!
!         failure= false :  INDICATES SUCCESSFUL EXIT
!         failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                           THAT FULL ACCURACY WAS NOT ATTAINED IN THE BIDIAGONAL
!                           SVD OF AN INTERMEDIATE BIDIAGONAL FORM BD OF a OR THAT
!                           a IS NEARLY SINGULAR AND SOME LOSS OF ORTHOGONALITY CAN
!                           BE EXPECTED IN THE RALHA-BARLOW ONE-SIDE BIDIAGONALIZATION
!                           OF a.
!
!         s IS OVERWRITTEN WITH THE SINGULAR VALUES OF a.
!
!         IF SORT = 'a' OR 'A', THE SINGULAR VALUES ARE SORTED INTO ASCENDING ORDER.
!         IF SORT = 'd' OR 'D', THE SINGULAR VALUES ARE SORTED INTO DESCENDING ORDER.
!
!   HERE, SORT = 'd' IS USED. THIS IS REQUIRED FOR THE USE OF bd_inviter2.
!                
!   IF THE PARAMETER sing_vec IS USED WITH THE VALUE false IN THE CALL OF svd_cmp4,
!   svd_cmp4 COMPUTES ONLY THE SINGULAR VALUES OF a AND, OPTIONALLY, STORES THE
!   INTERMEDIATE BIDIAGONAL FORM OF a AND THE ORTHOGONAL MATRICES USED TO REDUCE
!   a TO BIDIAGONAL FORM.
!
!   THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN THE OPTIONAL ARGUMENTS d AND e.
!   THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM d AND e ARE STORED 
!   IN mat AND p.
!
!   STEP2 : COMPUTE THE FIRST nsing LEFT AND RIGHT SINGULAR VECTORS OF a BY maxiter
!   INVERSE ITERATIONS ON THE INTERMEDIATE BIDIAGONAL MATRIX AND BACK-TRANSFORMATION
!   WITH SUBROUTINE bd_inviter2 .
!
!   ON ENTRY, PARAMETER s CONTAINS SELECTED SINGULAR VALUES OF THE BIDIAGONAL MATRIX d_e (OR a).
!   THE SINGULAR VALUES MUST BE GIVEN IN DECREASING ORDER.
!
    call bd_inviter2( a, p, d, e, s(:nsing), leftvec, rightvec, failure=failure2, maxiter=maxiter )
!
!   ON EXIT OF bd_inviter2 :
!
!         failure= false :  INDICATES SUCCESSFUL EXIT.
!         failure= true  :  INDICATES THAT THE ALGORITHM FAILS TO CONVERGE FOR SOME SINGULAR VECTORS.
!
!   THE SINGULAR VECTORS OF THE BIDIAGONAL FORM ARE COMPUTED USING maxiter INVERSE ITERATIONS
!   FOR ALL THE SINGULAR VALUES AT ONE STEP. THE SINGULAR VECTORS OF ARE THEN ORTHOGONALIZED BY 
!   THE MODIFIED GRAM-SCHMIDT ALGORITHM IF NECESSARY. THE SINGULAR VECTORS OF a ARE FINALLY COMPUTED 
!   BY BACK TRANSFORMATIONS. ON EXIT, leftvec AND rightvec CONTAIN THE FIRST nsing LEFT AND RIGHT
!   SINGULAR VECTORS OF a, RESPECTIVELY.
!
!   NOTE THAT bd_inviter2 MAY FAIL IF SOME THE SINGULAR VALUES SPECIFIED IN PARAMETER s ARE NEARLY
!   IDENTICAL FOR SOME PATHOLOGICAL MATRICES.
!
!   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 ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*V(:m,:nsing) - U(:n,:nsing)*S(:nsing,:nsing),
!       WHERE leftvec AND rightvec ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a.
!
        resid(:n,:nsing) = matmul(a2,rightvec) - leftvec*spread(s(:nsing),dim=1,ncopies=n)
        a2(:nsing,1_i4b) = norm( resid(:n,:nsing), dim=2_i4b )
        err1 = maxval( a2(:nsing,1_i4b) )/( sum( abs(s(:n)) )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U(:n,:nsing)**(t)*U(:n,:nsing).
!
        call unit_matrix( a2(:nsing,:nsing) )
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(leftvec), leftvec ) )
        err2 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - V(:m,:nsing)**(t)*V(:m,:nsing).
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(rightvec), rightvec ) )
        err3 = maxval( resid(:nsing,:nsing) )/real(m,stnd)
!
        err = max( err1, err2, err3 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a2, resid )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, p, leftvec, rightvec, s, d, e )
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. .not.failure2 ) then
!    if ( err<=eps .and. .not.failure1 .and. .not.failure2 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing all singular values and ', nsing, ' singular vectors of a ', &
       n, ' by ', m,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_svd_cmp4
! ===========================
!
end program ex1_svd_cmp4

ex1_sym_inv.F90

program ex1_sym_inv
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of function SYM_INV
!   in module Lin_Procedures . 
!                                                                              
! LATEST REVISION : 23/09/2014
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    USE Statpack, ONLY : lgl, i4b, stnd, true, false, zero, one, sym_inv, merror, allocate_error
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=4000, m=4000
!
    character(len=*), parameter :: name_proc='Example 1 of sym_inv'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, eps, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, ata, atainv, res
!
    integer(i4b) :: j
    integer      :: iok, istart, iend, irate
!
    logical(lgl) :: do_test, upper, failure
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : INVERSE OF A REAL SYMMETRIC DEFINITE POSITIVE MATRIX .
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = sqrt( epsilon( err ) )
    err = zero
!
    do_test = false
    upper   = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(m,n), ata(n,n), atainv(n,n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
! 
!   GENERATE A RANDOM DATA MATRIX a .
!
    call random_number( a )
!
!   GENERATE A n-BY-n SYMMETRIC POSITIVE DEFINITE MATRIX From a .
!
    ata = matmul( transpose(a), a )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count=istart, count_rate=irate )
!
!   COMPUTE THE MATRIX INVERSE OF ata WITH FUNCTION sym_inv.
!
    atainv = sym_inv( ata, upper=upper )
!
!   STOP THE TIMER.
!
    call system_clock( count=iend )
!
    elapsed_time = real( iend - istart, stnd )/real( irate, stnd )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAY .
!
        allocate( res(n,n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE ata TIMES ITS INVERSE - IDENTITY.
!
        res = matmul( ata, atainv )
!
        do j = 1_i4b, n
            res(j,j) = res(j,j) - one
        end do
!
!       CHECK THE RESULTS FOR SMALL RESIDUALS.
!
        err = sum( abs(res) ) / sum( abs(ata) )
!
!       DEALLOCATE WORK ARRAY.
!
        deallocate( res )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, ata, atainv )
!
    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 (*,'(a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing the inverse of a positive definite symmetric matrix of size ', &
       n, ' is', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_sym_inv
! ==========================
!
end program ex1_sym_inv

ex1_symlin_filter.F90

program ex1_symlin_filter
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines/functions LP_COEF, HP_COEF,
!   SYMLIN_FILTER in module Time_Series_Procedures.
!                                                                              
! LATEST REVISION : 12/11/2007
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, lp_coef, hp_coef, symlin_filter
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT, n IS THE LENGTH OF THE TIME SERIES, k IS THE NUMBER OF TERMS OF THE LANCZOS FILTER.
!
    integer(i4b), parameter :: prtunit=6, n=2000, k=21
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                     :: err
    real(stnd), dimension(n)       :: y, y2, y3
    real(stnd), dimension(k)       :: coefl, coefh
!
    integer(i4b) :: pc, nfilt, n1, n2, khalf
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of symlin_filter'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A RANDOM REAL NUMBER SEQUENCE OF LENGTH n .
!
    call random_number( y(:n) )
!
!   SAVE THE REAL RANDOM NUMBER ARRAY.
!
    y2(:n) = y(:n)
    y3(:n) = y(:n)
!
!   DETERMINE THE CUTOFF PERIOD.
!
    pc  = 18
!
!   FUNCTION lp_coef COMPUTES THE K-TERM LEAST SQUARES APPROXIMATION TO AN
!   -IDEAL- LOW PASS FILTER WITH CUTOFF PERIOD PL (EG CUTOFF FREQUENCY FC =  1/PL).
!
    coefl(:k) = lp_coef( PL=pc, K=k )
!
!   FUNCTION hp_coef COMPUTES THE K-TERM LEAST SQUARES APPROXIMATION TO AN
!   -IDEAL- HIGH PASS FILTER WITH CUTOFF PERIOD PH (EG CUTOFF FREQUENCY FC =  1/PH).
!
    coefh(:k) = hp_coef( PH=pc, K=k )
!
!   PL AND  PH ARE EXPRESSED IN NUMBER OF POINTS, i.e. PL OR PH =6(18) CORRESPONDS TO PERIODS
!   OF 1.5 YRS FOR QUATERLY(MONTHLY) DATA.
!
!   SUBROUTINE symlin_filter PERFORMS A SYMMETRIC FILTERING OPERATION ON AN INPUT TIME
!   SERIES (EG THE ARGUMENT VEC) WITH THE ARRAY OF SYMMETRIC LINEAR FILTER COEFFICIENTS COEF(:).
!
!   NOTE THAT (size(COEF)-1)/2 DATA POINTS WILL BE LOST FROM EACH END OF THE TIME SERIES,
!   SO THAT NFILT= size(VEC) - size(COEF) + 1) TIME OBSERVATIONS ARE RETURNED
!   AND THE REMAINING PART OF VEC(:) IS SET TO ZERO. NFILT IS AN OPTIONAL ARGUMENT.
!
    call symlin_filter( VEC=y2(:n), COEF=coefl(:k),  NFILT=nfilt )
!
    call symlin_filter( VEC=y3(:n), COEF=coefh(:k)  )
!
!   NOW RECONSTRUCT THE ORIGINAL TIME SERIES FROM THE TWO FILTERED TIME SERIES.
!
    y2(:nfilt) = y2(:nfilt) + y3(:nfilt)
!
!   TEST THE ACCURACY OF THE RECONSTRUCTION.
!
    khalf = ( k - 1 )/2
    n1    = khalf + 1
    n2    = n - khalf
!
    err = maxval(abs(y(n1:n2)-y2(:nfilt)))/maxval(abs(y(n1:n2)))
!
    if ( err<=sqrt(epsilon(err))  ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex1_symlin_filter
! ================================
!
end program ex1_symlin_filter

ex1_symlin_filter2.F90

program ex1_symlin_filter2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines/functions LP_COEF, HP_COEF,
!   SYMLIN_FILTER2 in module Time_Series_Procedures.
!                                                                              
! LATEST REVISION : 12/11/2007
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, lp_coef, hp_coef, symlin_filter2
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT, n IS THE LENGTH OF THE TIME SERIES, k IS THE NUMBER OF TERMS OF THE LANCZOS FILTER.
!
    integer(i4b), parameter :: prtunit=6, n=2000, k=21
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                     :: err
    real(stnd), dimension(n)       :: y, y2, y3
    real(stnd), dimension(k)       :: coefl, coefh
!
    integer(i4b) :: pc
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of symlin_filter2'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A RANDOM REAL NUMBER SEQUENCE OF LENGTH n .
!
    call random_number( y(:n) )
!
!   SAVE THE REAL RANDOM NUMBER ARRAY.
!
    y2(:n) = y(:n)
    y3(:n) = y(:n)
!
!   DETERMINE THE CUTOFF PERIOD.
!
    pc  = 18
!
!   FUNCTION lp_coef COMPUTES THE K-TERM LEAST SQUARES APPROXIMATION TO AN
!   -IDEAL- LOW PASS FILTER WITH CUTOFF PERIOD PL (EG CUTOFF FREQUENCY FC =  1/PL).
!
    coefl(:k) = lp_coef( PL=pc, K=k )
!
!   FUNCTION hp_coef COMPUTES THE K-TERM LEAST SQUARES APPROXIMATION TO AN
!   -IDEAL- HIGH PASS FILTER WITH CUTOFF PERIOD PH (EG CUTOFF FREQUENCY FC =  1/PH).
!
    coefh(:k) = hp_coef( PH=pc, K=k )
!
!   PL AND  PH ARE EXPRESSED IN NUMBER OF POINTS, i.e. PL OR PH =6(18) CORRESPONDS TO PERIODS
!   OF 1.5 YRS FOR QUATERLY(MONTHLY) DATA.
!
!   SUBROUTINE symlin_filter2 PERFORMS A SYMMETRIC FILTERING OPERATION ON AN INPUT TIME
!   SERIES (EG THE ARGUMENT VEC) WITH THE ARRAY OF SYMMETRIC LINEAR FILTER COEFFICIENTS COEF(:).
!
!   NO DATA POINTS WILL BE LOST, HOWEVER (size(COEF)-1)/2 OBSERVATIONS
!   AT EACH END OF THE TIME SERIES ARE AFFECTED BY END EFFECTS.
!
    call symlin_filter2( VEC=y2(:n), COEF=coefl(:k) )
!
    call symlin_filter2( VEC=y3(:n), COEF=coefh(:k)  )
!
!   NOW RECONSTRUCT THE ORIGINAL TIME SERIES FROM THE TWO FILTERED TIME SERIES.
!
    y2(:n) = y2(:n) + y3(:n)
!
!   TEST THE ACCURACY OF THE RECONSTRUCTION.
!
    err = maxval(abs(y(:n)-y2(:n)))/maxval(abs(y(:n)))
!
    if ( err<=sqrt(epsilon(err))  ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex1_symlin_filter2
! =================================
!
end program ex1_symlin_filter2

ex1_symtrid_bisect.F90

program ex1_symtrid_bisect
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SYMTRID_BISECT
!   in module Eig_Procedures .
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine TRID_DEFLATE in module Eig_Procedures.
!
! LATEST REVISION : 08/05/2016
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, one, two, c50,     &
                         trid_deflate, symtrid_bisect, norm, lamch, 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
!
    integer(i4b), parameter :: prtunit=6, n=3000, neig=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of symtrid_bisect'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err, eps, abstol, normt, &
                                               elapsed_time
    real(stnd), allocatable, dimension(:)   :: d, e, eigval, temp, temp2
    real(stnd), allocatable, dimension(:,:) :: resid, eigvec
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: max_qr_steps, neig2, j
!
    logical(lgl)  :: failure1, failure2, do_test, ortho
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps    = fudge*epsilon( err )
    abstol = sqrt( lamch('s') )
    err    = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( d(n), e(n), eigval(n), eigvec(n,neig), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   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) = 0.5
!    e(:n) = 0.5
!
    call random_number( d(:n) )
    call random_number( e(:n) )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   COMPUTE neig EIGENVALUES OF THE TRIDIAGONAL MATRIX BY A BISECTION METHOD WITH HIGH ACCURACY.
!   THE EIGENVALUES ARE COMPUTED WITH MAXIMUM ACCURACY WHEN OPTIONAL PARAMETER abstol IS SET TO
!   sqrt( lamch('s') ), WHICH IS THE SQUARE ROOT OF THE UNDERFLOW THRESHOLD.
!
    call symtrid_bisect( d, e, neig2, eigval, failure1, sort=sort, le=neig, abstol=abstol )
!
!   NEXT, COMPUTE THE FIRST nvec EIGENVECTORS OF THE SELF-ADJOINT MATRIX a BY A
!   DEFLATION TECHNIQUE APPLIED ON THE TRIDIAGONAL MATRIX d_e.
!
!   ON ENTRY OF SUBROUTINE trid_deflate, PARAMETER eigval CONTAINS SELECTED
!   EIGENVALUES OF THE TRIDIAGONAL MATRIX.
!   THE EIGENVALUES VALUES MUST BE GIVEN IN DECREASING ORDER.
!
    ortho = false
    max_qr_steps = 4_i4b
!
    call trid_deflate( d(:n), e(:n), eigval(:neig), eigvec(:n,:neig), failure=failure2,     &
                       ortho=ortho, max_qr_steps=max_qr_steps )
!
!   ON EXIT OF trid_deflate :
!
!       failure= false :  INDICATES SUCCESSFUL EXIT.
!       failure= true  :  INDICATES THAT MAXIMUM ACCURACY WAS NOT OBTAIN IN THE ALGORITHM.

!       eigvec CONTAINS THE nvec EIGENVECTORS OF THE TRIDIAGONAL MATRIX ASSOCIATED WITH THE
!       EIGENVALUES eigval(:nvec).
!
!   trid_deflate MAY FAIL IF SOME THE EIGENVALUES SPECIFIED IN PARAMETER eigval ARE NEARLY
!   IDENTICAL AND IF THESE EIGENVALUES ARE NOT COMPUTED WITH HIGH ACCURACY.
!
!   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 ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( resid(n,neig), temp(n), temp2(n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*u - u*s
!       WHERE s ARE THE EIGENVALUES AND u THE EIGENVECTORS OF THE TRIDIAGONAL MATRIX.
!
        do j=1_i4b, neig
!
            temp(1_i4b:n) = eigvec(1_i4b:n,j)
!
            temp2(1_i4b)         = d(1_i4b)*temp(1_i4b) + e(1_i4b)*temp(2_i4b)
            temp2(2_i4b:n-1_i4b) = e(1_i4b:n-2_i4b)*temp(1_i4b:n-2_i4b)           +   &
                                   d(2_i4b:n-1_i4b)*temp(2_i4b:n-1_i4b)           +   &
                                   e(2_i4b:n-1_i4b)*temp(3_i4b:n)
            temp2(n)             = e(n-1_i4b)*temp(n-1_i4b) + d(n)*temp(n)
!
            resid(1_i4b:n,j) = temp2(1_i4b:n) - eigval(j)*temp(1_i4b:n)
!
        end do
!
        temp(:neig) = norm( resid(1_i4b:n,1_i4b:neig), dim=2_i4b )
        normt = sqrt( sum( d(1_i4b:n)**2 ) + two*(sum( e(1_i4b:n-1_i4b)**2) ) )
!
        err1  = maxval( temp(:neig) )/( normt*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u**(t)*u
!       WHERE u are THE EIGENVECTORS OF THE TRIDIAGONAL MATRIX a.
!
        resid(:neig,:neig) = matmul( transpose( eigvec(:n,:neig) ), eigvec(:n,:neig) )
!
        do j=1_i4b, neig
            resid(j,j) = resid(j,j) - one
        end do
!
        err2 = maxval( abs( resid(:neig,:neig) ) )/real(n,stnd)
!
        err = max( err1, err2 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( resid, temp, temp2, d, e, eigval, eigvec )
!
    else
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( d, e, eigval, eigvec )
!
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. .not.failure1 .and. .not.failure2 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', neig, ' eigenvalues and eigenvectors of a ', &
       n, ' by ', n,' real symmetric tridiagonal matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_symtrid_bisect
! =================================
!
end program ex1_symtrid_bisect

ex1_symtrid_cmp.F90

program ex1_symtrid_cmp
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines SYMTRID_CMP and
!   ORTHO_GEN_SYMTRID in module EIG_Procedures .
!                                                                              
! LATEST REVISION : 28/05/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, symtrid_cmp,         &
                         ortho_gen_symtrid, 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
!
    integer(i4b), parameter :: prtunit=6, n=5000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of symtrid_cmp'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err, eps, elapsed_time
    real(stnd), allocatable, dimension(:)   :: d, e
    real(stnd), allocatable, dimension(:,:) :: a, a2, resid, trid
!
    integer(i4b) :: l
!
    integer      :: 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 : TRIDIAGONAL REDUCTION OF A REAL SYMMETRIC MATRIX.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), d(n), e(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), 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 )
!
!   CALL symtrid_cmp AND ortho_gen_symtrid_cmp TO REDUCE THE MATRIX a TO TRIDIAGONAL FORM
!
!                      a = Q*TRID*Q**(t)
!
!   WHERE Q IS ORTHOGONAL AND TRID IS A SYMMETRIC TRIDIAGONAL MATRIX.
!
!   ON ENTRY OF symtrid_cmp, a MUST CONTAINS THE LEADING n-BY-n UPPER TRIANGULAR PART
!   OF THE MATRIX TO BE REDUCED AND THE STRICTLY LOWER PART OF a IS NOT REFERENCED.
!
    call symtrid_cmp( a, d, e, store_q=true )
!
!   ON EXIT OF symtrid_cmp:
!
!         ARGUMENTS d AND e CONTAIN, RESPECTIVELY, THE DIAGONAL AND
!         OFF-DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX TRID.
!
!         IF THE OPTIONAL ARGUMENT store_q IS PRESENT AND SET TO TRUE,
!         THE LEADING n-BY-n UPPER TRIANGULAR PART OF a IS OVERWRITTEN
!         BY THE MATRIX Q AS A PRODUCT OF ELEMENTARY REFLECTORS.
!
!   ortho_gen_symtrid GENERATES THE MATRIX Q STORED AS A PRODUCT OF
!   ELEMENTARY REFLECTORS AFTER A CALL TO symtrid_cmp WITH store_q=true.
!
    call ortho_gen_symtrid( a )
!
!   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 ( 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 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a2, trid, resid )
!
    endif
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, d, e )
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) 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,i5,a,i5,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_symtrid_cmp
! ==============================
!
end program ex1_symtrid_cmp

ex1_symtrid_cmp2.F90

program ex1_symtrid_cmp2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines SYMTRID_CMP2 and
!   ORTHO_GEN_SYMTRID in module EIG_Procedures.
!                                                                              
! LATEST REVISION : 10/09/2019
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, symtrid_cmp2,         &
                         ortho_gen_symtrid, 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 MATRIX USED
! TO COMPUTE THE MATRIX CROSS-PRODUCT, m MUST BE GREATER THAN n, OTHERWISE
! symtrid_cmp2 WILL STOP WITH AN ERROR MESSAGE.
!
    integer(i4b), parameter :: prtunit=6, m=3000, n=1000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of symtrid_cmp2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err, eps, elapsed_time
    real(stnd), allocatable, dimension(:)   :: d, e
    real(stnd), allocatable, dimension(:,:) :: a, at, ata, resid, trid
!
    integer(i4b) :: l
!
    integer :: iok, istart, iend, irate, imax, itime
!
    logical(lgl) :: do_test, upper
!   
!
! 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 CROSS-PRODUCT,
!               USING THE ONE-SIDED RALHA METHOD.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(m,n), d(n), e(n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A m-by-n RANDOM DATA MATRIX a .
!
    call random_number( a )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( ata(n,n), at(n,m), trid(n,n), resid(n,n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
        at(:n,:m) = transpose( a(:m,:n) )
!
!       COMPUTE THE SYMMETRIC MATRIX CROSS-PRODUCT.
!
        ata(:n,:n) = matmul( at(:n,:m), a(:m,:n) )
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   CALL symtrid_cmp2 AND ortho_gen_symtrid_cmp TO REDUCE THE MATRIX CROSS-PRODUCT TO TRIDIAGONAL FORM
!
!                      ata = Q*TRID*Q**(t)
!
!   WHERE Q IS ORTHOGONAL AND TRID IS A SYMMETRIC TRIDIAGONAL MATRIX.
!
!   ON ENTRY OF symtrid_cmp2, a MUST CONTAINS THE INITIAL m-by-n MATRIX USED
!   FOR COMPUTING THE MATRIX CROSS-PRODUCT. THE ORTHOGONAL MATRIX Q IS STORED
!   IN FACTORED FORM IF THE LOGICAL ARGUMENT store_q IS SET TO true.
!
    call symtrid_cmp2( a(:m,:n), d, e, store_q=true )
!
!   ON EXIT OF symtrid_cmp2:
!
!         ARGUMENTS d AND e CONTAIN, RESPECTIVELY, THE DIAGONAL AND
!         OFF-DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX TRID.
!
!         IF THE LOGICAL ARGUMENT store_q IS SET TO TRUE ON ENTRY,
!         THE LEADING n-BY-n LOWER TRIANGULAR PART OF a IS OVERWRITTEN
!         BY THE MATRIX Q AS A PRODUCT OF ELEMENTARY REFLECTORS.
!
!   ortho_gen_symtrid GENERATES THE MATRIX Q STORED AS A PRODUCT OF
!   ELEMENTARY REFLECTORS AFTER A CALL TO symtrid_cmp2 WITH store_q=true.
!
    call ortho_gen_symtrid( a(:n,:n), false )
!
!   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 ( 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( ata(: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( ata )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - Q**(t)*Q.
!
        call unit_matrix( ata(:n,:n) )
!
        at(:n,:n) = transpose( a(:n,:n) )
!
        resid(:n,:n) = abs( ata(:n,:n) - matmul( at(:n,:n), a(:n,:n) ) )
        err2 = maxval( resid(:n,:n) )/real(n,stnd)
!
        err = max( err1, err2 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( ata, trid, resid, at )
!
    endif
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, d, e )
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) then
        write (prtunit,*) 
        write (prtunit,*) 'Accuracy of the computed tridiagonal decomposition a**(t)*a = Q*TRD*Q**(t) = ', err1
        write (prtunit,*) 'Orthogonality of the computed orthogonal matrix Q                          = ', err2
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing the tridiagonal reduction of a ', &
       n, ' by ', n,' real symmetric matrix cross-product is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_symtrid_cmp2
! ===============================
!
end program ex1_symtrid_cmp2

ex1_symtrid_qri.F90

program ex1_symtrid_qri
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SYMTRID_QRI
!   in module Eig_Procedures .
!                                                                              
!
! LATEST REVISION : 24/05/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, one, c50,            &
                         allocate_error, merror, symtrid_qri, norm, 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
!
    integer(i4b), parameter :: prtunit=6, n=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of symtrid_qri'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err, eps, normt, elapsed_time
    real(stnd), allocatable, dimension(:)   :: d, e, d2, e2, temp, temp2, resid2
    real(stnd), allocatable, dimension(:,:) :: eigvec, resid, id
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: j
!
    logical(lgl) :: 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 : EIGENVALUES AND EIGENVECTORS OF A REAL SYMMETRIC
!               TRIDIAGONAL MATRIX USING THE QR METHOD.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( eigvec(n,n), d(n), e(n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM TRIDIAGONAL MATRIX.
!   THE DIAGONAL ELEMENTS ARE STORED IN d .
!   THE OFF-DIAGONAL ELEMENTS ARE STORED IN e .
!
    call random_number( d(:n) )
    call random_number( e(:n) )

!    d(:n) = 0.5_stnd
!    e(:n) = 0.5_stnd

!    d(:n) = 1._stnd
!    e(:n) = 2._stnd
!
    if ( do_test ) then
!
        allocate( d2(n), e2(n), resid(n,n), resid2(n), id(n,n),  &
                  temp(n), temp2(n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       SAVE THE TRIDIAGONAL MATRIX .
!
        d2(:n) = d(:n)
        e2(:n) = e(: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 TRIDIAGONAL MATRIX TRID
!
!   WITH SUBROUTINE symtrid_qri.
!   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.
!
!   ON ENTRY OF symtrid_qri d AND e CONTAIN, RESPECTIVELY, THE DIAGONAL AND OFF-DIAGONAL
!   OF THE SYMMETRIC TRIDIAGONAL MATRIX TRID. IF THE OPTIONAL ARGUMENT init_mat IS SET TO
!   TRUE, THE MATRIX ARGUMENT eigvec IS INITIALIZED TO THE IDENTITY MATRIX AND THE SUBROUTINE
!   WILL COMPUTE THE EIGENVECTORS OF TRID. IF init_mat IS NOT USED OR SET TO FALSE, THE QR ITERATIONS
!   ARE DIRECTLY APPLIED TO eigvec WITHOUT ANY INITIAIZATION. THIS IS USEFUL FOR COMPUTING THE
!   EIGENVECTORS OF A SYMMETRIC MATRIX.
!
    call symtrid_qri( d(:n), e(:n), failure, eigvec(:n,:n), sort=sort, init_mat=true )
!
!   THE ROUTINE RETURNS THE EIGENVALUES AND THE EIGENVECTORS OF TRID.
!
!   ON EXIT OF symtrid_qri :
!
!       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 TRIDIAGONAL MATRIX TRID .
!
!       eigvec IS OVERWRITTEN WITH THE EIGENVECTORS, STORED COLUMNWISE;
!
!       d IS OVERWRITTEN WITH THE EIGENVALUES OF TRID.
!
!   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.
!
!   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 ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION TRID*U - U*D
!       WHERE D ARE THE EIGENVALUES AND U THE EIGENVECTORS OF THE TRIDIAGONAL MATRIX.
!
        do j=1_i4b, n
!
            temp(1_i4b:n) = eigvec(1_i4b:n,j)
!
            temp2(1_i4b)         = d2(1_i4b)*temp(1_i4b) + e2(1_i4b)*temp(2_i4b)
            temp2(2_i4b:n-1_i4b) = e2(1_i4b:n-2_i4b)*temp(1_i4b:n-2_i4b)           +   &
                                   d2(2_i4b:n-1_i4b)*temp(2_i4b:n-1_i4b)           +   &
                                   e2(2_i4b:n-1_i4b)*temp(3_i4b:n)
            temp2(n)             = e2(n-1_i4b)*temp(n-1_i4b) + d2(n)*temp(n)
!
            resid(1_i4b:n,j) = temp2(1_i4b:n) - d(j)*temp(1_i4b:n)
!
        end do
!
        resid2(:n) = norm( resid(:n,:n), dim=2_i4b )
        normt      = sqrt( sum( d2(1_i4b:n)**2 ) + sum( e2(1_i4b:n-1_i4b)**2 ) )
!
        err1 =  maxval( resid2(:n) )/( normt*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U
!       WHERE U ARE THE EIGENVECTORS OF THE TRIDIAGONAL MATRIX TRID.
!
        call unit_matrix( id(:n,:n) )
!
        resid(:n,:n) = abs( id(:n,:n) - matmul( transpose(eigvec(:n,:n)), eigvec(:n,:n) ) )
!
        err2 = maxval( resid(:n,:n) )/real(n,stnd)
!
        err = max( err1, err2 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( resid, resid2, id, temp, temp2, d2, e2, eigvec, d, e )
!
    else
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( eigvec, d, e )
!
    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
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', n, ' eigenvalues and eigenvectors of a ', &
       n, ' by ', n,' real tridiagonal matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_symtrid_qri
! ==============================
!
end program ex1_symtrid_qri

ex1_symtrid_qri2.F90

program ex1_symtrid_qri2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SYMTRID_QRI2
!   in module Eig_Procedures .
!                                                                              
!
! LATEST REVISION : 24/05/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, one, c50,            &
                         allocate_error, merror, symtrid_qri2, norm, 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
!
    integer(i4b), parameter :: prtunit=6, n=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of symtrid_qri2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err, eps, normt, elapsed_time
    real(stnd), allocatable, dimension(:)   :: d, e, d2, e2, temp, temp2, resid2
    real(stnd), allocatable, dimension(:,:) :: eigvec, resid, id
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: j
!
    logical(lgl) :: 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 : EIGENVALUES AND EIGENVECTORS OF A REAL SYMMETRIC
!               TRIDIAGONAL MATRIX USING THE QR METHOD WITH A
!               PERFECT SHIFT STRATEGY AND A WAVE FRONT ALGORITHM
!               FOR APPLYING GIVENS ROTATIONS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( eigvec(n,n), d(n), e(n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM TRIDIAGONAL MATRIX.
!   THE DIAGONAL ELEMENTS ARE STORED IN d .
!   THE OFF-DIAGONAL ELEMENTS ARE STORED IN e .
!
    call random_number( d(:n) )
    call random_number( e(:n) )

!    d(:n) = 0.5_stnd
!    e(:n) = 0.5_stnd

!    d(:n) = 1._stnd
!    e(:n) = 2._stnd
!
    if ( do_test ) then
!
        allocate( d2(n), e2(n), resid(n,n), resid2(n), id(n,n),  &
                  temp(n), temp2(n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       SAVE THE TRIDIAGONAL MATRIX .
!
        d2(:n) = d(:n)
        e2(:n) = e(: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 TRIDIAGONAL MATRIX TRID
!   WITH SUBROUTINE symtrid_qri2.
!
!   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.
!
!   ON ENTRY OF symtrid_qri2 d AND e CONTAIN, RESPECTIVELY, THE DIAGONAL AND OFF-DIAGONAL
!   OF THE SYMMETRIC TRIDIAGONAL MATRIX TRID. IF THE OPTIONAL ARGUMENT init_mat IS SET TO
!   TRUE, THE MATRIX ARGUMENT eigvec IS INITIALIZED TO THE IDENTITY MATRIX AND THE SUBROUTINE
!   WILL COMPUTE THE EIGENVECTORS OF TRID. IF init_mat IS NOT USED OR SET TO FALSE, THE QR ITERATIONS
!   ARE DIRECTLY APPLIED TO eigvec WITHOUT ANY INITIAIZATION. THIS IS USEFUL FOR COMPUTING THE
!   EIGENVECTORS OF A SYMMETRIC MATRIX.
!
    call symtrid_qri2( d(:n), e(:n), failure, eigvec(:n,:n), sort=sort, init_mat=true )
!
!   THE ROUTINE RETURNS THE EIGENVALUES AND THE EIGENVECTORS OF TRID.
!
!   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 TRIDIAGONAL MATRIX TRID .
!
!       eigvec IS OVERWRITTEN WITH THE EIGENVECTORS, STORED COLUMNWISE;
!
!       d IS OVERWRITTEN WITH THE EIGENVALUES OF TRID.
!
!   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.
!
!   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 ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION TRID*U - U*D
!       WHERE D ARE THE EIGENVALUES AND U THE EIGENVECTORS OF THE TRIDIAGONAL MATRIX.
!
        do j=1_i4b, n
!
            temp(1_i4b:n) = eigvec(1_i4b:n,j)
!
            temp2(1_i4b)         = d2(1_i4b)*temp(1_i4b) + e2(1_i4b)*temp(2_i4b)
            temp2(2_i4b:n-1_i4b) = e2(1_i4b:n-2_i4b)*temp(1_i4b:n-2_i4b)           +   &
                                   d2(2_i4b:n-1_i4b)*temp(2_i4b:n-1_i4b)           +   &
                                   e2(2_i4b:n-1_i4b)*temp(3_i4b:n)
            temp2(n)             = e2(n-1_i4b)*temp(n-1_i4b) + d2(n)*temp(n)
!
            resid(1_i4b:n,j) = temp2(1_i4b:n) - d(j)*temp(1_i4b:n)
!
        end do
!
        resid2(:n) = norm( resid(:n,:n), dim=2_i4b )
        normt      = sqrt( sum( d2(1_i4b:n)**2 ) + sum( e2(1_i4b:n-1_i4b)**2 ) )
!
        err1 =  maxval( resid2(:n) )/( normt*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U
!       WHERE U ARE THE EIGENVECTORS OF THE TRIDIAGONAL MATRIX TRID.
!
        call unit_matrix( id(:n,:n) )
!
        resid(:n,:n) = abs( id(:n,:n) - matmul( transpose(eigvec(:n,:n)), eigvec(:n,:n) ) )
!
        err2 = maxval( resid(:n,:n) )/real(n,stnd)
!
        err = max( err1, err2 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( resid, resid2, id, temp, temp2, d2, e2, eigvec, d, e )
!
    else
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( eigvec, d, e )
!
    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
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', n, ' eigenvalues and eigenvectors of a ', &
       n, ' by ', n,' real tridiagonal matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_symtrid_qri2
! ===============================
!
end program ex1_symtrid_qri2

ex1_symtrid_qri3.F90

program ex1_symtrid_qri3
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SYMTRID_QRI3
!   in module Eig_Procedures .
!                                                                              
!
! LATEST REVISION : 24/05/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, one, c50,            &
                         allocate_error, merror, symtrid_qri3, norm, 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
!
    integer(i4b), parameter :: prtunit=6, n=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of symtrid_qri3'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err, eps, normt, elapsed_time
    real(stnd), allocatable, dimension(:)   :: d, e, d2, e2, temp, temp2, resid2
    real(stnd), allocatable, dimension(:,:) :: eigvec, resid, id
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: j
!
    logical(lgl) :: 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 : EIGENVALUES AND EIGENVECTORS OF A REAL SYMMETRIC
!               TRIDIAGONAL MATRIX USING THE QR METHOD WITH A
!               WAVE FRONT ALGORITHM FOR APPLYING GIVENS ROTATIONS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( eigvec(n,n), d(n), e(n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM TRIDIAGONAL MATRIX.
!   THE DIAGONAL ELEMENTS ARE STORED IN d .
!   THE OFF-DIAGONAL ELEMENTS ARE STORED IN e .
!
    call random_number( d(:n) )
    call random_number( e(:n) )

!    d(:n) = 0.5_stnd
!    e(:n) = 0.5_stnd

!    d(:n) = 1._stnd
!    e(:n) = 2._stnd
!
    if ( do_test ) then
!
        allocate( d2(n), e2(n), resid(n,n), resid2(n), id(n,n),  &
                  temp(n), temp2(n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       SAVE THE TRIDIAGONAL MATRIX .
!
        d2(:n) = d(:n)
        e2(:n) = e(: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 TRIDIAGONAL MATRIX TRID
!   WITH SUBROUTINE symtrid_qri3.
!
!   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.
!
!   ON ENTRY OF symtrid_qri3 d AND e CONTAIN, RESPECTIVELY, THE DIAGONAL AND OFF-DIAGONAL
!   OF THE SYMMETRIC TRIDIAGONAL MATRIX TRID. IF THE OPTIONAL ARGUMENT init_mat IS SET TO
!   TRUE, THE MATRIX ARGUMENT eigvec IS INITIALIZED TO THE IDENTITY MATRIX AND THE SUBROUTINE
!   WILL COMPUTE THE EIGENVECTORS OF TRID. IF init_mat IS NOT USED OR SET TO FALSE, THE QR ITERATIONS
!   ARE DIRECTLY APPLIED TO eigvec WITHOUT ANY INITIAIZATION. THIS IS USEFUL FOR COMPUTING THE
!   EIGENVECTORS OF A SYMMETRIC MATRIX.
!
    call symtrid_qri3( d(:n), e(:n), failure, eigvec(:n,:n), sort=sort, init_mat=true )
!
!   THE ROUTINE RETURNS THE EIGENVALUES AND THE EIGENVECTORS OF TRID.
!
!   ON EXIT OF symtrid_qri3 :
!
!       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 TRIDIAGONAL MATRIX TRID .
!
!       eigvec IS OVERWRITTEN WITH THE EIGENVECTORS, STORED COLUMNWISE;
!
!       d IS OVERWRITTEN WITH THE EIGENVALUES OF TRID.
!
!   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.
!
!   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 ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION TRID*U - U*D
!       WHERE D ARE THE EIGENVALUES AND U THE EIGENVECTORS OF THE TRIDIAGONAL MATRIX.
!
        do j=1_i4b, n
!
            temp(1_i4b:n) = eigvec(1_i4b:n,j)
!
            temp2(1_i4b)         = d2(1_i4b)*temp(1_i4b) + e2(1_i4b)*temp(2_i4b)
            temp2(2_i4b:n-1_i4b) = e2(1_i4b:n-2_i4b)*temp(1_i4b:n-2_i4b)           +   &
                                   d2(2_i4b:n-1_i4b)*temp(2_i4b:n-1_i4b)           +   &
                                   e2(2_i4b:n-1_i4b)*temp(3_i4b:n)
            temp2(n)             = e2(n-1_i4b)*temp(n-1_i4b) + d2(n)*temp(n)
!
            resid(1_i4b:n,j) = temp2(1_i4b:n) - d(j)*temp(1_i4b:n)
!
        end do
!
        resid2(:n) = norm( resid(:n,:n), dim=2_i4b )
        normt      = sqrt( sum( d2(1_i4b:n)**2 ) + sum( e2(1_i4b:n-1_i4b)**2 ) )
!
        err1 =  maxval( resid2(:n) )/( normt*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U
!       WHERE U ARE THE EIGENVECTORS OF THE TRIDIAGONAL MATRIX TRID.
!
        call unit_matrix( id(:n,:n) )
!
        resid(:n,:n) = abs( id(:n,:n) - matmul( transpose(eigvec(:n,:n)), eigvec(:n,:n) ) )
!
        err2 = maxval( resid(:n,:n) )/real(n,stnd)
!
        err = max( err1, err2 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( resid, resid2, id, temp, temp2, d2, e2, eigvec, d, e )
!
    else
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( eigvec, d, e )
!
    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
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', n, ' eigenvalues and eigenvectors of a ', &
       n, ' by ', n,' real tridiagonal matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex1_symtrid_qri3
! ===============================
!
end program ex1_symtrid_qri3

ex1_symtrid_ratqri.F90

program ex1_symtrid_ratqri
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SYMTRID_RATQRI
!   in module Eig_Procedures .
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine TRID_INVITER in module Eig_Procedures.
!
! LATEST REVISION : 01/09/2012
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, one, two, c50,     &
                         trid_inviter, symtrid_ratqri, norm, unit_matrix 
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=1000, neig=200
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of symtrid_ratqri'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err, eps
    real(stnd), dimension(n)                :: d, e, e2, eigval
    real(stnd), dimension(n,neig)           :: eigvec
    real(stnd), allocatable, dimension(:,:) :: a, a2, resid
!
    integer      :: iok
    integer(i4b) :: maxiter=2, l
!
    logical(lgl) :: failure, do_test
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
!
    err = zero
    do_test = true
!
!   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
!
!   SAVE THE TRIDIAGONAL FORM .
!
    eigval(:n) = d(:n)
    e2(:n)     = e(:n)
!
!   COMPUTE EIGENVALUES OF THE TRIDIAGONAL MATRIX.
!
    call symtrid_ratqri( eigval(:n), e2(:n), neig, failure )
!
    if ( .not. failure ) then
!
!       COMPUTE THE FIRST neig EIGENVECTORS OF THE (1-2-1) TRIDIAGONAL MATRIX BY maxiter INVERSE ITERATIONS.
!
        call trid_inviter( d(:n), e(:n), eigval(:neig), eigvec(:n,:neig), failure, maxiter=maxiter )
!
        if ( do_test ) then
!
            allocate( a(n,n), a2(neig,neig), resid(n,neig), stat=iok )
!
            if ( iok/=0 ) then
                write (prtunit,*)  'Problem in attempt to allocate memory !'
                stop
            end if
!
!           FORM THE TRIDIAGONAL MATRIX
!
            a(:n,:n) = zero
!
            do l = 1_i4b, n-1_i4b
                a(l,l)       = d(l)
                a(l+1_i4b,l) = e(l)
                a(l,l+1_i4b) = e(l)
            end do
            a(n,n) = d(n)
!
!           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.
!
            resid = matmul( a, eigvec ) - eigvec*spread( eigval(:neig), 1, n )
            err1 = norm(resid)/( norm(a)*real(n,stnd) )
!
!           CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u**(t)*u
!           WHERE u are THE EIGENVECTORS OF THE TRIDIAGONAL MATRIX a.
!
            call unit_matrix( a2 )
!
            resid(:neig,:neig) = a2 - matmul( transpose( eigvec ), eigvec )
            err2 = norm(resid(:neig,:neig))/real(n,stnd)
!
            err = max( err1, err2 )
!
            deallocate( a, a2, resid )
!
        end if
!
    end if
!
    if ( err<=eps .and. .not.failure ) then
        write (prtunit,*) 'Example 1 of SYMTRID_RATQRI is correct'
    else
        write (prtunit,*) 'Example 1 of SYMTRID_RATQRI is incorrect'
    end if
!
!
! END OF PROGRAM ex1_symtrid_ratqri
! =================================
!
end program ex1_symtrid_ratqri

ex1_symtrid_ratqri2.F90

program ex1_symtrid_ratqri2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SYMTRID_RATQRI2
!   in module Eig_Procedures .
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine TRID_INVITER in module Eig_Procedures.
!
! LATEST REVISION : 01/09/2012
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, one, two, ten, c50,     &
                         trid_inviter, symtrid_ratqri2, norm, unit_matrix 
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=1000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of symtrid_ratqri2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err, eps
    real(stnd), dimension(n)                :: d, e, e2, eigval
    real(stnd), allocatable, dimension(:,:) :: eigvec, a, a2, resid
!
    integer      :: iok
    integer(i4b) :: maxiter=2, l, neig
!
    logical(lgl) :: failure, do_test
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
!
    err = zero
    do_test = true
!
!   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
!
!   SAVE THE TRIDIAGONAL FORM .
!
    eigval(:n) = d(:n)
    e2(:n)     = e(:n)
!
!   COMPUTE EIGENVALUES OF THE TRIDIAGONAL MATRIX.
!
    call symtrid_ratqri2( eigval(:n), e2(:n), ten, failure, neig )
!
    if ( .not. failure .and. neig>0 ) then
!
        allocate( eigvec(n,neig), stat=iok )
!
        if ( iok/=0 ) then
            write (prtunit,*)  'Problem in attempt to allocate memory !'
            stop
        end if
!
!       COMPUTE THE FIRST neig EIGENVECTORS OF THE (1-2-1) TRIDIAGONAL MATRIX BY maxiter INVERSE ITERATIONS.
!
        call trid_inviter( d(:n), e(:n), eigval(:neig), eigvec(:n,:neig), failure, maxiter=maxiter )
!
        if ( do_test ) then
!
            allocate( a(n,n), a2(neig,neig), resid(n,neig), stat=iok )
!
            if ( iok/=0 ) then
                write (prtunit,*)  'Problem in attempt to allocate memory !'
                stop
            end if
!
!           FORM THE TRIDIAGONAL MATRIX
!
            a(:n,:n) = zero
!
            do l = 1_i4b, n-1_i4b
                a(l,l)       = d(l)
                a(l+1_i4b,l) = e(l)
                a(l,l+1_i4b) = e(l)
            end do
            a(n,n) = d(n)
!
!           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.
!
            resid = matmul( a, eigvec ) - eigvec*spread( eigval(:neig), 1, n )
            err1 = norm(resid)/( norm(a)*real(n,stnd) )
!
!           CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u**(t)*u
!           WHERE u are THE EIGENVECTORS OF THE TRIDIAGONAL MATRIX a.
!
            call unit_matrix( a2 )
!
            resid(:neig,:neig) = a2 - matmul( transpose( eigvec ), eigvec )
            err2 = norm(resid(:neig,:neig))/real(n,stnd)
!
            err = max( err1, err2 )
!
            deallocate( a, a2, resid )
!
        end if
!
        deallocate( eigvec )
!
    end if
!
    if ( err<=eps .and. .not.failure ) then
        write (prtunit,*) 'Example 1 of SYMTRID_RATQRI2 is correct'
    else
        write (prtunit,*) 'Example 1 of SYMTRID_RATQRI2 is incorrect'
    end if
!
!
! END OF PROGRAM ex1_symtrid_ratqri2
! ==================================
!
end program ex1_symtrid_ratqri2

ex1_time_to_string.F90

program ex1_time_to_string
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of functions CPUSECS and TIME_TO_STRING
!   in module Time_Procedures .
!                                                                              
! LATEST REVISION : 06/07/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, extd, cpusecs, time_to_string
!   
!
! STRONG TYPING IMPOSED
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT.
!
    integer(i4b), parameter :: prtunit=6
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(extd)   :: tim1, tim2
!
    integer(i4b)  :: i, j
!
    character(len=13) :: string
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of time_to_string'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   FUNCTION cpusecs OBTAINS, FROM THE INTRINSIC ROUTINE SYSTEM_CLOCK,
!   THE CURRENT VALUE OF THE SYSTEM CPU USAGE CLOCK. THIS VALUE
!   IS THEN CONVERTED TO SECONDS AND RETURNED AS AN EXTENDED PRECISION
!   REAL VALUE.
!
!   THIS FUNCTIONS ASSUMES THAT THE NUMBER OF CPU CYCLES (CLOCK COUNTS) BETWEEN
!   TWO CALLS IS LESS THAN COUNT_MAX, THE MAXIMUM POSSIBLE VALUE OF CLOCK COUNTS
!   AS RETURNED BY THE INTRINSIC ROUTINE SYSTEM_CLOCK.
!
!   THIS ROUTINE WILL NOT WORK PROPERLY WITH OPENMP .
!
!   A TYPICAL USE OF THIS FUNCTION IS AS FOLLOWS :
!
    tim1 = cpusecs()
    j = 0
    do i=1, 1000000000
        j = j + 1
    end do
    tim2 = cpusecs()
!
!   CONVERT THE CPU TIME tim2-tim1 TO A STRING FORMAT FOR PRINTING AS
!
!           'milliseconds.seconds.minutes.hours'
!
!   WITH SUBROUTINE time_to_string .
!
    string = time_to_string( tim2-tim1 )
!
!   PRINT THE RESULT.
!
    write (prtunit, *)  " CPU Time(s): " // string //  " => milliseconds.seconds.minutes.hours "
!
!
! END OF PROGRAM ex1_time_to_string
! =================================
!
end program ex1_time_to_string

ex1_transpose2.F90

program ex1_transpose2
!
!
! Purpose
! =======
!
!   This program illustrates the use of function TRANSPOSE2
!   in module Module_Utilities and compares its efficiency with the intrinsic TRANSPOSE function. 
!                                                                              
! LATEST REVISION : 21/12/2015
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, transpose2, merror, allocate_error
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=10000, m=10000
!
    character(len=*), parameter :: name_proc='Example 1 of transpose2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: elapsed_time1, elapsed_time2
    real(stnd), dimension(:,:), allocatable :: a, a2, at
!
    integer :: iok, istart, iend, irate
!
    logical(lgl)                              :: do_test, failure
    logical(lgl), dimension(:,:), allocatable :: test
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : TRANSPOSITION OF A REAL MATRIX.
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,m), at(m,n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-by-m RANDOM REAL MATRIX a .
!
    call random_number( a(:n,:m) )
!
!   TRANSPOSE THE MATRIX WITH transpose2 FUNCTION.
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count=istart, count_rate=irate )
!
    at(:m,:n) = transpose2( a(:n,:m) )
!
!   STOP THE TIMER.
!
    call system_clock( count=iend )
!
    elapsed_time1 = real( iend - istart, stnd )/real( irate, stnd )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS .
!
        allocate( a2(n,m), test(n,m), stat=iok )
!
        if ( iok/=0 ) then
           call merror( name_proc//allocate_error )
        end if
!
        a2(:n,:m) = transpose2( at(:m,:n) )
!
!       CHECK THE RESULTS.
!
        test(:n,:m) = a(:n,:m) /= a2(:n,:m)
!
        failure = any( test(:n,:m) )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a2, test )
!
    end if
!
!   NOW TRANSPOSE THE MATRIX WITH INTRINSIC transpose FUNCTION.
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count=istart, count_rate=irate )
!
    at(:m,:n) = transpose( a(:n,:m) )
!
!   STOP THE TIMER.
!
    call system_clock( count=iend )
!
    elapsed_time2 = real( iend - istart, stnd )/real( irate, stnd )
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, at )
!
!   CHECK AND PRINT THE RESULTS.
!
    if ( .not. failure ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for transposing a real matrix of size ', n, ' by ', m,  &
       ' with transpose2() function is ', elapsed_time1, ' seconds'
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for transposing a real matrix of size ', n, ' by ', m,  &
       ' with the intrinsic transpose() function is ', elapsed_time2, ' seconds'
!
!
! END OF PROGRAM ex1_transpose2
! =============================
!
end program ex1_transpose2

ex1_trid_deflate.F90

program ex1_trid_deflate
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine TRID_DEFLATE
!   in module Eig_Procedures .
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutines SYMTRID_CMP and SYMTRID_BISECT
!    in module EIG_Procedures.
!                                                                              
! LATEST REVISION : 23/05/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, lamch, symtrid_cmp, trid_deflate,  &
                         symtrid_bisect, 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
!
    integer(i4b), parameter :: prtunit=6, n=3000, nvec=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of trid_deflate'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err, eps, safmin, abstol, elapsed_time
    real(stnd), allocatable, dimension(:)   :: eigval, resid2, d, e
    real(stnd), allocatable, dimension(:,:) :: a, eigvec, a2
!
    integer       :: iok, istart, iend, irate, imax, itime
    integer(i4b)  :: max_qr_steps, neig
!
    logical(lgl)  :: failure, failure2, do_test, ortho
!   
    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 : EIGENVALUES AND, OPTIONALLY, SELECTED EIGENVECTORS OF
!               A REAL SYMMETRIC MATRIX USING BISECTION FOR EIGENVALUES
!               AND A DEFLATION METHOD FOR THE EIGENVECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    safmin = lamch( 'S' )
    abstol = sqrt( safmin )
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), eigvec(n,nvec), eigval(n), d(n), e(n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A 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), resid2(nvec), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       SAVE 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 )
!
!   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 MATRIX TO SYMMETRIC TRIDIAGONAL FORM BY ORTHOGONAL
!   TRANSFORMATIONS WITH SUBROUTINE symtrid_cmp. THE ORTHOGONAL TRANSFORMATIONS
!   ARE SAVED IF THE OPTIONAL PARAMETER store_q IS SET TO TRUE.
!
    call symtrid_cmp( a(:n,:n), d(:n), e(:n), store_q=true )
!
!   ON EXIT OF symtrid_cmp:
!
!   a IS OVERWRITTEN WITH THE HOUSEHOLDER TRANSFORMATIONS USED TO REDUCE a
!   TO TRIDIAGONAL FORM IF THE OPTIONAL PARAMETER store_q IS SET TO TRUE,
!   OTHERWISE a IS DESTROYED.
!   ARGUMENTS d and e CONTAIN, RESPECTIVELY THE DIAGONAL AND OFF-DIAGONAL
!   ELEMENTS OF THE TRIDIAGONAL MATRIX.
!
!   SECOND, COMPUTE ALL EIGENVALUES OF THE SELF-ADJOINT MATRIX a TO HIGH
!   ACCURACY WITH SUBROUTINE symtrid_bisect.
!
    call symtrid_bisect( d(:n), e(:n), neig, eigval(:n), failure, &
                         sort=sort, abstol=abstol )
!
!   ON EXIT OF symtrid_bisect:
!
!       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 AN INTERMEDIATE TRIDIAGONAL FORM TRID OF a.
!
!       eigval IS OVERWRITTEN WITH THE EIGENVALUES OF THE TRIDIAGONAL MATRIX.
!       IF SORT = 'a' OR 'A', THE EIGENVALUES ARE SORTED INTO ASCENDING ORDER.
!       IF SORT = 'd' OR 'D', THE EIGENVALUES ARE SORTED INTO DESCENDING ORDER.
!
!   NEXT, COMPUTE THE FIRST nvec EIGENVECTORS OF THE SELF-ADJOINT MATRIX a BY A
!   DEFLATION TECHNIQUE APPLIED ON THE INTERMEDIATE TRIDIAGONAL MATRIX
!   AND BACK-TRANSFORMATION.
!
!   ON ENTRY OF SUBROUTINE trid_deflate, PARAMETER eigval CONTAINS SELECTED
!   EIGENVALUES OF THE TRIDIAGONAL MATRIX.
!   THE EIGENVALUES VALUES MUST BE GIVEN IN DECREASING ORDER.
!
    ortho = false
    max_qr_steps = 4_i4b
!
    call trid_deflate( d(:n), e(:n), eigval(:nvec), eigvec(:n,:nvec), failure=failure2,     &
                       mat=a, ortho=ortho, max_qr_steps=max_qr_steps )
!
!   ON EXIT OF trid_deflate :
!
!       failure= false :  INDICATES SUCCESSFUL EXIT.
!       failure= true  :  INDICATES THAT MAXIMUM ACCURACY WAS NOT OBTAIN IN THE ALGORITHM.
!
!       eigvec CONTAINS THE nvec EIGENVECTORS OF a ASSOCIATED WITH THE EIGENVALUES eigval(:nvec).
!
!   trid_deflate MAY FAIL IF SOME THE EIGENVALUES SPECIFIED IN PARAMETER eigval ARE NEARLY
!   IDENTICAL AND IF THESE EIGENVALUES ARE NOT COMPUTED WITH HIGH ACCURACY.
!
!   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 ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*U - U*D
!
        a(:n,:nvec) = matmul( a2, eigvec ) - eigvec*spread( eigval(:nvec), 1, n )
        resid2(:nvec) = norm( a(:n,:nvec), dim=2_i4b )
!
        err1 =  maxval( resid2(:nvec) )/( norm( a2 )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U.
!
        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 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, a2, eigvec, eigval, d, e, resid2 )
!
    else
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, eigvec, eigval, d, e )
!
    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
!
    if ( do_test ) 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,i5,a,i5,a,i5,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_trid_deflate
! ===============================
!
end program ex1_trid_deflate

ex1_trid_inviter.F90

program ex1_trid_inviter
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine TRID_INVITER
!   in module Eig_Procedures .
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine EIGVAL_CMP in module EIG_Procedures.
!                                                                              
! LATEST REVISION : 23/05/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, trid_inviter, eigval_cmp,  &
                         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
!
    integer(i4b), parameter :: prtunit=6, n=3000, nvec=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 1 of trid_inviter'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err, eps, elapsed_time
    real(stnd), allocatable, dimension(:)   :: eigval, resid2
    real(stnd), allocatable, dimension(:,:) :: a, eigvec, a2, d_e
!
    integer       :: iok, istart, iend, irate, imax, itime
    integer(i4b)  :: maxiter=2
!
    logical(lgl)  :: failure, failure2, 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 : EIGENVALUES AND, OPTIONALLY, SELECTED EIGENVECTORS OF
!               A REAL SYMMETRIC MATRIX USING THE INVERSE ITERATION METHOD.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), eigvec(n,nvec), eigval(n), d_e(n,2_i4b), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A 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), resid2(nvec), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       SAVE 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 )
!
!   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, COMPUTE ALL EIGENVALUES OF THE SELF-ADJOINT MATRIX a AND SAVE
!   THE INTERMEDIATE TRIDIAGONAL MATRIX IN PARAMETER d_e WITH
!   SUBROUTINE eigval_cmp.
!
    call eigval_cmp( a, eigval, failure=failure, sort=sort, d_e=d_e )
!
!   ON EXIT OF eigval_cmp:
!
!       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 AN INTERMEDIATE TRIDIAGONAL FORM TRID OF a.
!
!       a IS OVERWRITTEN WITH THE HOUSEHOLDER TRANSFORMATIONS USED TO REDUCE a
!       TO TRIDIAGONAL FORM IF THE OPTIONAL PARAMETER d_e IS PRESENT, OTHERWISE
!       a IS DESTROYED.
!
!       eigval 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.
!
!       d_e IS AN OPTIONAL ARGUMENT TO SAVE THE INTERMEDIATE TRIDIAGONAL FORM OF a.
!
!   NEXT COMPUTE THE FIRST nvec EIGENVECTORS OF THE SELF-ADJOINT MATRIX a BY
!   maxiter INVERSE ITERATIONS ON THE INTERMEDIATE TRIDIAGONAL MATRIX
!   d_e AND BACK-TRANSFORMATION.
!
!   ON ENTRY OF SUBROUTINE trid_inviter, PARAMETER eigval CONTAINS SELECTED
!   EIGENVALUES OF THE TRIDIAGONAL MATRIX.
!   THE EIGENVALUES VALUES MUST BE GIVEN IN DECREASING ORDER.
!
    call trid_inviter( d_e(:n,1), d_e(:n,2), eigval(:nvec), eigvec(:n,:nvec), failure=failure2,   &
                       mat=a, maxiter=maxiter )
!
!   ON EXIT OF trid_inviter :
!
!       failure= false :  INDICATES SUCCESSFUL EXIT
!       failure= true  :  INDICATES THAT MAXIMUM ACCURACY WAS NOT OBTAIN IN THE ALGORITHM

!       eigvec CONTAINS THE nvec EIGENVECTORS OF a ASSOCIATED WITH THE EIGENVALUES eigval(:nvec).
!
!       trid_inviter MAY FAIL IF SOME THE EIGENVALUES SPECIFIED IN PARAMETER eigval ARE NEARLY
!       IDENTICAL.
!
!   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 ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*U - U*D
!
        a(:n,:nvec) = matmul( a2, eigvec ) - eigvec*spread( eigval(:nvec), 1, n )
        resid2(:nvec) = norm( a(:n,:nvec), dim=2_i4b )
!
        err1 =  maxval( resid2(:nvec) )/( norm( a2 )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U.
!
        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 )
!
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, a2, eigvec, eigval, d_e, resid2 )
!
    else
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, eigvec, eigval, d_e )
!
    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
!
    if ( do_test ) 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,i5,a,i5,a,i5,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_trid_inviter
! ===============================
!
end program ex1_trid_inviter

ex1_ymd_to_daynum.F90

program ex1_ymd_to_daynum
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of function YMD_TO_DAYNUM
!   in module Time_Procedures .
!                                                                              
!   See also program ex1_daynum_to_ymd.f90 .                                                      
!                                                                              
! LATEST REVISION : 06/07/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, ymd_to_daynum, get_date
!   
!
! STRONG TYPING IMPOSED
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT.
!
    integer(i4b), parameter :: prtunit=6
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    integer(i4b) :: iyr, imon, iday, julday, iyr2, imon2, iday2, julday2
!
    character(len=11) :: date, date2
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of ymd_to_daynum'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A DATE.
!
    iyr  = 1902
    imon = 11
    iday = 15
!
!   GENERATE ANOTHER DATE.
!
    iyr2  = 1982
    imon2 = 10
    iday2 = 22
!
!   CONVERTS GREGORIAN YEAR (iyr), MONTH (imon) AND DAY (iday) TO JULIAN DAY
!   NUMBER.
!
    julday = ymd_to_daynum( iyr, imon, iday )
!
!   FUNCTION ymd_to_daynum CONVERTS THE THREE INTEGERS iyr, imon AND iday STANDING FOR
!   YEAR, MONTH, DAY IN THE GREGORIAN CALENDAR PROMULGATED BY GREGORY XIII ON
!   FRIDAY, 15 OCTOBER 1582, IN THE CORRESPONDING JULIAN DAY NUMBER STARTING
!   WITH ymd_to_daynum=1 ON FRIDAY, 15 OCTOBER 1582.
!
!   NOTE THE GREGORIAN CALENDAR WAS ADOPTED IN OCT. 15, 1582, AND HENCE
!   THIS FUNCTION WILL NOT WORK PROPERLY FOR DATES EARLY THAN 10-15-1582.
!   
!   CONVERTS GREGORIAN YEAR (iyr2), MONTH (imon2) AND DAY (iday2) TO JULIAN DAY
!   NUMBER.
!
    julday2 = ymd_to_daynum( iyr2, imon2, iday2 )
!
!   THE NUMBER OF DAYS BETWEEN TWO DATES IS THE DIFFERENCE BETWEEN THEIR
!   JULIAN DAY. SO, ONE OF THE MOST USEFUL APPLICATIONS FOR THIS ROUTINE
!   IS TO COMPUTE THE NUMBER OF DAYS BETWEEN TWO DATES.
!
    call get_date( iyr, imon, iday, date )
    call get_date( iyr2, imon2, iday2, date2 )
!
    write (prtunit,*)      &
      'The number of days between ' // date2 // ' and ' // date // ' is ', julday2-julday
!
!
! END OF PROGRAM ex1_ymd_to_daynum
! ================================
!
end program ex1_ymd_to_daynum

ex1_ymd_to_dayweek.F90

program ex1_ymd_to_dayweek
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of function YMD_TO_DAYWEEK
!   in module Time_Procedures .
!                                                                              
! LATEST REVISION : 06/07/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, ymd_to_dayweek, days, get_date
!   
!
! STRONG TYPING IMPOSED
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT.
!
    integer(i4b), parameter :: prtunit=6
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    integer(i4b) :: iyr, imon, iday, idayweek
!
    character(len=11) :: date
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 1 of ymd_to_dayweek'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A DATE.
!
    iyr  = 1902
    imon = 11
    iday = 15
!
!   DETERMINE THE DAY OF THE WEEK FROM FROM GREGORIAN YEAR (iyr),
!   MONTH (imon) AND DAY (iday).
!
    idayweek = ymd_to_dayweek( iyr, imon, iday )
!
!   FUNCTION ymd_to_dayweek RETURNS THE DAY OF THE WEEK (E.G., MON, TUE,...) AS AN INTEGER 
!   INDEX (MON=1 TO SUN=7) FOR THE GIVEN YEAR, MONTH, AND DAY IN THE GREGORIAN
!   CALENDAR PROMULGATED BY GREGORY XIII ON FRIDAY, 15 OCTOBER 1582.
!
!   NOTE THAT THE GREGORIAN CALENDAR WAS ADOPTED IN OCT. 15, 1582, AND HENCE
!   THIS ALGORITHM WILL NOT WORK PROPERLY FOR DATES EARLY THAN 10-15-1582.
!
!   PRINT THE RESULT.
!
    call get_date( iyr, imon, iday, date )
!
    write (prtunit,*) 'The date ' // date // ' is a ' // days(idayweek)
!
!
!
! END OF PROGRAM ex1_ymd_to_dayweek
! ================================
!
end program ex1_ymd_to_dayweek

ex2_bd_deflate2.F90

program ex2_bd_deflate2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine BD_DEFLATE2
!   in module SVD_Procedures .
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutines BD_CMP2 and BD_SINGVAL2 in module SVD_Procedures.
!                                                                              
! LATEST REVISION : 09/07/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, lamch, bd_cmp2, bd_singval2,  &
                         bd_deflate2, norm, unit_matrix, 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
!
    integer(i4b), parameter :: prtunit=6, n=6000, m=4000, nsing=4000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of bd_deflate2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, err3, eps, abstol, elapsed_time
    real(stnd), allocatable, dimension(:)   :: s, d, e
    real(stnd), allocatable, dimension(:,:) :: a, a2, p, leftvec, rightvec, resid
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: ns, max_qr_steps
!
    logical(lgl) :: failure1, failure2, failure3, ortho, do_test, gen_p
!   
    character    :: sort='d'
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 2 : PARTIAL SVD OF A n-BY-m REAL MATRIX WITH n>=m USING
!               THE RALHA-BARLOW ONE-SIDED BIDIAGONALISATION ALGORITHM, 
!               A BISECTION ALGORITHM FOR SINGULAR VALUES AND THE GODUNOV
!               DEFLATION TECHNIQUE FOR SINGULAR VECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps    = fudge*epsilon( err )
    abstol = sqrt( lamch('S') )
    err    = zero
!
    gen_p = false
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,m), p(m,m), leftvec(n,nsing), rightvec(m,nsing),      &
              s(m), d(m), e(m), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-BY-m RANDOM REAL MATRIX a.
!
    call random_number( a )
!
    if ( do_test ) then
!
        allocate( a2(n,m), resid(n,nsing), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       MAKE A COPY OF THE RANDOM DATA MATRIX.
!
        a2(:n,:m) = a(:n,:m)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL n-BY-m MATRIX a
!   IS WRITTEN
!
!                       a = U * S * V**(t)
!
!   WHERE S IS AN n-BY-m MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   min(m,n) DIAGONAL ELEMENTS, U IS AN n-BY-n ORTHOGONAL MATRIX, AND
!   V IS AN m-BY-m 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.
!
!   THIS PROGRAM ILLUSTRATES HOW TO COMPUTE ALL THE SINGULAR VALUES
!   OF a AND nsing LEFT AND RIGHT SINGULAR VECTORS OF a IN THREE STEPS:
!
!   STEP1 : CALL bd_cmp2 TO REDUCE THE MATRIX a TO BIDIAGONAL FORM
!
!               a = Q*BD*P**(t)
!
!   WHERE Q AND P ARE ORTHOGONAL AND BD IS AN UPPER BIDIAGONAL MATRIX.
!   bd_cmp2 USES THE ONE-SIDED RALHA-BARLOW ALGORITM AND IS FASTER THAN
!   THE STANDARD BIDIAGONALIZATION ALGORITHM USED IN bd_cmp. HOWEVER, A
!   A SLIGHT LOSS OF ORTHOGONALITY CAN BE EXPECTED FOR Q WHEN a IS NEARLY
!   SINGULAR SINCE Q IS COMPUTED FROM A RECURRENCE RELATIONSHIP.
!
    call bd_cmp2( a(:n,:m), d(:m), e(:m), p(:m,:m), failure=failure1, gen_p=gen_p )
!
!   ON OUTPUT OF bd_cmp2:
!
!       a CONTAINS THE FIRST min(m,n) COLUMNS OF Q
!       AND p CONTAINS THE ORTHOGONAL MATRIX P IN FACTORED FORM IF gen_p=false
!       OR IN EXPLICIT FORM IF gen_p=true.
!
!       d AND e CONTAINS RESPECTIVELY, THE DIAGONAL AND
!       SUBDIAGONAL OF THE BIDIAGONAL MATRIX BD.
!
!       failure= false :  INDICATES THAT MAXIMUM ACCURACY WAS OBTAINED.
!       failure= true  :  INDICATES THAT a IS NEARLY SINGULAR AND SOME LOSS
!                         OF ORTHOGONALITY FOR Q CAN BE EXPECTED.
!
!   STEP2 : COMPUTE SINGULAR VALUES OF THE BIDIAGONAL MATRIX (WHICH ARE ALSO THE
!   SINGULAR VALUES OF a) WITH SUBROUTINE bd_singval2 TO HIGH RELATIVE PRECISION.
!   THE SINGULAR VALUES ARE STORED IN s IN DECREASING ORDER (IF sort='d').
!
!   THE OPTIONAL ARGUMENT abstol OF bd_singval2 MAY BE USED TO INDICATE THE REQUIRED
!   PRECISION FOR THE SINGULAR VALUES. A SINGULAR VALUE IS CONSIDERED TO BE LOCATED
!   IF IT HAS BEEN DETERMINED TO LIE IN AN INTERVAL WHOSE WIDTH IS EQUAL OR LESS
!   THAN abstol. SINGULAR VALUES WILL BE COMPUTED MOST ACCURATELY WHEN abstol IS SET
!   TO THE SQUARE ROOT OF THE UNDERFLOW THRESHOLD (EG sqrt(LAMCH('S')) ).
!
    call bd_singval2( d(:m), e(:m), ns, s(:m), failure=failure2, sort=sort, abstol=abstol )
!
!   ON EXIT OF bd_singval2 :
!
!         failure= false :  INDICATES SUCCESSFUL EXIT
!         failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND THAT
!                           FULL  ACCURACY WAS NOT ATTAINED IN COMPUTING THE SINGULAR
!                           VALUES OF AN INTERMEDIATE BIDIAGONAL FORM BD OF a.
!
!         s IS OVERWRITTEN WITH THE SINGULAR VALUES OF THE BIDIAGONAL FORM BD OF a.
!
!         IF SORT = 'a' OR 'A', THE SINGULAR VALUES ARE SORTED INTO ASCENDING ORDER.
!         IF SORT = 'd' OR 'D', THE SINGULAR VALUES ARE SORTED INTO DESCENDING ORDER.
!
!   HERE, SORT = 'd' IS USED. THIS IS REQUIRED FOR THE USE OF bd_inviter2.
!
!   STEP3 : COMPUTE nsing LEFT AND RIGHT SINGULAR VECTORS OF a BY A DEFLATION TECHNIQUE
!   APPLIED TO THE INTERMEDIATE BIDIAGONAL MATRIX AND BACK-TRANSFORMATION WITH SUBROUTINE
!   bd_deflate2.
!
!   ON ENTRY OF bd_deflate2: PARAMETER s CONTAINS SELECTED SINGULAR VALUES OF THE BIDIAGONAL
!   MATRIX (OR OF a). THE SINGULAR VALUES MUST BE GIVEN IN DECREASING ORDER.
!
!   OPTIONAL PARAMETER ortho DETERMINES IF DEFLATION IS APPLIED SEQUENTIALLY TO ALL
!   COMPUTED SINGULAR VECTORS (ortho=true) OR ONLY IN EACH CLUSTER OF SINGULAR VALUES
!   (ortho=false). IN THE LATTER CASE, ORTHOGONALITY OF THE SINGULAR VECTORS MAY BE
!   SLIGHTLY DEGRADED, BUT COMPUTATIONS WILL BE MUCH FASTER.
!
    ortho = false
    max_qr_steps = 4_i4b
!
    call bd_deflate2( a(:n,:m), p(:m,:m), d(:m), e(:m), s(:nsing),                 &
                      leftvec(:n,:nsing), rightvec(:m,:nsing), failure=failure3,   &
                      ortho=ortho, max_qr_steps=max_qr_steps                       )
!
!   ON EXIT OF bd_deflate2 :
!
!       failure= false :  INDICATES SUCCESSFUL EXIT.
!       failure= true  :  INDICATES THAT MAXIMUM ACCURACY WAS NOT OBTAIN IN THE
!                         DEFLATION ALGORITHM.

!       leftvec AND rightvec CONTAIN, RESPECTIVELY, THE FIRST nsing LEFT AND RIGHT
!       SINGULAR VECTORS OF a .
!
!   bd_deflate2 MAY FAIL IF SOME THE SINGULAR VALUES SPECIFIED IN PARAMETER s ARE NEARLY
!   IDENTICAL FOR SOME PATHOLOGICAL MATRICES.
!
!   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 ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*V(:m,:nsing) - U(:n,:nsing)*S(:nsing,:nsing),
!       WHERE leftvec AND rightvec ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a.
!
        resid(:n,:nsing) = matmul(a2,rightvec) - leftvec*spread(s(:nsing),dim=1,ncopies=n)
        a2(:nsing,1_i4b) = norm( resid(:n,:nsing), dim=2_i4b )
!
        err1 = maxval( a2(:nsing,1_i4b) )/ ( sum( abs(s(:m)) )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U(:n,:nsing)**(t)*U(:n,:nsing).
!
        call unit_matrix( a2(:nsing,:nsing) )
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(leftvec), leftvec ) )
!
        err2 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - V(:m,:nsing)**(t)*V(:m,:nsing).
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(rightvec), rightvec ) )
!
        err3 = maxval( resid(:nsing,:nsing) )/real(m,stnd)
!
        err = max( err1, err2, err3 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a2, resid )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, p, leftvec, rightvec, s, d, e )
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. .not.failure2 .and. .not.failure3 ) then
!    if ( err<=eps .and. .not.failure1 .and. .not.failure2 .and. .not.failure3 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing all singular values and ', nsing, ' singular vectors of a ', &
       n, ' by ', m,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_bd_deflate2
! ==============================
!
end program ex2_bd_deflate2

ex2_bd_inviter.F90

program ex2_bd_inviter
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine BD_INVITER
!   in module SVD_Procedures .
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutines BD_CMP2 and BD_SVD in module SVD_Procedures
!    and subroutine APPLY_Q_QR in module QR_Procedures.
!
! LATEST REVISION : 10/06/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, half, one, c100, bd_inviter, bd_svd, &
                         bd_cmp2, unit_matrix, norm, merror, allocate_error, apply_q_qr
#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
!
    integer(i4b), parameter :: prtunit=6, m=6000, n=3000, nsing=3000
!   
    real(stnd), parameter  :: fudge=c100
!
    character(len=*), parameter :: name_proc='Example 2 of bd_inviter'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err3, err, eps, elapsed_time
    real(stnd), allocatable, dimension(:)   :: d, e, sup, singval
    real(stnd), allocatable, dimension(:,:) :: a, a2, p, resid, leftvec, rightvec, leftvec0, rightvec0
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: maxiter=2
!
    logical(lgl) :: failure1, failure2, failure3, bd_is_upper, gen_p, do_test
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 2 : PARTIAL SVD OF A REAL m-BY-n MATRIX USING THE Ralha-Barlow ONE_SIDED ALGORITHM,
!               THE GOLUB-REINSCH ALGORITHM FOR ALL SINGULAR VALUES AND THE INVERSE ITERATION
!               TECHNIQUE FOR SELECTED SINGULAR VECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    bd_is_upper = true
    gen_p       = false
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    if ( gen_p ) then
!
        allocate( a(m,n), p(n,n), d(n), e(n), singval(n),           &
                  sup(n), leftvec(m,nsing), rightvec(n,nsing),      &
                  leftvec0(n,nsing), rightvec0(n,nsing), stat=iok   )
!
    else
!
        allocate( a(m,n), p(n,n), d(n), e(n), singval(n),           &
                  sup(n), leftvec(m,nsing), rightvec(n,nsing),      &
                  leftvec0(n,nsing), stat=iok   )
!
    end if
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM DATA MATRIX .
!
    call random_number( a )
!
    if ( do_test ) then
!
        allocate( a2(m,n), resid(m,nsing), 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 )
!
!   FIRST CALL bd_cmp2 TO REDUCE THE MATRIX a TO BIDIAGONAL FORM
!
!               a = Q*BD*P**(t)
!
!   WHERE Q AND P ARE ORTHOGONAL AND BD IS AN UPPER BIDIAGONAL MATRIX.
!   bd_cmp2 USES THE ONE_SIDED RHALA-BARLOW ALGORITM AND IS FASTER THAN
!   THE STANDARD BIDIAGONALIZATION ALGORITHM USED IN bd_cmp. HOWEVER, A
!   A SLIGHT LOSS OF ORTHOGONALITY CAN BE EXPECTED FOR Q SINCE Q IS
!   COMPUTED FROM A RECURRENCE RELATIONSHIP.
!
    call bd_cmp2( a, d, e, p, failure=failure1, gen_p=gen_p )
!
!   ON OUTPUT OF bd_cmp2:
!
!       a CONTAINS THE FIRST min(n,m) COLUMNS OF Q
!       AND p CONTAINS THE ORTHOGONAL MATRIX P IN FACTORED FORM IF gen_p=false
!       OR IN EXPLICIT FORM IF gen_p=true.
!
!       d AND e CONTAINS RESPECTIVELY, THE DIAGONAL AND
!       SUBDIAGONAL OF THE BIDIAGONAL MATRIX BD.
!
!       failure= false :  INDICATES SUCCESSFUL EXIT.
!       failure= true  :  INDICATES THAT a IS NEARLY SINGULAR AND SOME LOSS
!                         OF ORTHOGONALITY FOR Q CAN BE EXPECTED.
!
!   NEXT COMPUTE ALL SINGULAR VALUES OF THE BIDIAGONAL MATRIX BD .
!   THE SINGULAR VALUES ARE STORED IN singval IN DECREASING ORDER (sort='d').
!
    singval(:n) = d(:n)
    sup(:n)     = e(:n)
!
    call bd_svd( bd_is_upper, singval(:n), sup(:n), failure=failure2, sort=sort  )
!
!   ON EXIT OF bd_svd :
!
!         failure= false :  INDICATES SUCCESSFUL EXIT.
!         failure= true  :  INDICATES THAT MAXIMUM ACCURACY WAS NOT OBTAIN IN THE BIDIAGONAL QR ALGORITHM.
!
!   NOW COMPUTE THE FIRST nsing SINGULAR VECTORS OF BD BY maxiter INVERSE ITERATIONS WITH
!   SUBROUTINE bd_inviter. THE SINGULAR VALUES MUST BE GIVEN IN DECREASING ORDER.
!
    if ( gen_p ) then
!
        call bd_inviter( bd_is_upper, d(:n), e(:n), singval(:nsing), leftvec0(:n,:nsing), rightvec0(:n,:nsing),  &
                         failure=failure3, maxiter=maxiter )
!
    else
!
        call bd_inviter( bd_is_upper, d(:n), e(:n), singval(:nsing), leftvec0(:n,:nsing), rightvec(:n,:nsing),  &
                         failure=failure3, maxiter=maxiter )
!
    end if
!
!   ON EXIT OF bd_inviter :
!
!         failure= false :  INDICATES SUCCESSFUL EXIT.
!         failure= true  :  INDICATES THAT MAXIMUM ACCURACY WAS NOT OBTAIN IN THE ALGORITHM.
!
!         leftvec AND rightvec CONTAIN, RESPECTIVELY, THE nsing LEFT AND RIGHT SINGULAR
!         VECTORS OF THE BIDIAGONAL MATRIX BD ASSOCIATED WITH THE SINGULAR VALUES singval(:nsing).
!
!   bd_inviter MAY FAIL IF SOME THE SINGULAR VALUES SPECIFIED IN PARAMETER singval ARE NEARLY
!   IDENTICAL FOR SOME PATHOLOGICAL BIDIAGONAL MATRICES.
!
!   FINALLY COMPUTE SINGULAR VECTORS OF THE ORIGINAL MATRIX BY MULTIPLICATION OR BACK-TRANSFORMATION.
!
    if ( gen_p ) then
!
        rightvec(:n,:nsing) = matmul( p(:n,:n), rightvec0(:n,:nsing) )
!
    else
!
        call apply_q_qr( p(2_i4b:n,2_i4b:n), p(2_i4b:n,1_i4b), rightvec(2_i4b:n,:nsing),  &
                         left=true, trans=false  )
!
    end if
!
    leftvec(:m,:nsing) = matmul( a(:m,:n), leftvec0(:n,:nsing) )
!
!   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 ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*V(:n,:nsing) - U(:m,:nsing)*S(:nsing,:nsing),
!       WHERE leftvec AND rightvec ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a.
!
        resid(:m,:nsing) = matmul(a2,rightvec) - leftvec*spread(singval(:nsing),dim=1,ncopies=m)
        a2(:nsing,1_i4b) = norm( resid(:m,:nsing), dim=2_i4b )
!
        err1 = maxval( a2(:nsing,1_i4b) )/( sum( abs(singval(:n)) )*real(m,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U(:n,:nsing)**(t)*U(:n,:nsing).
!
        call unit_matrix( a2(:nsing,:nsing) )
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(leftvec), leftvec ) )
!
        err2 = maxval( resid(:nsing,:nsing) )/real(m,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - V(:m,:nsing)**(t)*V(:m,:nsing).
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(rightvec), rightvec ) )
!
        err3 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
        err = max( err1, err2, err3 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a2, resid )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( gen_p ) then
!
        deallocate( a, p, leftvec, rightvec, leftvec0, rightvec0, singval, d, e, sup )
!
    else
!
        deallocate( a, p, leftvec, rightvec, leftvec0, singval, d, e, sup )
!
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. .not.failure2 .and. .not.failure3 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing all singular values and ', nsing, ' singular vectors of a ', &
       m, ' by ', n,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_bd_inviter
! =============================
!
end program ex2_bd_inviter

ex2_bd_inviter2.F90

program ex2_bd_inviter2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine BD_INVITER2
!   in module SVD_Procedures.
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutines BD_CMP2 and BD_SVD in module SVD_Procedures.
!                                                                              
! LATEST REVISION : 06/06/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, zero, true, false, bd_inviter2, bd_cmp2, bd_svd, &
                         norm, unit_matrix, 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
!
    integer(i4b), parameter :: prtunit=6, n=15000, m=10000, nsing=100
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of bd_inviter2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, err3, eps, elapsed_time
    real(stnd), allocatable, dimension(:)   :: s, d, e, e2
    real(stnd), allocatable, dimension(:,:) :: a, a2, p, leftvec, rightvec, resid
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: maxiter=2
!
    logical(lgl) :: failure1, failure2, failure3, do_test, gen_p
!   
    character    :: sort='d'
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 2 : ALL SINGULAR VALUES AND nsing SINGULAR VECTORS OF A n-BY-m REAL MATRIX WITH n>=m
!               USING THE RALHA-BARLOW ONE-SIDED BIDIAGONALISATION ALGORITHM, THE BIDIAGONAL QR
!               ALGORITHM FOR THE SINGULAR VALUES AND THE INVERSE ITERATION METHOD FOR THE 
!               SINGULAR VECTORS (EG PARTIAL SVD DECOMPOSITION).
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    gen_p = false
!
    do_test = false
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,m), p(m,m), leftvec(n,nsing), rightvec(m,nsing),      &
              s(m), d(m), e(m), e2(m), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-BY-m RANDOM REAL MATRIX a.
!
    call random_number( a )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( a2(n,m), resid(n,nsing), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       MAKE A COPY OF THE RANDOM DATA MATRIX .
!
        a2(:n,:m) = a(:n,:m)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL n-BY-m MATRIX a
!   IS WRITTEN
!
!                       a = U * S * V**(t)
!
!   WHERE S IS AN n-BY-m MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   min(m,n) DIAGONAL ELEMENTS, U IS AN n-BY-n ORTHOGONAL MATRIX, AND
!   V IS AN m-BY-m 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.
!
!   THIS PROGRAM ILLUSTRATES HOW TO COMPUTE ALL THE SINGULAR VALUES OF a AND
!   ONLY nsing LEFT AND RIGHT SINGULAR VECTORS OF a (EG A PARTIAL SVD DECOMPOSITION
!   OF a) IN THREE STEPS:
!
!   STEP1 : CALL bd_cmp2 TO REDUCE THE MATRIX a TO BIDIAGONAL FORM
!
!               a = Q*BD*P**(t)
!
!   WHERE Q AND P ARE ORTHOGONAL AND BD IS AN UPPER BIDIAGONAL MATRIX.
!   bd_cmp2 USES THE ONE-SIDED RHALA-BARLOW ALGORITM AND IS FASTER THAN
!   THE STANDARD BIDIAGONALIZATION ALGORITHM USED IN bd_cmp. HOWEVER, A
!   A SLIGHT LOSS OF ORTHOGONALITY CAN BE EXPECTED FOR Q WHEN a IS NEARLY
!   SINGULAR SINCE Q IS COMPUTED FROM A RECURRENCE RELATIONSHIP.
!
    call bd_cmp2( a(:n,:m), d(:m), e(:m), p(:m,:m), failure=failure1, gen_p=gen_p )
!
!   ON OUTPUT OF bd_cmp2:
!
!       a CONTAINS THE FIRST min(m,n) COLUMNS OF Q
!       AND p CONTAINS THE ORTHOGONAL MATRIX P IN FACTORED FORM IF gen_p=false
!       OR IN EXPLICIT FORM IF gen_p=true.
!
!       d AND e CONTAINS RESPECTIVELY, THE DIAGONAL AND
!       SUBDIAGONAL OF THE BIDIAGONAL MATRIX BD.
!
!       failure= false :  INDICATES THAT MAXIMUM ACCURACY WAS OBTAINED.
!       failure= true  :  INDICATES THAT a IS NEARLY SINGULAR AND SOME LOSS
!                         OF ORTHOGONALITY FOR Q CAN BE EXPECTED.
!
!   STEP2 : COMPUTE ALL SINGULAR VALUES OF THE BIDIAGONAL MATRIX BD WITH SUBROUTINE bd_svd.
!
!   FIRST MAKE A COPY OF THE BIDIAGONAL MATRIX BD FOR LATER USE WITH bd_inviter2 SUBROUTINE.
!
    s(:m)  = d(:m)
    e2(:m) = e(:m)
!
    call bd_svd( true, s(:m), e2(:m), failure=failure2, sort=sort  )
!
!   ON EXIT OF bd_svd :
!
!         failure= false :  INDICATES SUCCESSFUL EXIT
!         failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                           THAT FULL ACCURACY WAS NOT ATTAINED IN THE BIDIAGONAL
!                           SVD OF AN INTERMEDIATE BIDIAGONAL FORM BD OF a.
!
!         s IS OVERWRITTEN WITH THE SINGULAR VALUES OF a.
!
!         IF SORT = 'a' OR 'A', THE SINGULAR VALUES ARE SORTED INTO ASCENDING ORDER.
!         IF SORT = 'd' OR 'D', THE SINGULAR VALUES ARE SORTED INTO DESCENDING ORDER.
!
!   HERE, SORT = 'd' IS USED. THIS IS REQUIRED FOR THE USE OF bd_inviter2.
!
!   STEP3 : COMPUTE THE FIRST nsing LEFT AND RIGHT SINGULAR VECTORS OF a BY maxiter
!   INVERSE ITERATIONS ON THE INTERMEDIATE BIDIAGONAL MATRIX AND BACK-TRANSFORMATION
!   WITH SUBROUTINE bd_inviter2 .
!
!   ON ENTRY, PARAMETER s CONTAINS SELECTED SINGULAR VALUES OF THE BIDIAGONAL MATRIX d_e (OR a).
!   THE SINGULAR VALUES MUST BE GIVEN IN DECREASING ORDER.
!
    call bd_inviter2( a, p, d, e, s(:nsing), leftvec, rightvec, failure=failure3, maxiter=maxiter )
!
!   ON EXIT OF bd_inviter2 :
!
!         failure= false :  INDICATES SUCCESSFUL EXIT.
!         failure= true  :  INDICATES THAT THE ALGORITHM FAILS TO CONVERGE FOR SOME SINGULAR VECTORS.
!
!   THE SINGULAR VECTORS OF THE BIDIAGONAL FORM ARE COMPUTED USING maxiter INVERSE ITERATIONS
!   FOR ALL THE SINGULAR VALUES AT ONE STEP. THE SINGULAR VECTORS OF ARE THEN ORTHOGONALIZED BY 
!   THE MODIFIED GRAM-SCHMIDT ALGORITHM IF NECESSARY. THE SINGULAR VECTORS OF a ARE FINALLY COMPUTED 
!   BY BACK TRANSFORMATIONS. ON EXIT, leftvec AND rightvec CONTAIN THE FIRST nsing LEFT AND RIGHT
!   SINGULAR VECTORS OF a, RESPECTIVELY.
!
!   NOTE THAT bd_inviter2 MAY FAIL IF SOME THE SINGULAR VALUES SPECIFIED IN PARAMETER s ARE NEARLY
!   IDENTICAL FOR SOME PATHOLOGICAL MATRICES.
!
!   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 ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*V(:m,:nsing) - U(:n,:nsing)*S(:nsing,:nsing),
!       WHERE leftvec AND rightvec ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a.
!
        resid(:n,:nsing) = matmul(a2,rightvec) - leftvec*spread(s(:nsing),dim=1,ncopies=n)
        a2(:nsing,1_i4b) = norm( resid(:n,:nsing), dim=2_i4b )
        err1 = maxval( a2(:nsing,1_i4b) )/( sum( abs(s(:n)) )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U(:n,:nsing)**(t)*U(:n,:nsing).
!
        call unit_matrix( a2(:nsing,:nsing) )
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(leftvec), leftvec ) )
        err2 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - V(:m,:nsing)**(t)*V(:m,:nsing).
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(rightvec), rightvec ) )
        err3 = maxval( resid(:nsing,:nsing) )/real(m,stnd)
!
        err = max( err1, err2, err3 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a2, resid )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, p, leftvec, rightvec, s, d, e, e2 )
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. .not.failure2 .and. .not.failure3 ) then
!    if ( err<=eps .and. .not.failure1 .and. .not.failure2 .and. .not.failure3 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing all singular values and ', nsing, ' singular vectors of a ', &
       n, ' by ', m,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_bd_inviter2
! ==============================
!
end program ex2_bd_inviter2

ex2_bd_singval.F90

program ex2_bd_singval
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine BD_SINGVAL
!   in module SVD_Procedures .
!                                                                              
!                                                                              
! Further Details
! ===============
!
!    The program also shows the use of subroutines BD_CMP, APPLY_Q_BD, APPLY_P_BD
!    in module SVD_Procedures.
!
! LATEST REVISION : 22/07/2010
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, bd_inviter,     &
                         bd_cmp, bd_singval, apply_q_bd, apply_p_bd,        &
                         merror, allocate_error, norm, c50
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=1000, m=500, mn=min(m,n), ls=20
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of bd_singval'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, eps
    real(stnd), dimension(n,m)              :: a, a2
    real(stnd), dimension(:,:), allocatable :: leftvec, rightvec
    real(stnd), dimension(mn)               :: s, d, e, tauq, taup
!
    integer(i4b) :: maxiter=2, nsing
    integer      :: iok
!
    logical(lgl) :: failure, bd_is_upper
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
!
    err = zero
!
!   GENERATE A RANDOM DATA MATRIX a.
!
    call random_number( a )
!
!   SAVE RANDOM DATA MATRIX a .
!
    a2(:n,:m) = a(:n,:m)
!
!   REDUCE a TO LOWER OR UPPER BIDIAGONAL FORM.
!
    call bd_cmp( a, d, e, tauq, taup )
!
!   COMPUTE THE FIRST ls SINGULAR VALUES OF BIDIAGONAL FORM OF a BY A BISECTION METHOD.
!
    call bd_singval( d, e, nsing, s, failure, sort=sort, vector=true, ls=ls  )
!
    if ( .not. failure .and. nsing>0 ) then
!
!       ALLOCATE WORK VARIABLES NEEDED TO STORE THE SINGULAR VECTORS.
!
        allocate( leftvec(n,nsing),    &
                  rightvec(m,nsing),   &
                  stat = iok    )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
        bd_is_upper = n>=m
!
!       COMPUTE THE FIRST nsing SINGULAR VECTORS OF a BY maxiter
!       INVERSE ITERATIONS ON THE INTERMEDIATE BIDIAGONAL MATRIX
!       d_e AND BACK-TRANSFORMATION.
!
        call bd_inviter( bd_is_upper, d, e, s(:nsing), leftvec(:mn,:nsing), rightvec(:mn,:nsing),  &
                         failure, maxiter=maxiter )
!
!       COMPUTE SINGULAR VECTORS OF a BY BACK-TRANSFORMATION.
!
        if ( bd_is_upper ) then
            leftvec(mn+1_i4b:n,:nsing) = zero
        else
            rightvec(mn+1_i4b:m,:nsing) = zero
        end if
!
!       GENERATE LEFT SINGULAR VECTORS OF a IN leftvec BY BACK-TRANSFORMATION.
!
        call apply_q_bd( a, tauq, leftvec,  left=true, trans=false )
!
!       GENERATE RIGHT SINGULAR VECTORS OF a IN rightvec BY BACK-TRANSFORMATION.
!
        call apply_p_bd( a, taup, rightvec, left=true, trans=false )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*rightvec - leftvec*s(:nsing),
!       WHERE leftvec AND rightvec ARE THE LEFT AND RIGHT SINGULAR VECTORS.
!
        err =  norm( matmul(a2,rightvec) - leftvec*spread(s(:nsing),dim=1,ncopies=n) )/( norm( a2 )*real(mn,stnd) )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( leftvec,  rightvec  )
!
    end if
!
    if ( err<=eps .and. .not.failure ) then
        write (prtunit,*) 'Example 1 of BD_SINGVAL is correct'
    else
        write (prtunit,*) 'Example 1 of BD_SINGVAL is incorrect'
    end if
!
!
! END OF PROGRAM ex2_bd_singval
! =============================
!
end program ex2_bd_singval

ex2_bd_singval2.F90

program ex2_bd_singval2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine BD_SINGVAL2
!   in module SVD_Procedures .
!                                                                              
!                                                                              
! Further Details
! ===============
!
!    The program also shows the use of subroutines BD_CMP, APPLY_Q_BD, APPLY_P_BD
!    in module SVD_Procedures.
!
! LATEST REVISION : 22/07/2010
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, bd_inviter,     &
                         bd_cmp, bd_singval2, apply_q_bd, apply_p_bd,       &
                         merror, allocate_error, norm, c50
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=1000, m=500, mn=min(m,n), ls=20
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of bd_singval2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, eps
    real(stnd), dimension(n,m)              :: a, a2
    real(stnd), dimension(:,:), allocatable :: leftvec, rightvec
    real(stnd), dimension(mn)               :: s, d, e, tauq, taup
!
    integer(i4b) :: maxiter=2, nsing
    integer      :: iok
!
    logical(lgl) :: failure, bd_is_upper
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
!
    err = zero
!
!   GENERATE A RANDOM DATA MATRIX a.
!
    call random_number( a )
!
!   SAVE RANDOM DATA MATRIX a .
!
    a2(:n,:m) = a(:n,:m)
!
!   REDUCE a TO LOWER OR UPPER BIDIAGONAL FORM.
!
    call bd_cmp( a, d, e, tauq, taup )
!
!   COMPUTE THE FIRST ls SINGULAR VALUES OF BIDIAGONAL FORM OF a BY A BISECTION METHOD.
!
    call bd_singval2( d, e, nsing, s, failure, sort=sort, vector=true, ls=ls  )
!
    if ( .not. failure .and. nsing>0 ) then
!
!       ALLOCATE WORK VARIABLES NEEDED TO STORE THE SINGULAR VECTORS.
!
        allocate( leftvec(n,nsing),    &
                  rightvec(m,nsing),   &
                  stat = iok    )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
        bd_is_upper = n>=m
!
!       COMPUTE THE FIRST nsing SINGULAR VECTORS OF a BY maxiter
!       INVERSE ITERATIONS ON THE INTERMEDIATE BIDIAGONAL MATRIX
!       d_e AND BACK-TRANSFORMATION.
!
        call bd_inviter( bd_is_upper, d, e, s(:nsing), leftvec(:mn,:nsing), rightvec(:mn,:nsing),  &
                         failure, maxiter=maxiter )
!
!       COMPUTE SINGULAR VECTORS OF a BY BACK-TRANSFORMATION.
!
        if ( bd_is_upper ) then
            leftvec(mn+1_i4b:n,:nsing) = zero
        else
            rightvec(mn+1_i4b:m,:nsing) = zero
        end if
!
!       GENERATE LEFT SINGULAR VECTORS OF a IN leftvec BY BACK-TRANSFORMATION.
!
        call apply_q_bd( a, tauq, leftvec,  left=true, trans=false )
!
!       GENERATE RIGHT SINGULAR VECTORS OF a IN rightvec BY BACK-TRANSFORMATION.
!
        call apply_p_bd( a, taup, rightvec, left=true, trans=false )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*rightvec - leftvec*s(:nsing),
!       WHERE leftvec AND rightvec ARE THE LEFT AND RIGHT SINGULAR VECTORS.
!
        err =  norm( matmul(a2,rightvec) - leftvec*spread(s(:nsing),dim=1,ncopies=n) )/( norm( a2 )*real(mn,stnd) )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( leftvec,  rightvec  )
!
    end if
!
    if ( err<=eps .and. .not.failure ) then
        write (prtunit,*) 'Example 1 of BD_SINGVAL2 is correct'
    else
        write (prtunit,*) 'Example 1 of BD_SINGVAL2 is incorrect'
    end if
!
!
! END OF PROGRAM ex2_bd_singval2
! ==============================
!
end program ex2_bd_singval2

ex2_bd_svd.F90

program ex2_bd_svd
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine BD_SVD
!   in module SVD_Procedures .
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine BD_INVITER in module SVD_Procedures.
!
! LATEST REVISION : 28/09/2010
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, half, one, c50, &
                         bd_inviter, bd_svd, unit_matrix, norm
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=500, nsing=10
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of bd_svd'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err3, err, eps
    real(stnd), dimension(n)                :: diag, sup, sup2, singval
    real(stnd), dimension(n,nsing)          :: leftvec, rightvec
    real(stnd), allocatable, dimension(:,:) :: a, a2, resid
!
    integer      :: iok
    integer(i4b) :: maxiter=2
!
    logical(lgl) :: failure, a_is_upper, do_test
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
!
    err = zero
    do_test = true
!
!   GENERATE AN UPPER BIDIAGONAL TOEPLITZ MATRIX a.
!   THE DIAGONAL ELEMENTS ARE STORED IN diag .
!   THE OFF-DIAGONAL ELEMENTS ARE STORED IN sup .
!
    a_is_upper   = true
    diag(:n)     = half
    sup(1_i4b)   = zero
    sup(2_i4b:n) = one
!
!   MAKE A COPY OF THE BIDIAGONAL MATRIX.
!
    singval(:n) = diag(:n)
    sup2(:n)    = sup(:n)
!
!    COMPUTE SINGULAR VALUES OF BIDIAGONAL MATRIX a .
!
     call bd_svd( a_is_upper, singval(:n), sup2(:n), failure, sort=sort  )
!
     if ( .not. failure ) then
!
!       COMPUTE THE FIRST nsing SINGULAR VECTORS OF a BY maxiter INVERSE ITERATIONS.
!
        call bd_inviter( a_is_upper, diag(:n), sup(:n), singval(:nsing), leftvec(:n,:nsing), rightvec(:n,:nsing),  &
                         failure, maxiter=maxiter )
!
        if ( do_test ) then
!
            allocate( a(nsing,nsing), a2(nsing,nsing), resid(n,nsing), stat=iok )
!
            if ( iok/=0 ) then
                write (prtunit,*)  'Problem in attempt to allocate memory !'
                stop
            end if
!
!           CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*rightvec - leftvec*singval(:nsing),
!           WHERE leftvec AND rightvec ARE THE LEFT AND RIGHT SINGULAR VECTORS.
!
            if ( a_is_upper ) then
!
                resid(:n,:nsing) = spread( diag(:n),        dim=2, ncopies=nsing )*rightvec                 + &
                                   eoshift( spread(sup(:n), dim=2,ncopies=nsing)*rightvec, shift=1 )        - &
                                   spread( singval(:nsing), dim=1, ncopies=n )*leftvec 

            else
!
                resid(:n,:nsing) = spread( diag(:n),        dim=2, ncopies=nsing )*leftvec                   + &
                                   eoshift( spread(sup(:n), dim=2,ncopies=nsing)*leftvec, shift=1 )          - &
                                   spread( singval(:nsing), dim=1, ncopies=n )*rightvec
!
            end if
!
            err1 = norm(resid)/(sum( singval(:n) )*real(n,stnd) )
!
!           CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u**(t)*u
!           WHERE u are LEFT SINGULAR VECTORS OF THE BIDIAGONAL MATRIX a.
!
            call unit_matrix( a )
!
            a2 = a - matmul( transpose( leftvec ), leftvec )
            err2 = norm(a2)/real(n,stnd)
!
!           CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - v**(t)*v
!           WHERE v are RIGHT SINGULAR VECTORS OF THE BIDIAGONAL MATRIX a.
!
            a2 = a - matmul( transpose( rightvec ), rightvec )
            err3 = norm(a2)/real(n,stnd)
!
            err = max( err1, err2, err3 )
!
            deallocate( a, a2, resid )
!
        end if
!
    end if
!
    if ( err<=eps .and. .not.failure ) then
        write (prtunit,*) 'Example 2 of BD_SVD is correct'
    else
        write (prtunit,*) 'Example 2 of BD_SVD is incorrect'
    end if
!
!
! END OF PROGRAM ex2_bd_svd
! =========================
!
end program ex2_bd_svd

ex2_chol_cmp.F90

program ex2_chol_cmp
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines CHOL_CMP and CHOL_SOLVE
!   in module Lin_Procedures . 
!                                                                              
! LATEST REVISION : 15/06/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, zero, true, false, chol_cmp, chol_solve,   &
                         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
!
    integer(i4b), parameter :: prtunit=6, n=4000, m=n+10, nrhs=4000
!
    character(len=*), parameter :: name_proc='Example 2 of chol_cmp'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, eps, d1, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, c, b, x, res
    real(stnd), dimension(:),   allocatable :: invdiag
!
    integer :: iok, istart, iend, irate, imax, itime
!
    logical(lgl)   :: do_test, upper
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 2 : SOLVING A LINEAR SYSTEM WITH A REAL n-BY-n SYMMETRIC DEFINITE POSITIVE MATRIX
!               AND SEVERAL RIGHT HAND-SIDES WITH THE CHOLESKY DECOMPOSITION.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = sqrt( epsilon( err ) )
    err = zero
!
    do_test = false
    upper   = false
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( c(m,n), a(n,n), b(n,nrhs), x(n,nrhs), invdiag(n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-by-n RANDOM 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 .
!
!   BY COMPUTING THE CHOLESKY DECOMPOSITION OF MATRIX a .
!   IF ON OUTPUT OF chol_cmp d1 IS DIFFERENT FROM ZERO
!   THEN THE SYMMETRIC LINEAR SYSTEM IS NOT SINGULAR
!   AND CAN BE SOLVED BY SUBROUTINE chol_solve.
!
    call chol_cmp( a, invdiag, d1, upper=upper )
!
    if ( d1==zero ) then
!
!       ANORMAL EXIT FROM chol_cmp SUBROUTINE, PRINT A WARNING.
!
        write (prtunit,*) 'Error in exit of CHOL_CMP subroutine, d1=', d1
!
    else
!
        call chol_solve( a, invdiag, b, upper=upper )
!
    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 ( d1/=zero .and. 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 ARRAYS.
!
        deallocate( a, b, c, x, invdiag, res )
!
    else
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, b, c, x, invdiag )
!
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. d1/=zero ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for solving a positive definite symmetric system of size ', &
       n, ' with ', nrhs, ' right hand side vectors is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_chol_cmp
! ===========================
!
end program ex2_chol_cmp

ex2_comp_cor.F90

program ex2_comp_cor
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine COMP_COR
!   in module Mul_Stat_Procedures .
!                                                                              
! LATEST REVISION : 06/07/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, lgl, true, comp_cor
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=26, m=20, p=50
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                    :: err_xstat, err_ystat, err_cor, xyn, eps
    real(stnd), dimension(n,m)    :: xycor1, xycor2
    real(stnd), dimension(m,2)    :: ystat1, ystat2
    real(stnd), dimension(n,2)    :: xstat1, xstat2
    real(stnd), dimension(n,p)    :: x
    real(stnd), dimension(m,p)    :: y
!
    integer(i4b) :: i
!
    logical(lgl) :: first, last
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 2 of comp_cor'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
    eps = sqrt( epsilon(eps) )
!
!   GENERATE A RANDOM OBSERVATION ARRAY x .
!
    call random_number( x(:n,:p) )
!
!   GENERATE A RANDOM OBSERVATION ARRAY y .
!
    call random_number( y(:m,:p) )
!
!   COMPUTE THE CORRELATIONS BETWEEN x AND y
!   FOR THE p OBSERVATIONS .
!
    first = true
    last  = true
    call comp_cor( x(:n,:p), y(:m,:p), first, last,                    &
                   xstat1(:n,:2), ystat1(:m,:2), xycor1(:n,:m), xyn )
!
!   ON EXIT OF COMP_COR WHEN last=true :
!
!      xstat1(i,1) CONTAINS THE MEAN VALUES OF THE ARRAY SECTION x(i,:p).
!
!      xstat1(i,2) CONTAINS THE VARIANCES OF THE ARRAY SECTION x(i,:p).
!
!      ystat1(j,1) CONTAINS THE MEAN VALUE OF THE ARRAY SECTION y(j,:p).
!
!      ystat1(j,2) CONTAINS THE VARIANCE OF THE ARRAY SECTION y(j,:p).
!
!      xycor1(i,j) CONTAINS THE CORRELATION COEFFICIENT
!                  BETWEEN x(i,:p) AND y(j,:p).
!
!      xyn         CONTAINS THE NUMBER OF OBSERVATIONS IN THE DATA ARRAYS
!                  x(:n,:p) AND y(:m,:p) (xyn=real(p,stnd) ).
!
!   COMPUTE CORRELATIONS BETWEEN x AND y,
!   ITERATIVELY  FOR THE p OBSERVATIONS .
!
    do i = 1, p
!
        first = i==1
        last  = i==p
!
        call comp_cor( x(:n,i:i), y(:m,i:i), first, last,                      &
                       xstat2(:n,:2), ystat2(:m,:2), xycor2(:n,:m), xyn )
    end do
!
!   CHECK THAT THE TWO SETS OF STATISTICS AGREE.
!
    err_xstat = maxval( abs( ( xstat1-xstat2)/xstat1 ) )
    err_ystat = maxval( abs( ( ystat1-ystat2)/ystat1 ) )
    err_cor   = maxval( abs( xycor1-xycor2 ) )
!
    if ( max(err_xstat, err_ystat, err_cor )<=eps ) then
        write (prtunit,*) 'Example 2 of COMP_COR is correct'
    else
        write (prtunit,*) 'Example 2 of COMP_COR is incorrect'
    end if
!
!
! END OF PROGRAM ex2_comp_cor
! ===========================
!
end program ex2_comp_cor

ex2_comp_cor_miss.F90

program ex2_comp_cor_miss
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine COMP_COR_MISS
!   in module Mul_Stat_Procedures .
!                                                                              
! LATEST REVISION : 06/07/2006
!                                                                              
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, lgl, true, comp_cor_miss
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT.
!
    integer(i4b), parameter :: prtunit=6, n=26, m=20, p=50
!
! miss IS THE MISSING INDICATOR.
!
    real(stnd), parameter :: miss=-999.99_stnd
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                    :: err_xstat, err_ystat, err_cor, eps
    real(stnd), dimension(n,m,4)  :: xycor1, xycor2
    real(stnd), dimension(m,4)    :: ystat1, ystat2
    real(stnd), dimension(n,4)    :: xstat1, xstat2
    real(stnd), dimension(n,p)    :: x
    real(stnd), dimension(m,p)    :: y
!
    integer(i4b) :: i
!
    logical(lgl) :: first, last
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 2 of comp_cor_miss'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
    eps = sqrt( epsilon(eps) )
!
!   GENERATE A RANDOM OBSERVATION ARRAY x WITH MISSING VALUES.
!
    call random_number( x(:n,:p) )
    where ( x(:n,:p)<=0.05_stnd ) x(:n,:p) = miss
!
!   GENERATE A RANDOM OBSERVATION ARRAY y WITH MISSING VALUES.
!
    call random_number( y(:m,:p) )
    where ( y(:m,:p)<=0.05_stnd ) y(:m,:p) = miss
!
!   COMPUTE THE CORRELATIONS BETWEEN x AND y
!   FOR THE p OBSERVATIONS .
!
    first = true
    last  = true
    call comp_cor_miss( x(:n,:p), y(:m,:p), first, last, xstat1(:n,:4),               &
                        ystat1(:m,:4), xycor1(:n,:m,:4), xymiss=miss )
!
!   ON EXIT OF comp_cor_miss WHEN last=true :
!
!      xstat1(i,1) CONTAINS THE MEAN VALUES OF THE ARRAY SECTION x(i,:p).
!
!      xstat1(i,2) CONTAINS THE VARIANCES OF THE ARRAY SECTION x(i,:p).
!
!      xstat1(i,3) CONTAINS THE NUMBER OF NON-MISSING OBSERVATIONS
!                  IN THE ARRAY SECTION x(i,:p).
!
!      ystat1(j,1) CONTAINS THE MEAN VALUE OF THE ARRAY SECTION y(j,:p).
!
!      ystat1(j,2) CONTAINS THE VARIANCE OF THE ARRAY SECTION y(j,:p).
!
!      ystat1(j,3) CONTAINS THE NUMBER OF NON-MISSING OBSERVATIONS
!                  IN THE ARRAY SECTION y(j,:p).
!
!      xycor1(i,j,1) CONTAINS THE CORRELATION COEFFICIENT BETWEEN x(i,:p) AND y(j,:p)
!                    COMPUTED WITH THE ABOVE UNIVARIATE STATISTICS.
!
!      xycor1(i,j,2) CONTAINS THE INCIDENCE VALUE BETWEEN x(i,:p) AND y(j,:p).
!                    xycor1(i,j,2) INDICATES THE NUMBER OF VALID PAIRS OF OBSERVATIONS
!                    WHICH WHERE USED IN THE CALCULATION OF xycor1(i,j,1) .
!
!   xstat1(:,4), ystat1(:,4) AND xycor1(:,:,3:4) ARE USED AS WORKSPACE AND CONTAIN NO USEFUL
!   INFORMATION ON OUTPUT OF comp_cor_miss.
!
!   COMPUTE CORRELATIONS BETWEEN x AND y,
!   ITERATIVELY  FOR THE p OBSERVATIONS .
!
    do i = 1, p
!
        first = i==1
        last  = i==p
!
        call comp_cor_miss( x(:n,i:i), y(:m,i:i), first, last, xstat2(:n,:4),       &
                            ystat2(:m,:4), xycor2(:n,:m,:4), xymiss=miss )
    end do
!
!   CHECK THAT THE TWO SETS OF STATISTICS AGREE.
!
    err_xstat = maxval( abs( ( xstat1(:n,:3)-xstat2(:n,:3))/xstat1(:n,:3) ) )
    err_ystat = maxval( abs( ( ystat1(:m,:3)-ystat2(:m,:3))/ystat1(:m,:3) ) )
    err_cor   = maxval( abs( xycor1(:n,:m,:2)-xycor2(:n,:m,:2) ) )
!
    if ( max(err_xstat, err_ystat, err_cor )<=eps ) then
        write (prtunit,*) 'Example 2 of COMP_COR_MISS is correct'
    else
        write (prtunit,*) 'Example 2 of COMP_COR_MISS is incorrect'
    end if
!
!
!
! END OF PROGRAM ex2_comp_cor_miss
! ================================
!
end program ex2_comp_cor_miss

ex2_comp_cormat.F90

program ex2_comp_cormat
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine COMP_CORMAT
!   in module Mul_Stat_Procedures .
!                                                                              
! LATEST REVISION : 06/07/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, lgl, true, false, comp_cormat
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, m=20, p=500, n=(m*(m+1))/2
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                       :: err_mean, err_std, err_cor, eps, xn
    real(stnd), dimension(n)         :: corp1, corp2
    real(stnd), dimension(m,p)       :: x
    real(stnd), dimension(m)         :: mean1, mean2, std1, std2
!
    integer(i4b) :: i
!
    logical(lgl) :: first, last, cov
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 2 of comp_cormat'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
    eps = sqrt( epsilon(eps) )
!
!   GENERATE A RANDOM OBSERVATION ARRAY x .
!
    call random_number( x )
!
    cov = false
!
!   COMPUTE THE MEANS, STANDARD-DEVIATIONS AND CORRELATION MATRIX
!   OF x FOR THE p OBSERVATIONS .
!
    first = true
    last  = true
    call comp_cormat( x(:m,:p), first, last, mean1(:m), corp1(:n), xn,    &
                      xstd=std1(:m), cov=cov )
!
!   ON EXIT, WHEN last=true :
!
!     mean1(:m) CONTAINS THE VARIABLE MEANS COMPUTED FROM ALL OBSERVATIONS 
!     IN THE DATA MATRIX x.
!
!     THE UPPER TRIANGLE OF THE SYMMETRIC CORRELATION OR VARIANCE-COVARIANCE MATRIX cor,
!     AS CONTROLLED BY THE cov ARGUMENT, IS PACKED COLUMNWISE IN THE LINEAR ARRAY corp1.
!     MORE PRECISELY, THE J-TH COLUMN  OF cor IS STORED IN THE ARRAY CORP1 AS FOLLOWS:
!
!            corp1(i + (j-1)*j/2) = cor(i,j) for 1<=i<=j;
!
!     xn INDICATES THE NUMBERS OF OBSERVATIONS WHICH WERE 
!     USED IN THE CALCULATION OF corp1.
!
!     IF THE OPTIONAL ARGUMENT xstd IS PRESENT, xstd CONTAINS THE VARIABLE 
!     STANDARD-DEVIATIONS.
!
!   COMPUTE THE MEANS, STANDARD-DEVIATIONS AND CORRELATION MATRIX
!   OF x, ITERATIVELY  FOR THE p OBSERVATIONS .
!
    do i = 1, p
!
        first = i==1
        last =  i==p
!
        call comp_cormat( x(:m,i:i), first, last, mean2(:m), corp2(:n), xn,    &
                         xstd=std2(:m), cov=cov )
    end do
!
!   CHECK THAT THE TWO SETS OF STATISTICS AGREE.
!
    err_mean = maxval( abs( ( mean1-mean2)/mean1 ) )
    err_std  = maxval( abs( ( std1-std2)/std1    ) )
    err_cor  = maxval( abs( corp1-corp2 ) )
!
    if ( max(err_mean, err_std, err_cor )<=eps ) then
        write (prtunit,*) 'Example 2 of COMP_CORMAT is correct'
    else
        write (prtunit,*) 'Example 2 of COMP_CORMAT is incorrect'
    end if
!
!
!
! END OF PROGRAM ex2_comp_cormat
! ==============================
!
end program ex2_comp_cormat

ex2_comp_cormat_miss.F90

program ex2_comp_cormat_miss
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine COMP_CORMAT_MISS
!   in module Mul_Stat_Procedures .
!                                                                              
! LATEST REVISION : 06/07/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, lgl, true, false, comp_cormat_miss
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, m=20, p=500, n=(m*(m+1))/2
!
! miss IS THE MISSING INDICATOR.
!
    real(stnd), parameter :: miss=-999.99_stnd
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                       :: err_mean, err_std, err_cor, eps
    real(stnd), dimension(n)         :: corp1, corp2
    real(stnd), dimension(m,p)       :: x
    real(stnd), dimension(n,3)       :: xn
    real(stnd), dimension(m,2)       :: mean1, mean2
    real(stnd), dimension(m)         :: std1, std2
!
    integer(i4b) :: i
!
    logical(lgl) :: first, last, cov
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 2 of comp_cormat_miss'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
    eps = sqrt( epsilon(eps) )
!
!   GENERATE A RANDOM OBSERVATION ARRAY x WITH MISSING VALUES.
!
    call random_number( x(:m,:p) )
    where ( x(:m,:p)<=0.05_stnd ) x(:m,:p) = miss
!
    cov = false
!
!   COMPUTE THE MEANS, STANDARD-DEVIATIONS AND CORRELATION MATRIX
!   OF x FOR THE p OBSERVATIONS .
!
    first = true
    last  = true
    call comp_cormat_miss( x(:m,:p), first, last, mean1(:m,:2), corp1(:n), xn(:n,:3), miss,   &
                           xstd=std1(:m), cov=cov )
!
!   ON EXIT, WHEN last=true :
!
!     mean1(:m,1) CONTAINS THE VARIABLE MEANS COMPUTED FROM ALL NON-MISSING OBSERVATIONS 
!     IN THE DATA MATRIX x. mean1(:m,2) IS USED AS WORKSPACE.
!
!     THE UPPER TRIANGLE OF THE SYMMETRIC CORRELATION OR VARIANCE-COVARIANCE MATRIX cor,
!     AS CONTROLLED BY THE cov ARGUMENT, IS PACKED COLUMNWISE IN THE LINEAR ARRAY corp1.
!     MORE PRECISELY, THE J-TH COLUMN  OF cor IS STORED IN THE ARRAY CORP1 AS FOLLOWS:
!
!            corp1(i + (j-1)*j/2) = cor(i,j) for 1<=i<=j;
!
!     xn(:n,1) CONTAINS THE UPPER TRIANGLE OF THE MATRIX OF THE INCIDENCE VALUES
!     BETWEEN EACH PAIR OF VARIABLES, PACKED COLUMNWISE, IN A LINEAR ARRAY. 
!     xn(i + (j-1)*j/2,1) INDICATES THE NUMBERS OF NON-MISSING PAIRS WHICH WERE 
!     USED IN THE CALCULATION OF cor(i,j) for 1<=i<=j . xn(:n,2:3) IS USED AS WORKSPACE.
!     
!     IF THE OPTIONAL ARGUMENT xstd IS PRESENT, xstd CONTAINS THE VARIABLE 
!     STANDARD-DEVIATIONS COMPUTED FROM ALL NON-MISSING OBSERVATIONS.
!
!
!   COMPUTE THE MEANS, STANDARD-DEVIATIONS AND CORRELATION MATRIX
!   OF x, ITERATIVELY  FOR THE p OBSERVATIONS .
!
    do i = 1, p
!
        first = i==1
        last =  i==p
!
        call comp_cormat_miss( x(:m,i:i), first, last, mean2(:m,:2), corp2(:n), xn(:n,:3), miss,   &
                               xstd=std2(:m), cov=cov )
    end do
!
!   CHECK THAT THE TWO SETS OF STATISTICS AGREE.
!
    err_mean = maxval( abs( ( mean1(:m,1)-mean2(:m,1))/mean1(:m,1) ) )
    err_std  = maxval( abs( ( std1(:m)-std2(:m))/std1(:m)    ) )
    err_cor  = maxval( abs( corp1(:n)-corp2(:n) ) )
!
    if ( max(err_mean, err_std, err_cor )<=eps ) then
        write (prtunit,*) 'Example 2 of COMP_CORMAT_MISS is correct'
    else
        write (prtunit,*) 'Example 2 of COMP_CORMAT_MISS is incorrect'
    end if
!
!
! END OF PROGRAM ex2_comp_cormat_miss
! ===================================
!
end program ex2_comp_cormat_miss

ex2_comp_inv.F90

program ex2_comp_inv
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine COMP_INV
!   in module Lin_Procedures . 
!                                                                              
! LATEST REVISION : 18/06/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, one, comp_inv,  &
                         norm, merror, allocate_error
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=4000
!
    character(len=*), parameter :: name_proc='Example 2 of comp_inv'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, eps, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, a2, ainv, res
!
    integer(i4b) :: j
    integer      :: iok, istart, iend, irate, imax, itime
!
    logical(lgl) :: do_test, failure
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 2 : COMPUTE THE INVERSE OF A REAL n-BY-n MATRIX.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = sqrt( epsilon( err ) )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), ainv(n,n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
! 
!   GENERATE A RANDOM REAL MATRIX.
!
    call random_number( a )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAY.
!
        allocate( a2(n,n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       MAKE A COPY OF THE 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 THE MATRIX INVERSE WITH SUBROUTINE comp_inv.
!   INPUT ARGUMENT NOT OVERWRITTEN.
!
    call comp_inv( a, failure, ainv )
!
!   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 ( failure ) then
!
!       ANORMAL EXIT FROM comp_inv SUBROUTINE, PRINT A WARNING.
!
        write (prtunit,*) 'Error in exit of COMP_INV subroutine, failure=', failure
        write (prtunit,*) 
!
    else if ( do_test ) then
!
!       ALLOCATE WORK ARRAY.
!
        allocate( res(n,n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE a TIMES ITS INVERSE - IDENTITY.
!
        res = matmul( a2, ainv )
!
        do j = 1_i4b, n
            res(j,j) = res(j,j) - one
        end do
!
        err = norm( res(:n,:n) ) /( real(n,stnd)*norm(a2(:n,:n)) )
!
!       DEALLOCATE WORK ARRAY.
!
        deallocate( res )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, ainv )
!
    if ( allocated( a2 ) ) deallocate( a2 )
!
!   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 (*,'(a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing the inverse of a real matrix of size ', &
       n, ' by ', n, ' is', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_comp_inv
! ===========================
!
end program ex2_comp_inv

ex2_comp_mvs.F90

program ex2_comp_mvs
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine COMP_MVS
!   in module Stat_Procedures .
!                                                                              
! LATEST REVISION : 06/07/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, lgl, true, comp_mvs
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! xmiss IS THE MISSING INDICATOR
!
    real(stnd), parameter  :: xmiss=-999.99_stnd
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=26, m=20, p=250
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                      :: err_mean, err_std, err_var, eps
    real(stnd), dimension(n,m)      :: xmean1, xmean2, xstd1, xstd2, xvar1, xvar2
    real(stnd), dimension(n,m,p)    :: x
!
    integer(i4b)                  :: i
    integer(i4b), dimension(n,m)  :: xnobs1, xnobs2
!
    logical(lgl) :: first, last
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 2 of comp_mvs'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
    eps = sqrt( epsilon(err_mean) )
!
!   GENERATE A RANDOM OBSERVATION ARRAY x WITH MISSING VALUES .
!
    call random_number( x )
!
    where( x(:,:,:)<=0.25_stnd )  x(:,:,:) = xmiss
!
!   COMPUTE THE MEANS, VARIANCES, STANDARD-DEVIATIONS AND NUMBER OF OBSERVATIONS 
!   OF x FOR THE p OBSERVATIONS .
!
    first = true
    last  = true
!
    call comp_mvs( x(:,:,:), first, last, xmean1(:,:), xvar1(:,:), xstd1(:,:),  &
                   xmiss=xmiss, xnobs=xnobs1(:,:) )
!
!   COMPUTE THE MEANS, VARIANCES, STANDARD-DEVIATIONS AND NUMBER OF OBSERVATIONS OF x
!   ITERATIVELY FOR THE p OBSERVATIONS  .
!
    do i = 1, p
!
        first = i==1
        last  = i==p
!
        call comp_mvs( x(:,:,i:i), first, last, xmean2(:,:), xvar2(:,:), xstd2(:,:),  &
                       xmiss=xmiss, xnobs=xnobs2(:,:)  )
    end do
!
!   CHECK THAT THE TWO SETS OF STATISTICS AGREE.
!
    err_mean = maxval( abs( ( xmean1-xmean2)/xmean1 ) )
    err_var  = maxval( abs( ( xvar1-xvar2)/xvar1    ) )
    err_std  = maxval( abs( ( xstd1-xstd2)/xstd1    ) )
!
    if ( max(err_mean, err_var, err_std )<=eps .and. all( xnobs2(:,:)==xnobs1(:,:) ) ) then
        write (prtunit,*) 'Example 2 of COMP_MVS is correct'
    else
        write (prtunit,*) 'Example 2 of COMP_MVS is incorrect'
    end if
!
!
! END OF PROGRAM ex2_comp_mvs
! ===========================
!
end program ex2_comp_mvs

ex2_comp_triang_inv.F90

program ex2_comp_triang_inv
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine COMP_TRIANG_INV
!   in module Lin_Procedures . 
!                                                                              
! LATEST REVISION : 18/06/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, zero, one, true, false, allocate_error,   &
                         triangle, norm, comp_triang_inv, merror
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=4000, p=n*(n+1)/2
!
    character(len=*), parameter :: name_proc='Example 2 of comp_triang_inv'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, eps, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, a2, res
    real(stnd), dimension(:),   allocatable :: ap
!
    integer(i4b) :: j
    integer      :: iok, istart, iend, irate, imax, itime
!
    logical(lgl) :: do_test, upper
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 2 : COMPUTE IN PLACE THE INVERSE OF A REAL n-BY-n TRIANGULAR MATRIX.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = sqrt( epsilon( err ) )
    err = zero
!
    do_test = true
    upper   = false
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), ap(p), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM TRIANGULAR MATRIX IN PACKED FORM ap .
!
    call random_number( ap )
!
!   MAKE SURE THAT TRIANGULAR MATRIX IS NOT SINGULAR.
!
    ap = ap + real( n, stnd )
!
!   UNPACK THE TRIANGULAR MATRIX a .
!
    a = unpack( ap, mask=triangle(upper,n,n,extra=1_i4b), field=zero )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( a2(n,n), res(n,n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       MAKE A COPY OF THE TRIANGULAR 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 IN PLACE THE INVERSE OF a WITH SUBROUTINE comp_triang_inv.
!   THE INPUT ARGUMENT IS OVERWRITTEN.
!
    call comp_triang_inv( a, upper=upper )
!
!   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 ( do_test ) then
!
!       COMPUTE a TIMES ITS INVERSE - IDENTITY.
!
        res(:n,:n) = matmul( a(:n,:n), a2(:n,:n) )
!
        do j = 1_i4b, n
            res(j,j) = res(j,j) - one
        end do
!
        err = norm( res(:n,:n) ) /( real(n,stnd)*norm(a2(:n,:n)) )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, ap, a2, res )
!
    else
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, ap )
!
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    write (prtunit,*)
    write (*,'(a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing in place the inverse of a real triangular matrix of size ', &
       n, ' by ', n, ' is', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_comp_triang_inv
! ==================================
!
end program ex2_comp_triang_inv

ex2_comp_unistat.F90

program ex2_comp_unistat
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine COMP_UNISTAT
!   in module Stat_Procedures .
!                                                                              
! LATEST REVISION : 06/07/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, lgl, true, comp_unistat
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! xmiss IS THE MISSING INDICATOR
!
    real(stnd), parameter  :: xmiss=-999.99_stnd
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=26, m=20, p=250
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                      :: err1, err2, eps
    real(stnd), dimension(n,m,7)    :: xstat1, xstat2
    real(stnd), dimension(n,m,p)    :: x
!
    integer(i4b)                  :: i
    integer(i4b), dimension(n,m)  :: xnobs1, xnobs2
!
    logical(lgl) :: first, last
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 2 of comp_unistat'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
    eps = sqrt( epsilon(eps) )
!
!   GENERATE A RANDOM OBSERVATION ARRAY x WITH MISSING VALUES, xmiss IS THE MISSING INDICATOR .
!
    call random_number( x )
!
    where( x(:,:,:)<=0.25_stnd )  x(:,:,:) = xmiss
!
!   COMPUTE THE STATISTICS OF x FOR THE p OBSERVATIONS .
!
    first = true
    last  = true
!
    call comp_unistat( x(:n,:m,:p), first, last, xstat1(:n,:m,:7), xmiss=xmiss, xnobs=xnobs1(:n,:m) )
!
!   ON EXIT, WHEN last=true, xstat1 CONTAINS THE FOLLOWING
!   STATISTICS ON ALL VARIABLES :
!
!        xstat1(:,:,1) CONTAINS THE MEAN VALUES.
!        xstat1(:,:,2) CONTAINS THE VARIANCES.
!        xstat1(:,:,3) CONTAINS THE STANDARD DEVIATIONS.
!        xstat1(:,:,4) CONTAINS THE COEFFICIENTS OF SKEWNESS.
!        xstat1(:,:,5) CONTAINS THE COEFFICIENTS OF KURTOSIS.
!        xstat1(:,:,6) CONTAINS THE MINIMA.
!        xstat1(:,:,7) CONTAINS THE MAXIMA.
!
!   ON EXIT,  xnobs(:,:) CONTAINS THE NUMBERS OF NON-MISSING OBSERVATIONS
!   ON ALL VARIABLES. xnobs NEEDS TO BE SPECIFIED ONLY ON THE LAST 
!   CALL TO comp_unistat (LAST=true).
!
!   COMPUTE THE STATISTICS OF x, ITERATIVELY FOR THE p OBSERVATIONS  .
!
    do i = 1, p
!
        first = i==1
        last  = i==p
!
        call comp_unistat( x(:n,:m,i:i), first, last, xstat2(:n,:m,:7), xmiss=xmiss, xnobs=xnobs2(:n,:m) )
    end do
!
!   CHECK THAT THE TWO SETS OF STATISTICS AGREE.
!
    err1 = maxval( abs( (xstat2(:,:,1:3)-xstat1(:,:,1:3))/xstat1(:,:,1:3) ) )
    err2 = maxval( abs( xstat2(:,:,4:7)-xstat1(:,:,4:7) ) )
!
    if ( max(err1, err2)<=eps  .and. all( xnobs2(:,:)==xnobs1(:,:) ) ) then
        write (prtunit,*) 'Example 2 of COMP_UNISTAT is correct'
    else
        write (prtunit,*) 'Example 2 of COMP_UNISTAT is incorrect'
    end if
!
!
! END OF PROGRAM ex2_comp_unistat
! ===============================
!
end program ex2_comp_unistat

ex2_drawsample.F90

program ex2_drawsample
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines COMP_COR and DRAWSAMPLE
!   in modules Mul_Stat_Procedures and Random, respectively.
!                                                                              
! LATEST REVISION : 06/07/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    USE Statpack, ONLY : i4b, stnd, lgl, true, comp_cor, drawsample, random_seed_, random_number_
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
! p       IS THE NUMBER OF OBSERVATIONS OF THE RANDOM VECTORS
! nrep    IS THE NUMBER OF SHUFFLES FOR THE PERMUTATION TEST
!
    INTEGER(i4b), PARAMETER :: prtunit=6, p=47, p1=37, p2=p, p3=p2-p1+1, nrep=9999, nsample=5
!
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                        :: xyn
    REAL(stnd), DIMENSION(nsample)    :: xycor, prob, xycor2
    real(stnd), dimension(nsample,2)  :: xstat
    real(stnd), dimension(2)          :: ystat
    real(stnd), dimension(nsample,p)  :: x
    real(stnd), dimension(nsample,p3) :: x2
    real(stnd), dimension(p)          :: y
    real(stnd), dimension(p3)         :: y2
    REAL(stnd), DIMENSION(6,p)         :: dat
!
    integer(i4b)                     :: i
    integer(i4b), dimension(p)       :: pop
    integer(i4b), dimension(nsample) :: nge
!
    logical(lgl) :: first, last
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 2 of drawsample'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE DATA MATRIX.
!
    dat = reshape( (/  &
24.54,18.62,1.69,3.69,5.92,1915.7,&
24.22,18.38,1.54,3.58,5.83,2088.1,&
24.40,18.13,2.26,4.17,6.28,1910.1,&
24.33,17.99,2.28,4.21,6.34,1925.6,&
24.47,18.28,2.23,4.11,6.18,2040.1,&
24.07,18.47,1.13,3.25,5.60,2314.8,&
24.51,18.80,1.23,3.36,5.71,2120.3,&
24.49,18.43,1.95,3.90,6.06,1819.4,&
24.55,18.53,1.69,3.75,6.02,1889.5,&
24.74,18.52,2.15,4.08,6.22,1692.1,&
24.99,18.33,2.36,4.40,6.65,1845.3,&
24.85,17.69,2.78,4.86,7.16,2060.8,&
24.42,17.83,2.12,4.24,6.59,2010.8,&
24.58,18.55,1.66,3.74,6.03,2166.1,&
24.53,18.50,1.63,3.72,6.03,2113.6,&
24.55,18.19,2.41,4.28,6.36,1482.6,&
24.82,18.52,2.01,4.04,6.29,1539.1,&
24.37,18.47,1.83,3.76,5.90,1830.7,&
24.65,17.91,2.15,4.33,6.74,1664.7,&
24.66,18.22,2.06,4.14,6.45,2368.1,&
25.35,18.88,2.10,4.18,6.48,2542.3,&
25.02,18.58,2.30,4.26,6.44,2263.3,&
24.67,18.31,2.23,4.19,6.36,2250.4,&
24.24,18.26,1.82,3.79,5.98,1929.3,&
24.50,18.82,1.51,3.49,5.68,2501.0,&
24.41,18.84,1.58,3.47,5.57,2158.7,&
24.64,18.84,2.06,3.83,5.80,2229.8,&
24.65,19.16,1.59,3.44,5.48,1881.2,&
24.51,18.84,1.95,3.72,5.67,1981.1,&
24.64,18.90,2.12,3.84,5.74,2862.6,&
24.63,18.42,1.69,3.84,6.21,2526.3,&
25.22,18.78,2.11,4.16,6.43,2057.5,&
25.08,18.17,2.36,4.52,6.91,2464.4,&
25.02,18.63,1.93,4.05,6.39,2444.2,&
24.94,18.78,1.82,3.88,6.15,1965.9,&
25.31,18.35,2.41,4.57,6.97,1991.9,&
25.08,18.45,2.39,4.40,6.63,2205.1,&
24.79,18.54,1.97,4.00,6.26,2080.0,&
24.88,18.80,1.99,3.93,6.08,2331.2,&
24.31,19.10,1.28,3.14,5.21,2677.1,&
24.59,18.64,1.71,3.72,5.94,2415.5,&
24.97,18.64,1.96,4.03,6.32,1998.2,&
25.10,18.41,1.93,4.19,6.68,1925.8,&
25.14,18.66,2.21,4.24,6.48,2128.9,&
24.39,18.96,1.62,3.43,5.43,1977.4,&
25.36,18.30,2.19,4.50,7.06,1831.8,&
24.99,18.68,2.13,4.12,6.32,1967.0 &
                      /) ,shape=(/ 6, p /) )
!

!
    y(:p) = dat(6,:)
!
    x(:,:p) = dat(1:5,:)
!
!   COMPUTE THE CORRELATIONS BETWEEN x AND y
!   FOR THE p2-p1+1 LAST  OBSERVATIONS .
!
    first = true
    last  = true
!
    call comp_cor( x(:nsample,p1:p2), y(p1:p2), first, last, xstat(:nsample,:2), ystat(:2),    &
                   xycor(:nsample), xyn )
!
!   ON EXIT OF COMP_COR WHEN last=true :
!
!      xstat(:nsample,1)     CONTAINS THE MEAN VALUES OF THE OBSERVATION ARRAY x(:nsample,p1:p2).
!
!      xstat(:nsample,2)     CONTAINS THE VARIANCES OF THE OBSERVATION ARRAY x(:nsample,p1:p2).
!
!      ystat(1)              CONTAINS THE MEAN VALUE OF THE OBSERVATION VECTOR  y(p1:p2).
!
!      ystat(2)              CONTAINS THE VARIANCE OF THE OBSERVATION VECTOR  y(p1:p2).
!
!      xycor(:nsample)       CONTAINS THE CORRELATION COEFFICIENTS BETWEEN x(:nsample,p1:p2) AND y(p1:p2).
!
!      xyn                   CONTAINS THE NUMBER OF OBSERVATIONS IN THE DATA ARRAYS
!                            x(:nsample,p1:p2) AND  y(p1:p2) (xyn=real(p2-p1+1,stnd) ).
!
!
!   NOW COMPUTE A PERMUTATION TEST OF THE CORRELATION BETWEEN x AND y WITH
!   SUBROUTINES drawsample  AND comp_cor WITH nrep SHUFFLES .
!
    nge(:nsample) = 1
    call random_seed_( )
!
    do i=1, nrep
!
        call drawsample( p3, pop )
!
        x2(:nsample,:p3) = x(:nsample,pop(:p3))
        y2(:p3)          = y(pop(:p3))
!
        call comp_cor( x2(:nsample,:p3), y2(:p3), first, last, xstat(:nsample,:2), ystat(:2),    &
                       xycor2(:nsample), xyn )
!
        where( abs( xycor2(:nsample) )>= abs( xycor(:nsample) ) ) nge(:nsample) = nge(:nsample) + 1
!
    end do 
!
!   COMPUTE THE SIGNIFICANCE LEVELS.
!
    prob(:nsample) = real( nge(:nsample), stnd )/real( nrep+1, stnd )
!
    WRITE (prtunit,*) 'Correlations  = ', xycor(:nsample)
    WRITE (prtunit,*) 'Probabilities = ', prob(:nsample)
!
!
! END OF PROGRAM ex2_drawsample
! ==============================
!
end program ex2_drawsample

ex2_eig_cmp.F90

program ex2_eig_cmp
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine EIG_CMP
!   in module Eig_Procedures .
!                                                                            
! LATEST REVISION : 01/06/2017
!
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, merror,   &
                         allocate_error, unit_matrix, eig_cmp
#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
!
    integer(i4b), parameter :: prtunit=6, n=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of eig_cmp'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, eps, elapsed_time
    real(stnd), dimension(:),   allocatable :: d, resid2
    real(stnd), dimension(:,:), allocatable :: a, a2, resid
!
    integer        :: iok, istart, iend, irate, imax, itime
!
    logical(lgl)   :: do_test, failure, upper=false
!   
    character    :: sort='a'
!   
!   
! 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 EIGENVECTORS OF A REAL SYMMETRIC
!               MATRIX USING THE TRIDIAGONAL QR METHOD.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), d(n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM DATA MATRIX AND FROM IT
!   A SELF-ADJOINT MATRIX a .
!
    call random_number( a )
    a = a + transpose( a ) 
!
    if ( do_test ) then
!
        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 )
!
!   COMPUTE EIGENVALUES AND EIGENVECTORS OF THE SELF-ADJOINT MATRIX a
!   WITH SUBROUTINE eig_cmp.
!   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.
!
!   COMPUTE EIGENVALUES AND EIGENVECTORS OF THE SELF-ADJOINT MATRIX a ,
!   BY USING ONLY THE LOWER TRIANGLE OF a ON INPUT INSTEAD OF THE UPPER
!   TRIANGLE.
!
    call eig_cmp( a, d, failure, sort=sort, upper=upper )
!
!   THE ROUTINE RETURNS THE EIGENVALUES AND THE EIGENVECTORS OF a.
!
!   ON EXIT OF eig_cmp:
!
!       failure= false :  INDICATES SUCCESSFUL EXIT.
!       failure= true  :  INDICATES THAT THE TRIDIAGONAL QR ALGORITHM DID NOT CONVERGE AND
!                         THAT FULL ACCURACY WAS NOT ATTAINED IN THE EIGENDECOMPOSITION 
!                         OF AN 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.
!
!   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 ( 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 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, a2, d, resid, resid2 )
!
    else
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, d )
!
    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
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', n, ' eigenvalues and eigenvectors of a ', &
       n, ' by ', n,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_eig_cmp
! ==========================
!
end program ex2_eig_cmp

ex2_eig_cmp2.F90

program ex2_eig_cmp2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine EIG_CMP2
!   in module Eig_Procedures .
!                                                                            
! LATEST REVISION : 01/06/2017
!
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, merror,   &
                         allocate_error, unit_matrix, eig_cmp2
#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
!
    integer(i4b), parameter :: prtunit=6, n=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of eig_cmp2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, eps, elapsed_time
    real(stnd), dimension(:),   allocatable :: d, resid2
    real(stnd), dimension(:,:), allocatable :: a, a2, resid
!
    integer        :: iok, istart, iend, irate, imax, itime
!
    logical(lgl)   :: do_test, failure, upper=false
!   
    character    :: sort='a'
!   
!   
! 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, A PERFECT SHIFT
!               STRATEGY FOR THE EIGENVECTORS AND A WAVE-FRONT ALGORITHM
!               FOR APPLYING GIVENS ROTATIONS IN THE TRIDIAGONAL QR
!               ALGORITHM.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), d(n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM DATA MATRIX AND FROM IT
!   A SELF-ADJOINT MATRIX a .
!
    call random_number( a )
    a = a + transpose( a ) 
!
    if ( do_test ) then
!
        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 )
!
!   COMPUTE EIGENVALUES AND EIGENVECTORS OF THE SELF-ADJOINT MATRIX a
!   WITH SUBROUTINE eig_cmp2.
!   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.
!
!   COMPUTE EIGENVALUES AND EIGENVECTORS OF THE SELF-ADJOINT MATRIX a ,
!   BY USING ONLY THE LOWER TRIANGLE OF a ON INPUT INSTEAD OF THE UPPER
!   TRIANGLE.
!
    call eig_cmp2( a, d, failure, sort=sort, upper=upper )
!
!   THE ROUTINE RETURNS THE EIGENVALUES AND THE EIGENVECTORS OF a.
!
!   ON EXIT OF eig_cmp2:
!
!       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 AN 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.
!
!   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 ( 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 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, a2, d, resid, resid2 )
!
    else
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, d )
!
    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
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', n, ' eigenvalues and eigenvectors of a ', &
       n, ' by ', n,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_eig_cmp2
! ===========================
!
end program ex2_eig_cmp2

ex2_eig_cmp3.F90

program ex2_eig_cmp3
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine EIG_CMP3
!   in module Eig_Procedures .
!                                                                            
! LATEST REVISION : 01/06/2017
!
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, merror,   &
                         allocate_error, unit_matrix, eig_cmp3
#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
!
    integer(i4b), parameter :: prtunit=6, n=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of eig_cmp3'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, eps, elapsed_time
    real(stnd), dimension(:),   allocatable :: d, resid2
    real(stnd), dimension(:,:), allocatable :: a, a2, resid
!
    integer        :: iok, istart, iend, irate, imax, itime
!
    logical(lgl)   :: do_test, failure, upper=false
!   
    character    :: sort='a'
!   
!   
! 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 AND A WAVE-FRONT ALGORITHM
!               FOR APPLYING GIVENS ROTATIONS IN THE TRIDIAGONAL QR
!               ALGORITHM.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), d(n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM DATA MATRIX AND FROM IT
!   A SELF-ADJOINT MATRIX a .
!
    call random_number( a )
    a = a + transpose( a ) 
!
    if ( do_test ) then
!
        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 )
!
!   COMPUTE EIGENVALUES AND EIGENVECTORS OF THE SELF-ADJOINT MATRIX a
!   WITH SUBROUTINE eig_cmp3.
!   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.
!
!   COMPUTE EIGENVALUES AND EIGENVECTORS OF THE SELF-ADJOINT MATRIX a ,
!   BY USING ONLY THE LOWER TRIANGLE OF a ON INPUT INSTEAD OF THE UPPER
!   TRIANGLE.
!
    call eig_cmp3( a, d, failure, sort=sort, upper=upper )
!
!   THE ROUTINE RETURNS THE EIGENVALUES AND THE EIGENVECTORS OF a.
!
!   ON EXIT OF eig_cmp3:
!
!       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 AN 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.
!
!   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 ( 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 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, a2, d, resid, resid2 )
!
    else
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, d )
!
    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
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', n, ' eigenvalues and eigenvectors of a ', &
       n, ' by ', n,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_eig_cmp3
! ===========================
!
end program ex2_eig_cmp3

ex2_eigval_cmp.F90

program ex2_eigval_cmp
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine EIGVAL_CMP
!   in module Eig_Procedures.
!                                                                              
! LATEST REVISION : 20/01/2020
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, triangle, trid_inviter,  &
                         eigval_cmp, 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 MATRIX
! AND neig IS THE NUMBER OF WANTED EIGENVECTORS
!
    integer(i4b), parameter :: prtunit=6, n=3000, p=(n*(n+1))/2, neig=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of eigval_cmp'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, eps, elapsed_time
    real(stnd), dimension(:),   allocatable :: vec, d, res
    real(stnd), dimension(:,:), allocatable :: a, eigvec, d_e, resmat
!
    integer(i4b) :: maxiter=2
    integer      :: iok, istart, iend, irate, imax, itime
!
    logical(lgl) :: failure, failure2, do_test, upper=true
!   
    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 : PARTIAL EIGENVALUES/EIGENVECTORS DECOMPOSITION OF A n-BY-n REAL
!               SYMMETRIC MATRIX STORED IN PACKED FORM USING THE FAST PAL-WALKER-KAHAN VARIANT
!               OF THE QR METHOD FOR EIGENVALUES AND THE INVERSE ITERATION TECHNIQUE FOR
!               SELECTED EIGENVECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
!
    err = zero
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), d(n), d_e(n,2), vec(p), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM DATA MATRIX AND FROM IT
!   A SELF-ADJOINT MATRIX a .
!
    call random_number( a )
    a = a + transpose( a ) 
!
!   MAKE A COPY OF THE SELF-ADJOINT MATRIX IN PACKED FORM.
!
    vec(:p) = pack( a, mask=triangle( upper, n, n, extra=1_i4b) )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   COMPUTE ALL EIGENVALUES OF THE SELF-ADJOINT MATRIX a AND SAVE
!   THE INTERMEDIATE TRIDIAGONAL MATRIX IN PARAMETER d_e .
!
    call eigval_cmp( vec, d, failure, sort=sort, d_e=d_e )
!
!   THE ROUTINE RETURNS THE EIGENVALUES OF a.
!
!   ON EXIT OF eigval_cmp:
!
!       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 AN INTERMEDIATE TRIDIAGONAL FORM TRID OF a.
!
!       vec IS OVERWRITTEN BY THE ORTHOGONAL MATRIX USED TO TRANSFORM a IN TRIDIAGONAL FORM IF
!           THE OPTIONAL ARGUMENT d_e IS SPECIFIED. THE MATRIX Q IS STORED IN FACTORED FORM.
!
!       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.
!
    if ( .not. failure .and. neig>0  ) then
!
!       ALLOCATE WORK ARRAY NEEDED TO STORE THE EIGENVECTORS.
!
        allocate( eigvec(n,neig), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE THE FIRST neig EIGENVECTORS OF THE SELF-ADJOINT MATRIX a BY
!       maxiter INVERSE ITERATIONS ON THE INTERMEDIATE TRIDIAGONAL MATRIX
!       d_e AND BACK-TRANSFORMATION.
!
        call trid_inviter( d_e(:n,1_i4b), d_e(:n,2_i4b), d(:neig), eigvec, failure2, &
                           matp=vec, maxiter=maxiter )
!
    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 ( do_test .and. .not.failure .and. neig>0 ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( resmat(n,neig), res(n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*eigvec - eigvec*d
!       WHERE d ARE THE EIGENVALUES AND eigvec THE EIGENVECTORS OF a.
!
        resmat(:n,:neig) = matmul( a(:n,:n), eigvec(:n,:neig)) - eigvec(:n,:neig)*spread( d(:neig), dim=1, ncopies=n)
        res(:neig)  = norm( resmat(:n,:neig), dim=2_i4b )
!
        err1 = maxval( res(:neig) )/( norm( a )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - eigvec**(t)*eigvec.
!
        call unit_matrix( a(:neig,:neig) )
!
        resmat(:neig,:neig) = abs( a(:neig,:neig) - matmul( transpose(eigvec(:n,:neig)), eigvec(:n,:neig) ) )
!
        err2 = maxval( resmat(:neig,:neig) )/real(n,stnd)
!
        err = max( err1, err2 )
!
!       DEALLOCATE WORK ARRAY.
!
        deallocate( resmat, res )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, d_e, d, vec )
!
    if ( allocated( eigvec ) )  deallocate( eigvec )
!
!   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
!
    if ( do_test  .and. .not.failure .and. neig>0 ) then
        write (prtunit,*) 
        write (prtunit,*) 'Accuracy of the computed eigenvalues/eigenvectors couplets = ', err1
        write (prtunit,*) 'Orthogonality of the computed eigenvectors                 = ', err2
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing all the eigenvalues and ', neig, ' eigenvectors of a ', &
       n, ' by ', n,' real symmetric matrix stored in packed form is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_eigval_cmp
! =============================
!
end program ex2_eigval_cmp

ex2_eigval_cmp2.F90

program ex2_eigval_cmp2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine EIGVAL_CMP2
!   in module Eig_Procedures.
!                                                                              
! LATEST REVISION : 20/01/2020
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, triangle, trid_inviter,  &
                         eigval_cmp2, 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 MATRIX AND neig IS THE NUMBER OF WANTED EIGENVECTORS
!
    integer(i4b), parameter :: prtunit=6, n=3000, p=(n*(n+1))/2, neig=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of eigval_cmp2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, eps, elapsed_time
    real(stnd), dimension(:),   allocatable :: vec, d, res
    real(stnd), dimension(:,:), allocatable :: a, eigvec, d_e, resmat
!
    integer(i4b) :: maxiter=2
    integer      :: iok, istart, iend, irate, imax, itime
!
    logical(lgl) :: failure, failure2, do_test, upper=true
!   
    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 : PARTIAL EIGENVALUES/EIGENVECTORS DECOMPOSITION OF A n-BY-n REAL
!               SYMMETRIC MATRIX STORED IN PACKED FORM USING THE FAST PAL-WALKER-KAHAN VARIANT
!               OF THE QR METHOD FOR EIGENVALUES AND THE INVERSE ITERATION TECHNIQUE FOR
!               SELECTED EIGENVECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
!
    err = zero
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), d(n), d_e(n,2), vec(p), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM DATA MATRIX AND FROM IT
!   A SELF-ADJOINT MATRIX a .
!
    call random_number( a )
    a = a + transpose( a ) 
!
!   MAKE A COPY OF THE SELF-ADJOINT MATRIX IN PACKED FORM.
!
    vec(:p) = pack( a, mask=triangle( upper, n, n, extra=1_i4b) )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   COMPUTE ALL EIGENVALUES OF THE SELF-ADJOINT MATRIX a AND SAVE
!   THE INTERMEDIATE TRIDIAGONAL MATRIX IN PARAMETER d_e .
!
    call eigval_cmp2( vec, d, failure, sort=sort, d_e=d_e )
!
!   THE ROUTINE RETURNS THE EIGENVALUES OF a.
!
!   ON EXIT OF eigval_cmp2:
!
!       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 AN INTERMEDIATE TRIDIAGONAL FORM TRID OF a.
!
!       vec IS OVERWRITTEN BY THE ORTHOGONAL MATRIX USED TO TRANSFORM a IN TRIDIAGONAL FORM IF
!           THE OPTIONAL ARGUMENT d_e IS SPECIFIED. THE MATRIX Q IS STORED IN FACTORED FORM.
!
!       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.
!
    if ( .not. failure .and. neig>0  ) then
!
!       ALLOCATE WORK ARRAY NEEDED TO STORE THE EIGENVECTORS.
!
        allocate( eigvec(n,neig), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE THE FIRST neig EIGENVECTORS OF THE SELF-ADJOINT MATRIX a BY
!       maxiter INVERSE ITERATIONS ON THE INTERMEDIATE TRIDIAGONAL MATRIX
!       d_e AND BACK-TRANSFORMATION.
!
        call trid_inviter( d_e(:n,1_i4b), d_e(:n,2_i4b), d(:neig), eigvec, failure2, &
                           matp=vec, maxiter=maxiter )
!
    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 ( do_test .and. .not.failure .and. neig>0 ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( resmat(n,neig), res(n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*eigvec - eigvec*d
!       WHERE d ARE THE EIGENVALUES AND eigvec THE EIGENVECTORS OF a.
!
        resmat(:n,:neig) = matmul( a(:n,:n), eigvec(:n,:neig)) - eigvec(:n,:neig)*spread( d(:neig), dim=1, ncopies=n)
        res(:neig)  = norm( resmat(:n,:neig), dim=2_i4b )
!
        err1 = maxval( res(:neig) )/( norm( a )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - eigvec**(t)*eigvec.
!
        call unit_matrix( a(:neig,:neig) )
!
        resmat(:neig,:neig) = abs( a(:neig,:neig) - matmul( transpose(eigvec(:n,:neig)), eigvec(:n,:neig) ) )
!
        err2 = maxval( resmat(:neig,:neig) )/real(n,stnd)
!
        err = max( err1, err2 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( resmat, res )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, d_e, d, vec )
!
    if ( allocated( eigvec ) )  deallocate( eigvec )
!
!   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
!
    if ( do_test  .and. .not.failure .and. neig>0 ) then
        write (prtunit,*) 
        write (prtunit,*) 'Accuracy of the computed eigenvalues/eigenvectors couplets = ', err1
        write (prtunit,*) 'Orthogonality of the computed eigenvectors                 = ', err2
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing all the eigenvalues and ', neig, ' eigenvectors of a ', &
       n, ' by ', n,' real symmetric matrix stored in packed form is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_eigval_cmp2
! ==============================
!
end program ex2_eigval_cmp2

ex2_eigval_cmp3.F90

program ex2_eigval_cmp3
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine EIGVAL_CMP3
!   in module Eig_Procedures.
!                                                                              
! LATEST REVISION : 20/01/2020
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, norm, triangle, trid_inviter,  &
                         eigval_cmp3, 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 MATRIX AND neig IS THE NUMBER OF WANTED EIGENVECTORS
!
    integer(i4b), parameter :: prtunit=6, n=3000, p=(n*(n+1))/2, neig=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of eigval_cmp3'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, eps, elapsed_time
    real(stnd), dimension(:),   allocatable :: vec, d, res
    real(stnd), dimension(:,:), allocatable :: a, eigvec, d_e, resmat
!
    integer(i4b) :: maxiter=2
    integer      :: iok, istart, iend, irate, imax, itime
!
    logical(lgl) :: failure, failure2, do_test, upper=true
!   
    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 : PARTIAL EIGENVALUES/EIGENVECTORS DECOMPOSITION OF A n-BY-n REAL
!               SYMMETRIC MATRIX STORED IN PACKED FORM USING THE QR METHOD
!               FOR EIGENVALUES AND THE INVERSE ITERATION TECHNIQUE FOR
!               SELECTED EIGENVECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
!
    err = zero
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), d(n), d_e(n,2), vec(p), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM DATA MATRIX AND FROM IT
!   A SELF-ADJOINT MATRIX a .
!
    call random_number( a )
    a = a + transpose( a ) 
!
!   MAKE A COPY OF THE SELF-ADJOINT MATRIX IN PACKED FORM.
!
    vec(:p) = pack( a, mask=triangle( upper, n, n, extra=1_i4b) )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   COMPUTE ALL EIGENVALUES OF THE SELF-ADJOINT MATRIX a AND SAVE
!   THE INTERMEDIATE TRIDIAGONAL MATRIX IN PARAMETER d_e .
!
    call eigval_cmp3( vec, d, failure, sort=sort, d_e=d_e )
!
!   THE ROUTINE RETURNS THE EIGENVALUES OF a.
!
!   ON EXIT OF eigval_cmp3:
!
!       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 AN INTERMEDIATE TRIDIAGONAL FORM TRID OF a.
!
!       vec IS OVERWRITTEN BY THE ORTHOGONAL MATRIX USED TO TRANSFORM a IN TRIDIAGONAL FORM IF
!           THE OPTIONAL ARGUMENT d_e IS SPECIFIED. THE MATRIX Q IS STORED IN FACTORED FORM.
!
!       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.
!
    if ( .not. failure .and. neig>0  ) then
!
!       ALLOCATE WORK ARRAY NEEDED TO STORE THE EIGENVECTORS.
!
        allocate( eigvec(n,neig), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE THE FIRST neig EIGENVECTORS OF THE SELF-ADJOINT MATRIX a BY
!       maxiter INVERSE ITERATIONS ON THE INTERMEDIATE TRIDIAGONAL MATRIX
!       d_e AND BACK-TRANSFORMATION.
!
        call trid_inviter( d_e(:n,1_i4b), d_e(:n,2_i4b), d(:neig), eigvec, failure2, &
                           matp=vec, maxiter=maxiter )
!
    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 ( do_test .and. .not.failure .and. neig>0 ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( resmat(n,neig), res(n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*eigvec - eigvec*d
!       WHERE d ARE THE EIGENVALUES AND eigvec THE EIGENVECTORS OF a.
!
        resmat(:n,:neig) = matmul( a(:n,:n), eigvec(:n,:neig)) - eigvec(:n,:neig)*spread( d(:neig), dim=1, ncopies=n)
        res(:neig)  = norm( resmat(:n,:neig), dim=2_i4b )
!
        err1 = maxval( res(:neig) )/( norm( a )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - eigvec**(t)*eigvec.
!
        call unit_matrix( a(:neig,:neig) )
!
        resmat(:neig,:neig) = abs( a(:neig,:neig) - matmul( transpose(eigvec(:n,:neig)), eigvec(:n,:neig) ) )
!
        err2 = maxval( resmat(:neig,:neig) )/real(n,stnd)
!
        err = max( err1, err2 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( resmat, res )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, d_e, d, vec )
!
    if ( allocated( eigvec ) )  deallocate( eigvec )
!
!   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
!
    if ( do_test  .and. .not.failure .and. neig>0 ) then
        write (prtunit,*) 
        write (prtunit,*) 'Accuracy of the computed eigenvalues/eigenvectors couplets = ', err1
        write (prtunit,*) 'Orthogonality of the computed eigenvectors                 = ', err2
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing all the eigenvalues and ', neig, ' eigenvectors of a ', &
       n, ' by ', n,' real symmetric matrix stored in packed form is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_eigval_cmp3
! ==============================
!
end program ex2_eigval_cmp3

ex2_gchol_cmp.F90

program ex2_gchol_cmp
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines GCHOL_CMP and CHOL_SOLVE
!   in module Lin_Procedures . 
!                                                                              
! LATEST REVISION : 18/09/2014
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, zero, c10, true, false, gchol_cmp, chol_solve, merror, allocate_error
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=1000, m=n-1, nrhs=100
!
    real(stnd), parameter :: fudge=c10
!
    character(len=*), parameter :: name_proc='Example 2 of gchol_cmp'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, eps, tol, d1, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, a2, c, b, b2, d, res
    real(stnd), dimension(:), allocatable   :: invdiag
!
    integer(i4b) :: krank
    integer      :: iok, istart, iend, irate
!
    logical(lgl)   :: do_test, upper
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 2 : REAL SYMMETRIC DEFINITE POSITIVE MATRIX AND SEVERAL RIGHT HAND-SIDES.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    tol = sqrt( epsilon( err ) )
    eps = fudge*tol
    err = zero
!
    do_test = true
    upper   = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( c(m,n), a(n,n), b(n,nrhs), invdiag(n), d(m,nrhs), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-by-n RANDOM SYMMETRIC POSITIVE SEMIDEFINITE MATRIX a .
!
    call random_number( c )
!
    a = matmul( transpose(c), c )
!
!   GENERATE A RANDOM RIGHT HAND-SIDE MATRIX b BELONGING TO THE RANGE OF a.
!
    call random_number( d )
!
    b = matmul( transpose(c), d )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS .
!
        allocate(  a2(n,n), b2(n,nrhs), res(n,nrhs), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       MAKE A COPY OF COEFFICIENT MATRIX AND RIGHT HAND-SIDE MATRIX .
!
        a2 = a
        b2 = b
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count=istart, count_rate=irate )
!
!   COMPUTE THE SOLUTION MATRIX FOR SYMMETRIC POSITIVE SEMIDEFINITE
!   SYSTEM
!
!                     a*x = b .
!
!   BY COMPUTING THE CHOLESKY DECOMPOSITION OF MATRIX a .
!   IF ON OUTPUT OF gchol_cmp d1 IS GREATER OR EQUAL TO ZERO
!   THEN THE SYMMETRIC LINEAR SYSTEM CAN BE SOLVED BY 
!   SUBROUTINE chol_solve.
!
    call gchol_cmp( a, invdiag, krank, d1, tol=tol, upper=upper )
!
    if ( d1<zero ) then
!
!       ANORMAL EXIT FROM gchol_cmp SUBROUTINE, PRINT A WARNING.
!
        write (prtunit,*) 'Error in the call to GCHOL_CMP subroutine, d1=', d1
!
    else
!
        call chol_solve( a, invdiag, b, upper=upper )
!
        if ( do_test ) then
!
!           CHECK THE RESULTS FOR SMALL RESIDUALS.
!
            res(:n,:nrhs) = b2(:n,:nrhs) - matmul( a2, b(:n,:nrhs) )
            err = maxval( sum( abs(res), dim=1 ) / ( sum(abs(a2)) + sum(abs(b2), dim=1) ) )
!
        end if
!
    end if
!
    call system_clock( count=iend )
!
    elapsed_time = real( iend - istart, stnd )/real( irate, stnd )
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( do_test ) then
        deallocate( a, b, c, d, invdiag, a2, b2, res )
    else
        deallocate( a, b, c, d, invdiag )
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. d1>=zero ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for solving a positive semidefinite symmetric system of size ', &
       n, ' with', nrhs, ' right hand side vectors is', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_gchol_cmp
! ============================
!
end program ex2_gchol_cmp

ex2_hwfilter.F90

program ex2_hwfilter
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine HWFILTER
!   in module Time_Series_Procedures .
!                                                                              
! LATEST REVISION : 30/03/2007
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, one, hwfilter
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT, n IS THE LENGTH OF THE TIME SERIES, m IS THE NUMBER OF TIME SERIES.
!
    integer(i4b), parameter :: prtunit=6, n=1000, m=1000
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                 :: err, win
    real(stnd), dimension(m,n) :: y, y2, y3
!
    integer(i4b) :: minp, maxp
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 2 of hwfilter'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE m RANDOM REAL NUMBER SEQUENCES OF LENGTH n .
!
    call random_number( y(:m,:n) )
!
!   SAVE THE REAL RANDOM NUMBER ARRAY.
!
    y2(:m,:n) = y(:m,:n)
    y3(:m,:n) = y(:m,:n)
!
    minp  = 18_i4b
    maxp  = 96_i4b
!
!   BY DEFAULT, HAMMMING WINDOW FILTERING IS USED (i.e. win=0.54).
!   SET win=0.5 for HANNING WINDOW OR win=1 FOR RECTANGULAR WINDOW.
!   IN ANY CASE, win MUST BE GREATER OR EQUAL TO 0.5 AND LESS OR EQUAL TO 1.
!
    win = one
!
!   hwfilter FILTERS A NUMBER OF TIME SERIES (THE ARGUMENT MAT) IN THE FREQUENCY BAND
!   LIMITED BY PERIODS PL AND PH BY WINDOWED FILTERING (PL AND PH ARE EXPRESSED IN NUMBER OF
!   POINTS, i.e. PL=18 AND PH=96 SELECTS PERIODS BETWEEN 1.5 YRS AND 8 YRS FOR MONTHLY DATA).
!
!   FILTER THE TIME SERIES, KEEP THE PERIODS BETWEEN minp AND maxp .
!
    call hwfilter( MAT=y2(:m,:n), PL=minp, PH=maxp, WIN=win, MAX_ALLOC=1000 )
!
!   SETTING PH<PL IS ALLOWED AND PERFORMS BAND REJECTION OF PERIODS BETWEEN PH AND PL.
!
!   FILTER THE TIME SERIES, KEEP THE PERIODS OUTSIDE THE BAND BETWEEN minp AND maxp .
!
    call hwfilter( MAT=y3(:m,:n), PL=maxp, PH=minp, WIN=win, MAX_ALLOC=1000 )
!
!   NOW RECONSTRUCT THE ORIGINAL TIME SERIES FROM THE FILTERED TIME SERIES.
!
    y2(:m,:n) = y2(:m,:n) + y3(:m,:n)
!
!   TEST THE ACCURACY OF THE RECONSTRUCTION.
!
    err = maxval(abs(y(:m,:n)-y2(:m,:n)))/maxval(abs(y(:m,:n)))
!
    if ( err<=sqrt(epsilon(err))  ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex2_hwfilter
! ===========================
!
end program ex2_hwfilter

ex2_hwfilter2.F90

program ex2_hwfilter2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine HWFILTER2
!   in module Time_Series_Procedures .
!                                                                              
! LATEST REVISION : 30/03/2007
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, one, hwfilter2
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT, n IS THE LENGTH OF THE TIME SERIES, m IS THE NUMBER OF TIME SERIES.
!
    integer(i4b), parameter :: prtunit=6, n=500, m=1000
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                 :: err, win
    real(stnd), dimension(m,n) :: y, y2, y3
!
    integer(i4b) :: minp, maxp
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 2 of hwfilter2'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE m RANDOM REAL NUMBER SEQUENCES OF LENGTH n .
!
    call random_number( y(:m,:n) )
!
!   SAVE THE REAL RANDOM NUMBER ARRAY.
!
    y2(:m,:n) = y(:m,:n)
    y3(:m,:n) = y(:m,:n)
!
    minp  = 18_i4b
    maxp  = 96_i4b
!
!   BY DEFAULT, HAMMMING WINDOW FILTERING IS USED (i.e. win=0.54).
!   SET win=0.5 for HANNING WINDOW OR win=1 FOR RECTANGULAR WINDOW.
!   IN ANY CASE, win MUST BE GREATER OR EQUAL TO 0.5 AND LESS OR EQUAL TO 1.
!
    win = one
!
!   hwfilter FILTERS A NUMBER OF TIME SERIES (THE ARGUMENT MAT) IN THE FREQUENCY BAND
!   LIMITED BY PERIODS PL AND PH BY WINDOWED FILTERING (PL AND PH ARE EXPRESSED IN NUMBER OF
!   POINTS, i.e. PL=18 AND PH=96 SELECTS PERIODS BETWEEN 1.5 YRS AND 8 YRS FOR MONTHLY DATA).
!
!   FILTER THE TIME SERIES, KEEP THE PERIODS BETWEEN minp AND maxp .
!
    call hwfilter2( MAT=y2(:m,:n), PL=minp, PH=maxp, WIN=win )
!
!   SETTING PH<PL IS ALLOWED AND PERFORMS BAND REJECTION OF PERIODS BETWEEN PH AND PL.
!
!   FILTER THE TIME SERIES, KEEP THE PERIODS OUTSIDE THE BAND BETWEEN minp AND maxp .
!
    call hwfilter2( MAT=y3(:m,:n), PL=maxp, PH=minp, WIN=win )
!
!   NOW RECONSTRUCT THE ORIGINAL TIME SERIES FROM THE FILTERED TIME SERIES.
!
    y2(:m,:n) = y2(:m,:n) + y3(:m,:n)
!
!   TEST THE ACCURACY OF THE RECONSTRUCTION.
!
    err = maxval(abs(y(:m,:n)-y2(:m,:n)))/maxval(abs(y(:m,:n)))
!
    if ( err<=sqrt(epsilon(err))  ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex2_hwfilter2
! ============================
!
end program ex2_hwfilter2

ex2_lin_lu_solve.F90

program ex2_lin_lu_solve
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine LIN_LU_SOLVE
!   in module Lin_Procedures . 
!                                                                              
! LATEST REVISION : 03/09/2014
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, lin_lu_solve, merror, allocate_error
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=4000, nrhs=4000
!
    character(len=*), parameter :: name_proc='Example 2 of lin_lu_solve'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, eps, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, b, x, res
!
    integer        :: iok, istart, iend, irate
!
    logical(lgl)   :: failure, do_test
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 2 : REAL MATRIX AND SEVERAL RIGHT HAND-SIDES.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = sqrt( epsilon( err ) )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( 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 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=istart, count_rate=irate )
!
!   COMPUTE THE SOLUTION MATRIX FOR LINEAR SYSTEM
!
!            a*x = b .
!
!   BY COMPUTING THE LU DECOMPOSITION WITH PARTIAL PIVOTING AND
!   IMPLICIT ROW SCALING OF MATRIX a. IF ON OUTPUT OF lin_lu_solve
!   failure IS SET TO FALSE THEN THE LINEAR SYSTEM IS NOT SINGULAR
!   AND THE SOLUTION MATRIX HAS BEEN COMPUTED.
!
    call lin_lu_solve( a, b, failure )
!
!   STOP THE TIMER.
!
    call system_clock( count=iend )
!
    elapsed_time = real( iend - istart, stnd )/real( irate, stnd )
!
    if ( failure ) then
!
!       ANORMAL EXIT FROM lin_lu_solve SUBROUTINE, PRINT A WARNING.
!
        write (prtunit,*) 'Error in the call to LIN_LU_SOLVE subroutine, failure=', failure
!
    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 )
!
!   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 (*,'(a,i5,a,i5,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 ex2_lin_lu_solve
! ===============================
!
end program ex2_lin_lu_solve

ex2_llsq_qr_solve.F90

program ex2_llsq_qr_solve
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine LLSQ_QR_SOLVE
!   in modules LLSQ_Procedures .
!                                                                              
! LATEST REVISION : 25/07/2014
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, lgl, zero, false, true, llsq_qr_solve
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, m=4000, n=2000, nrhs=400
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, tol
    real(stnd), allocatable, dimension(:,:) :: x, resid, b, a
!
    integer(i4b) :: krank
!
    integer      :: iok
!
    logical(lgl) :: do_test
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 2 of llsq_qr_solve'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(m,n), b(m,nrhs), resid(m,nrhs), x(n,nrhs), stat=iok )
!
    if ( iok/=0 ) then
        write (prtunit,*)  'Problem in attempt to allocate memory !'
        stop
    end if
!
!   GENERATE A RANDOM COEFFICIENT MATRIX a .
!
    call random_number( a )
!
!   GENERATE A RANDOM RIGHT HAND-SIDE MATRIX b .
!
    call random_number( b )
!
!   EXAMPLE 2 : LINEAR LEAST SQUARES SYSTEM.
!
!   COMPUTE SOLUTION MATRIX FOR LINEAR LEAST SQUARES SYSTEM
!
!           a(:m,:n)*x(:n,:nrhs)=b(:m,:nrhs) .
!
    err      = zero
    do_test  = false
!
!   SET TOLERANCE .
!
    tol = 0.00001_stnd
!
    krank = 0_i4b
!
    call llsq_qr_solve( a(:m,:n), b(:m,:nrhs), x(:n,:nrhs),               &
                        krank=krank, tol=tol, resid=resid(:m,:nrhs) )
!
!   llsq_qr_solve COMPUTES SOLUTION(S) TO REAL LINEAR LEAST SQUARES PROBLEMS 
!   OF THE FORM:
!
!                       Minimize 2-norm(| b - a*x |)
!
!   USING AN ORTHOGONAL FACTORIZATION WITH COLUMNS PIVOTING OF a. a IS A m VECTOR
!   OR AN m-BY-n MATRIX WHICH MAY BE RANK-DEFICIENT. IF a IS A MATRIX, m>=n OR
!   n>m IS PERMITTED.
!
!   SEVERAL RIGHT HAND SIDE VECTORS b AND SOLUTION VECTORS x CAN BE
!   HANDLED IN A SINGLE CALL; THEY ARE STORED AS THE COLUMNS OF THE
!   m-BY-nrhs RIGHT HAND SIDE MATRIX b AND THE n-BY-nrhs SOLUTION
!   MATRIX x, RESPECTIVELY. IN OTHER WORDS, THE ARGUMENTS b AND x MAY
!   BE VECTORS OR MATRICES.
!
!   a AND b ARE NOT OVERWRITTEN BY llsq_qr_solve. THE OPTIONAL ARGUMENTS krank,
!   tol AND min_norm MUST NOT BE PRESENT IF a IS A m-VECTOR.
!
!   ON INPUT, IF THE OPTIONAL PARAMETER krank IS SPECIFIED AND IF krank=k,
!   THIS IMPLIES THAT THE FIRST k COLUMNS OF a ARE TO BE FORCED INTO THE BASIS.
!   PIVOTING IS PERFORMED ON THE LAST n-k COLUMNS OF a.
!   
!   WHEN krank>=min(m,n) IS USED, PIVOTING IS NOT PERFORMED. THIS IS
!   APPROPRIATE WHEN a IS KNOWN TO BE FULL RANK. krank<=0 CAN BE USED
!   WHEN PIVOTING IS DESIRED ON ALL COLUMNS OF a.
!   
!   BY DEFAULT, PIVOTING IS DONE ON ALL THE COLUMNS OF a.
!   
!   ON EXIT, IF THE OPTIONAL PARAMETER krank IS SPECIFIED,
!   krank CONTAINS THE EFFECTIVE RANK OF a. I.E., THE NUMBER
!   OF INDEPENDENT COLUMNS IN MATRIX a.
!                      
!   IF tol IS PRESENT AND IS IN [0,1[, THEN :
!       ON ENTRY, SPECIFIC CALCULATIONS TO DETERMINE THE EFFECTIVE RANK a
!       ARE PERFORMED. tol IS USED TO DETERMINE THE EFFECTIVE RANK
!       OF a, WHICH IS THEN DEFINED AS THE ORDER OF THE LARGEST LEADING
!       TRIANGULAR SUBMATRIX r11 IN THE QR FACTORIZATION WITH PIVOTING OF a,
!       WHOSE ESTIMATED CONDITION NUMBER IN THE 1-NORM IS LESS THAN 1/tol.
!       IF tol=0 IS SPECIFIED THE NUMERICAL RANK OF a IS DETERMINED.
!       ON EXIT, THE RECIPROCAL OF THE CONDITION NUMBER IS RETURNED IN tol.
!
!   IF tol IS NOT SPECIFIED OR IS OUTSIDE [0,1[ :
!       THE CALCULATIONS TO DETERMINE THE EFFECTIVE RANK OF a ARE NOT
!       PERFORMED AND CRUDE TESTS ON r(j,j) ARE DONE TO DETERMINE
!       THE NUMERICAL RANK OF a.
!
!   IF IT IS POSSIBLE THAT a MAY NOT BE FULL RANK (I.E., CERTAIN COLUMNS OF a ARE
!   LINEAR COMBINATIONS OF OTHER COLUMNS), THEN THE LINEARLY DEPENDENT COLUMNS CAN
!   USUALLY BE DETERMINED BY USING krank=0  AND tol=RELATIVE PRECISION OF THE ELEMENTS
!   IN a. IF EACH ELEMENT IS CORRECT TO, SAY, 5 DIGITS THEN tol=0.00001 SHOULD
!   BE USED. ALSO, IT MAY BE HELPFUL TO SCALE THE COLUMNS OF a SO THAT ALL ELEMENTS 
!   ARE ABOUT THE SAME ORDER OF MAGNITUDE.
!   
!   ON EXIT, IF THE OPTIONAL PARAMETER resid IS PRESENT,
!   THE RESIDUAL VECTOR OR MATRIX b - a*x is COMPUTED AND
!
!                               resid = b - a*x .
!
!   THE 2-NORM OF THE RESIDUAL VECTOR(S) FOR THE SOLUTION VECTOR(S) x, CAN ALSO BE COMPUTED
!   DIRECTLY BY SPECIFYING THE OPTIONAL PARAMETER rnorm IN THE CALL OF llsq_qr_solve .
!
!   THE MINIMUN 2-NORM SOLUTION(S) ARE COMPUTED IF THE OPTIONAL LOGICAL PARAMETER min_norm IS
!   PRESENT AND IS SET TO true. OTHERWISE, SOLUTION(S) ARE COMPUTED SUCH THAT IF THE jTH COLUMN
!   OF a IS OMITTED FROM THE BASIS, x[j] OR x[j,:nrhs] IS SET TO ZERO.
!
    if ( do_test ) then
!
!       CHECK THAT THE RESIDUALS ARE ORTHOGONAL TO THE COLUMN VECTORS OF a .
!
        err = maxval( sum( abs( matmul( transpose(resid), a ) ), dim=2 ) )/ sum( abs(a) )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, b, resid, x )
!
!   PRINT THE RESULT OF THE TEST.
!
    if ( err<=sqrt(epsilon(err)) ) then
        write (prtunit,*) 'Example 2 of LLSQ_QR_SOLVE is correct'
    else
        write (prtunit,*) 'Example 2 of LLSQ_QR_SOLVE is incorrect'
    end if
!
!
! END OF PROGRAM ex2_llsq_qr_solve
! ================================
!
end program ex2_llsq_qr_solve

ex2_llsq_qr_solve2.F90

program ex2_llsq_qr_solve2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine LLSQ_QR_SOLVE2
!   in module LLSQ_Procedures.
!                                                                              
! LATEST REVISION : 20/01/2021
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, lgl, zero, false, true, llsq_qr_solve2
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, m=4000, n=2000, nrhs=100
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, tol
    real(stnd), allocatable, dimension(:,:) :: x, b, a, a2
!
    integer(i4b) :: krank
!
    integer      :: iok
!
    logical(lgl) :: comp_resid, do_test
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 2 of llsq_qr_solve2'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
    err      = zero
    do_test  = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(m,n), b(m,nrhs), x(n,nrhs), stat=iok )
!
    if ( iok/=0 ) then
        write (prtunit,*)  'Problem in attempt to allocate memory !'
        stop
    end if
!
!   GENERATE A RANDOM COEFFICIENT MATRIX a .
!
    call random_number( a )
!
!   GENERATE A RANDOM RIGHT HAND-SIDE MATRIX b .
!
    call random_number( b )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAY.
!
        allocate( a2(m,n), stat=iok )
!
        if ( iok/=0 ) then
            write (prtunit,*)  'Problem in attempt to allocate memory !'
            stop
        end if
!
!       SAVE DATA MATRIX .
!
        a2(:m,:n) = a(:m,:n)
!
    end if
!
!   EXAMPLE 2 : LINEAR LEAST SQUARES SYSTEM.
!
!   COMPUTE SOLUTION MATRIX FOR LINEAR LEAST SQUARES SYSTEM
!
!           a(:m,:n)*x(:n,:nrhs)=b(:m,:nrhs) .
!
!   SET TOLERANCE .
!
    tol = 0.00001_stnd
!
    krank      = 0_i4b
    comp_resid = true
!
    call llsq_qr_solve2( a(:m,:n), b(:m,:nrhs), x(:n,:nrhs),               &
                         comp_resid=comp_resid, krank=krank, tol=tol )
!
!   llsq_qr_solve2 COMPUTES SOLUTION(S) TO REAL LINEAR LEAST SQUARES PROBLEMS 
!   OF THE FORM:
!
!                       Minimize 2-norm(| b - a*x |)
!
!   USING AN ORTHOGONAL FACTORIZATION WITH COLUMNS PIVOTING OF a. a IS A m VECTOR
!   OR AN m-BY-n MATRIX WHICH MAY BE RANK-DEFICIENT. IF a IS A MATRIX, m>=n OR
!   n>m IS PERMITTED.
!
!   SEVERAL RIGHT HAND SIDE VECTORS b AND SOLUTION VECTORS x CAN BE
!   HANDLED IN A SINGLE CALL; THEY ARE STORED AS THE COLUMNS OF THE
!   m-BY-nrhs RIGHT HAND SIDE MATRIX b AND THE n-BY-nrhs SOLUTION
!   MATRIX x, RESPECTIVELY. IN OTHER WORDS, THE ARGUMENTS b AND x MAY
!   BE VECTORS OR MATRICES.
!
!   a AND b ARE OVERWRITTEN BY llsq_qr_solve2. THE OPTIONAL ARGUMENTS krank,
!   tol AND min_norm MUST NOT BE PRESENT IF a IS A m-VECTOR.
!
!   ON INPUT, IF THE OPTIONAL PARAMETER krank IS SPECIFIED AND IF krank=k,
!   THIS IMPLIES THAT THE FIRST k COLUMNS OF a ARE TO BE FORCED INTO THE BASIS.
!   PIVOTING IS PERFORMED ON THE LAST n-k COLUMNS OF a.
!   
!   WHEN krank>=min(m,n) IS USED, PIVOTING IS NOT PERFORMED. THIS IS
!   APPROPRIATE WHEN a IS KNOWN TO BE FULL RANK. krank<=0 CAN BE USED
!   WHEN PIVOTING IS DESIRED ON ALL COLUMNS OF a.
!   
!   BY DEFAULT, PIVOTING IS DONE ON ALL THE COLUMNS OF a.
!   
!   ON EXIT, IF THE OPTIONAL PARAMETER krank IS SPECIFIED,
!   krank CONTAINS THE EFFECTIVE RANK OF a. I.E., THE NUMBER
!   OF INDEPENDENT COLUMNS IN MATRIX a.
!                      
!   IF tol IS PRESENT AND IS IN [0,1[, THEN :
!       ON ENTRY, SPECIFIC CALCULATIONS TO DETERMINE THE EFFECTIVE RANK a
!       ARE PERFORMED. tol IS USED TO DETERMINE THE EFFECTIVE RANK
!       OF a, WHICH IS THEN DEFINED AS THE ORDER OF THE LARGEST LEADING
!       TRIANGULAR SUBMATRIX r11 IN THE QR FACTORIZATION WITH PIVOTING OF a,
!       WHOSE ESTIMATED CONDITION NUMBER IN THE 1-NORM IS LESS THAN 1/tol.
!       IF tol=0 IS SPECIFIED THE NUMERICAL RANK OF a IS DETERMINED.
!       ON EXIT, THE RECIPROCAL OF THE CONDITION NUMBER IS RETURNED IN tol.
!
!   IF tol IS NOT SPECIFIED OR IS OUTSIDE [0,1[ :
!       THE CALCULATIONS TO DETERMINE THE EFFECTIVE RANK OF a ARE NOT
!       PERFORMED AND CRUDE TESTS ON r(j,j) ARE DONE TO DETERMINE
!       THE NUMERICAL RANK OF a.
!
!   IF IT IS POSSIBLE THAT a MAY NOT BE FULL RANK (I.E., CERTAIN COLUMNS OF a ARE
!   LINEAR COMBINATIONS OF OTHER COLUMNS), THEN THE LINEARLY DEPENDENT COLUMNS CAN
!   USUALLY BE DETERMINED BY USING krank=0  AND tol=RELATIVE PRECISION OF THE ELEMENTS
!   IN a. IF EACH ELEMENT IS CORRECT TO, SAY, 5 DIGITS THEN tol=0.00001 SHOULD
!   BE USED. ALSO, IT MAY BE HELPFUL TO SCALE THE COLUMNS OF a SO THAT ALL ELEMENTS 
!   ARE ABOUT THE SAME ORDER OF MAGNITUDE.
!   
!   ON EXIT, IF THE OPTIONAL LOGICAL PARAMETER comp_resid IS PRESENT AND IS SET TO true,
!   THE RESIDUAL VECTOR OR MATRIX b - a*x is COMPUTED AND IS OUTPUT IN b .
!
!   THE 2-NORM OF THE RESIDUAL VECTOR(S) FOR THE SOLUTION VECTOR(S) x, CAN ALSO BE COMPUTED
!   DIRECTLY BY SPECIFYING THE OPTIONAL PARAMETER rnorm IN THE CALL OF llsq_qr_solve2 .
!
!   THE MINIMUN 2-NORM SOLUTION(S) ARE COMPUTED IF THE OPTIONAL LOGICAL PARAMETER min_norm IS
!   PRESENT AND IS SET TO true. OTHERWISE, SOLUTION(S) ARE COMPUTED SUCH THAT IF THE jTH COLUMN
!   OF a IS OMITTED FROM THE BASIS, x[j] OR x[j,:nrhs] IS SET TO ZERO.
!
    if ( do_test ) then
!
!       CHECK THAT THE RESIDUALS ARE ORTHOGONAL TO THE COLUMN VECTORS OF a .
!
        err = maxval( sum( abs( matmul( transpose(b), a2 ) ), dim=2 ) )/ sum( abs(a2) )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a2 )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, b, x )
!
!   PRINT THE RESULT OF THE TEST.
!
    if ( err<=sqrt(epsilon(err)) ) then
        write (prtunit,*) 'Example 2 of LLSQ_QR_SOLVE2 is correct'
    else
        write (prtunit,*) 'Example 2 of LLSQ_QR_SOLVE2 is incorrect'
    end if
!
!
! END OF PROGRAM ex2_llsq_qr_solve2
! =================================
!
end program ex2_llsq_qr_solve2

ex2_llsq_svd_solve.F90

program ex2_llsq_svd_solve
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine LLSQ_SVD_SOLVE
!   in module LLSQ_Procedures . 
!                                                                              
! LATEST REVISION : 04/09/2014
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, zero, c50, false, true, lamch, norm,      &
                         print_array, llsq_svd_solve, merror, allocate_error
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=2000, m=4000, p=min(m,n), nrhs=400
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of llsq_svd_solve'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, eps, tol, cond, sfmin
    real(stnd), dimension(nrhs)             :: rnorm, bnorm
    real(stnd), dimension(n)                :: sing_values
    real(stnd), allocatable, dimension(:,:) :: a, a2, b, b2, x, res
!
    integer(i4b) :: krank
!
    integer      :: iok
!
    logical(lgl) :: failure, do_test, do_print
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 2 : LINEAR LEAST SQUARES SYSTEM AND SEVERAL RIGHT HAND-SIDES.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    do_test  = false
    do_print = false
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(m,n), b(m,nrhs), x(n,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 )
!
!   GENERATE A m-by-nrhs REAL RANDOM RIGHT HAND-SIDE MATRIX b .
!
    call random_number( b )
!
    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
!
    if ( do_print ) then
!
!       COMPUTE THE NORM OF DEPENDENT VARIABLE b .
!
        bnorm(:nrhs) = norm( b(:m,:nrhs), dim=2_i4b )
!
    end if
!
!   llsq_svd_solve COMPUTES THE MINIMUM NORM SOLUTIONS TO REAL LINEAR LEAST
!   SQUARES PROBLEMS :
!
!                       Minimize 2-norm(| b - A*x |)
!
!   USING THE SINGULAR VALUE DECOMPOSITION (SVD) OF A. A IS AN m-BY-n MATRIX
!   WHICH MAY BE RANK-DEFICIENT.
!
!   SEVERAL RIGHT HAND SIDE VECTORS b AND SOLUTION VECTORS x CAN BE
!   HANDLED IN A SINGLE CALL; THEY ARE STORED AS THE COLUMNS OF THE
!   m-BY-nrhs RIGHT HAND SIDE MATRIX B AND THE n-BY-nrhs SOLUTION
!   MATRIX X, RESPECTIVELY.
!
!   THE EFFECTIVE RANK OF a, krank, IS DETERMINED BY TREATING AS ZERO THOSE
!   SINGULAR VALUES WHICH ARE LESS THAN tol TIMES THE LARGEST SINGULAR VALUE.
!
    tol = 0.0000001_stnd
!
!   COMPUTE THE LEAST-SQUARES SOLUTION MATRIX OF a*x=b .
!
    call llsq_svd_solve( a, b, failure, x,                                            &
                         singvalues=sing_values, krank=krank, rnorm=rnorm, tol=tol )
!
    if ( do_test ) then
!
!       CHECK THAT THE RESIDUALS ARE ORTHOGONAL TO THE COLUMN VECTORS OF a .
!
        res = b2 - matmul( a2, x )
        err = maxval( sum(abs(matmul(transpose(a2),res)),   dim=1) )/ sum( abs(a2) )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a2, b2, res )
!
    end if
!
    if ( err<=eps .and. .not.failure ) then
!
        write (prtunit,*) name_proc//' is correct'
!
        if ( do_print ) then
!
!           GET MACHINE CONSTANT sfmin, SUCH THAT 1/sfmin DOES NOT OVERFLOW.
!
            sfmin = lamch( 's' )
!
!           COMPUTE THE CONDITION NUMBER OF A IN THE 2-NORM
!
!               singvalues(1)/singvalues(min(m,n)) .
!
            if ( sing_values(p)/sing_values(1)<=sfmin ) then
                cond = huge( a )
            else
                cond = sing_values(1)/sing_values(p)
            end if
!
!           PRINT RESULTS .
!
            write (prtunit,*)
            write (prtunit,*)
            write (prtunit,*) 'LEAST SQUARES SOLUTION VIA SINGULAR VALUE DECOMPOSITION'
            write (prtunit,*) '           MIN OF IIA*x-bII**2 FOR x                   '
            write (prtunit,*)
!
            call print_array( sing_values, title=' SINGULAR VALUES ASSOCIATED WITH MATRIX A ' )
!
            write (prtunit,*)
            write (prtunit,*) 'TOLERANCE FOR ZERO SINGULAR VALUE (tol*sing_values(1)):',tol*sing_values(1)
            write (prtunit,*)
            write (prtunit,*) 'CONDITION NUMBER OF A :',cond
            write (prtunit,*) 'RANK OF A             :',krank
            write (prtunit,*)
!
            call print_array( rnorm**2,         title=' RESIDUALS SUM OF SQUARES IIA*x-bII**2 ' )
            call print_array( (rnorm/bnorm)**2, title=' RESIDUALS SUM OF SQUARES (%) (IIA*x-bII**2/IIbII**2) ' )
            call print_array( x,                title=' ASSOCIATED LEAST SQUARES SOLUTIONS x ' )
!
        end if
!
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, b, x )
!
!
! END OF PROGRAM ex2_llsq_svd_solve
! =================================
!
end program ex2_llsq_svd_solve

ex2_lu_cmp.F90

program ex2_lu_cmp
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines LU_CMP and LU_SOLVE
!   in module Lin_Procedures . 
!                                                                              
! LATEST REVISION : 11/06/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, zero, true, false, lu_cmp, lu_solve,    &
                         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
!
    integer(i4b), parameter :: prtunit=6, n=3000, nrhs=3000
!
    character(len=*), parameter :: name_proc='Example 2 of lu_cmp'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, eps, d1, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, b, x, res
!
    integer(i4b), dimension(:), allocatable :: ip
    integer                                 :: iok, istart, iend, irate, imax, itime
!
    logical(lgl)   :: do_test
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 2 : SOLVING A LINEAR SYSTEM WITH A REAL n-BY-n MATRIX
!               AND SEVERAL RIGHT HAND-SIDES WITH THE LU DECOMPOSITION.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = sqrt( epsilon( err ) )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), b(n,nrhs), x(n,nrhs), ip(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 LINEAR SYSTEM
!
!            a*x = b .
!
!   BY COMPUTING THE LU DECOMPOSITION WITH PARTIAL PIVOTING AND
!   IMPLICIT ROW SCALING OF MATRIX a . IF ON OUTPUT OF lu_cmp
!   d1 IS DIFFERENT FROM ZERO THEN THE LINEAR SYSTEM IS NOT
!   SINGULAR AND CAN BE SOLVED BY SUBROUTINE lu_solve.
!
    call lu_cmp( a, ip, d1 )
!
    if ( d1==zero ) then
!
!       ANORMAL EXIT FROM lu_cmp SUBROUTINE, PRINT A WARNING.
!
        write (prtunit,*) 'Error in exit of LU_CMP subroutine, d1=', d1
!
    else
!
        call lu_solve( a, ip, b )
!
    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 ( d1/=zero .and. 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 ARRAYS.
!
        deallocate( a, b, x, ip, res )
!
    else
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, b, x, ip )
!
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. d1/=zero ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,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 ex2_lu_cmp
! =========================
!
end program ex2_lu_cmp

ex2_permute_cor.F90

program ex2_permute_cor
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines COMP_COR and PERMUTE_COR
!   in module Mul_Stat_Procedures .
!                                                                              
! LATEST REVISION : 06/07/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, lgl, true, comp_cor, permute_cor, random_seed_, random_number_
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
! p       IS THE NUMBER OF OBSERVATIONS OF THE RANDOM VECTORS
! nrep    IS THE NUMBER OF SHUFFLES FOR THE PERMUTATION TEST
! nsample IS THE NUMBER OF SAMPLES TO EVALUATE THE REJECTION RATE OF THE TEST
!
    integer(i4b), parameter :: prtunit=6, p=50, nrep=99, nsample=3000
!
! sign_level IS THE SIGNIFICANCE LEVEL OF THE PERMUTATION TEST
! eps        IS THE ALLOWED RELATIVE ERROR FOR THE REJECTION RATE
!
    real(stnd),  parameter :: sign_level=0.05, eps=0.2
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                       :: xyn, err_prob, prob_rej_rate
    real(stnd), dimension(nsample)   :: xycor, prob
    real(stnd), dimension(nsample,2) :: xstat
    real(stnd), dimension(2)         :: ystat
    real(stnd), dimension(nsample,p) :: x
    real(stnd), dimension(p)         :: y
!
    integer(i4b) :: rej_rate
!
    logical(lgl) :: first, last
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 2 of permute_cor'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   INITIALIZE THE RANDOM GENERATOR.
!
    call random_seed_()
!
!   GENERATE A RANDOM UNIFORM OBSERVATION VECTOR y .
!
    call random_number_( y(:p) )
!
!   GENERATE A RANDOM UNIFORM OBSERVATION ARRAY x .
!
    call random_number_( x(:nsample,:p) )
!
!   COMPUTE THE CORRELATIONS BETWEEN x AND y
!   FOR THE p OBSERVATIONS .
!
    first = true
    last  = true
    call comp_cor( x(:nsample,:p), y(:p), first, last, xstat(:nsample,:2), ystat(:2),    &
                   xycor(:nsample), xyn )
!
!   ON EXIT OF COMP_COR WHEN last=true :
!
!      xstat(:nsample,1)     CONTAINS THE MEAN VALUES OF THE OBSERVATION ARRAY x(:nsample,:p).
!
!      xstat(:nsample,2)     CONTAINS THE VARIANCES OF THE OBSERVATION ARRAY x(:nsample,:p).
!
!      ystat(1)              CONTAINS THE MEAN VALUE OF THE OBSERVATION VECTOR  y(:p).
!
!      ystat(2)              CONTAINS THE VARIANCE OF THE OBSERVATION VECTOR  y(:p).
!
!      xycor(:nsample)       CONTAINS THE CORRELATION COEFFICIENTS BETWEEN x(:nsample,:p) AND y(:p).
!
!      xyn                   CONTAINS THE NUMBER OF OBSERVATIONS IN THE DATA ARRAYS
!                            x(:nsample,:p) AND  y(:p) (xyn=real(p,stnd) ).
!
!
!   NOW COMPUTE A PERMUTATION TEST OF THE CORRELATION BETWEEN x AND y WITH
!   SUBROUTINE permute_cor WITH nrep SHUFFLES .
!
    call permute_cor( x(:nsample,:p), y(:p), xstat(:nsample,:2), ystat(:2),   &
                      xycor(:nsample), prob(:nsample), nrep=nrep )
!
!   NOW COMPUTE THE REJECTION RATE OF THE TEST. IDEALLY, FOR THE sign_level
!   SIGNIFICANCE LEVEL, WE WOULD REJECT ONLY THE NULL HYPOTHESIS sign_level %
!   OF THE TIME. IN OTHER WORDS, THE REJECTION RATE MUST BE APPROXIMATELY EQUAL
!   TO THE SIGNIFICANCE LEVEL sign_level .
!
    rej_rate      = count( prob(:nsample)<=sign_level )
    prob_rej_rate = real( rej_rate, stnd )/real( nsample, stnd )
!
!   COMPUTE THE RELATIVE ERROR OF THE REJECTION RATE.
!
    err_prob = abs( (prob_rej_rate-sign_level)/sign_level )
!
!   CHECK THAT THE RELATIVE ERROR OF THE REJECTION RATE IS LESS THAN eps .
!
    if ( err_prob<=eps ) then
        write (prtunit,*) 'Example 2 of PERMUTE_COR is correct'
    else
        write (prtunit,*) 'Example 2 of PERMUTE_COR is incorrect'
    end if
!
!
! END OF PROGRAM ex2_permute_cor
! ==============================
!
end program ex2_permute_cor

ex2_phase_scramble_cor.F90

program ex2_phase_scramble_cor
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines COMP_COR and PHASE_SCRAMBLE_COR
!   in module Mul_Stat_Procedures .
!                                                                              
! LATEST REVISION : 06/07/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, lgl, true, comp_cor, phase_scramble_cor, pinvn
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
! p       IS THE NUMBER OF OBSERVATIONS OF THE TIME SERIES VECTORS
! nrep    IS THE NUMBER OF SHUFFLES FOR THE PHASE-SCRAMBLED BOOTSTRAP TEST
! nsample IS THE NUMBER OF SAMPLES TO EVALUATE THE REJECTION RATE OF THE TEST
!
    integer(i4b), parameter :: prtunit=6, p=50, nrep=99, nsample=2000
!
! sign_level IS THE SIGNIFICANCE LEVEL OF PHASE-SCRAMBLED BOOTSTRAP TEST
! eps        IS THE ALLOWED RELATIVE ERROR FOR THE REJECTION RATE
! b          IS THE LAG-1 AUTOCORRELATION FOR THE AR(1) MODEL USED
!            TO GENERATE THE TIME SERIES
!
    real(stnd),  parameter :: sign_level=0.05, eps=0.2, b=0.2
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                       :: xyn, err_prob, prob_rej_rate
    real(stnd), dimension(nsample)   :: xycor, prob
    real(stnd), dimension(nsample,2) :: xstat
    real(stnd), dimension(2)         :: ystat
    real(stnd), dimension(nsample,p) :: x, e
    real(stnd), dimension(p)         :: y, e2
!
    integer(i4b) :: j, rej_rate
!
    logical(lgl) :: first, last
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 2 of phase_scramble_cor'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   INITIALIZE THE RANDOM GENERATOR.
!
    call random_seed()
!
!   GENERATE A TIME SERIES USING AN AR(1) MODEL OF THE FORM
!
!               y(i+1) = b*y(i) + e2(i)
!
!     WHERE b IS THE SPECIFIED LAG-1 AUTOCORRELATION AND e2(i)
!     IS A NORMALLY DISTRIBUTED RANDOM VARIABLE WITH A 0 MEAN
!     AND A VARIANCE OF 1.
!
    call random_number( y(:p) )
    e2(:p) = pinvn( y(:p) )
!
    y(1) = e2(1)
    do j=2, p
        y(j) = b*y(j-1) + e2(j)
    end do
!
!   GENERATE nsample INDEPENDENT TIME SERIES FROM THE SAME AR(1) MODEL.
!
    call random_number( x(:nsample,:p) )
    e(:nsample,:p) = pinvn( x(:nsample,:p) )
!
    x(:nsample,1) = e(:nsample,1)
    do j=2, p
        x(:nsample,j) = b*x(:nsample,j-1) + e(:nsample,j)
    end do
!
!   COMPUTE THE CORRELATIONS BETWEEN x AND y
!   FOR THE p OBSERVATIONS .
!
    first = true
    last  = true
    call comp_cor( x(:nsample,:p), y(:p), first, last, xstat(:nsample,:2), ystat(:2),    &
                   xycor(:nsample), xyn )
!
!   ON EXIT OF COMP_COR WHEN last=true :
!
!      xstat(:nsample,1)     CONTAINS THE MEAN VALUES OF THE OBSERVATION ARRAY x(:nsample,:p).
!
!      xstat(:nsample,2)     CONTAINS THE VARIANCES OF THE OBSERVATION ARRAY x(:nsample,:p).
!
!      ystat(1)              CONTAINS THE MEAN VALUE OF THE OBSERVATION VECTOR  y(:p).
!
!      ystat(2)              CONTAINS THE VARIANCE OF THE OBSERVATION VECTOR  y(:p).
!
!      xycor(:nsample)       CONTAINS THE CORRELATION COEFFICIENTS BETWEEN x(:nsample,:p) AND y(:p).
!
!      xyn                   CONTAINS THE NUMBER OF OBSERVATIONS IN THE DATA ARRAYS
!                            x(:nsample,:p) AND  y(:p) (xyn=real(p,stnd) ).
!
!
!   NOW COMPUTE A THE PHASE-SCRAMBLED BOOTSTRAP TEST OF THE CORRELATION
!   BETWEEN x AND y WITH SUBROUTINE phase_scramble_cor WITH nrep SHUFFLES .
!
    call phase_scramble_cor( x(:nsample,:p), y(:p), xstat(:nsample,:2), ystat(:2),   &
                             xycor(:nsample), prob(:nsample), nrep=nrep )
!
!   NOW COMPUTE THE REJECTION RATE OF THE TEST. IDEALLY, FOR THE sign_level
!   SIGNIFICANCE LEVEL, WE WOULD REJECT ONLY THE NULL HYPOTHESIS sign_level %
!   OF THE TIME. IN OTHER WORDS, THE REJECTION RATE MUST BE APPROXIMATELY EQUAL
!   TO THE SIGNIFICANCE LEVEL sign_level .
!
    rej_rate      = count( prob(:nsample)<=sign_level )
    prob_rej_rate = real( rej_rate, stnd )/real( nsample, stnd )
!
!   COMPUTE THE RELATIVE ERROR OF THE REJECTION RATE.
!
    err_prob = abs( (prob_rej_rate-sign_level)/sign_level )
!
!   CHECK THAT THE RELATIVE ERROR OF THE REJECTION RATE IS LESS THAN eps .
!
    if ( err_prob<=eps ) then
        write (prtunit,*) 'Example 2 of PHASE_SCRAMBLE_COR is correct'
    else
        write (prtunit,*) 'Example 2 of PHASE_SCRAMBLE_COR is incorrect'
    end if
!
!
! END OF PROGRAM ex2_phase_scramble_cor
! =====================================
!
end program ex2_phase_scramble_cor

ex2_probq.F90

program ex2_probq
!
!
! Purpose
! =======
!
!   This program is intended to illustrate the use of functions PROBQ, PINVQ
!   in module Prob_Procedures .
!                                                                              
!                                                                              
! LATEST REVISION : 26/02/2013
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, false, one, c99, probq, pinvq
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=5000, m=10000
!
    real(stnd), parameter :: eps = 1.0e-3_stnd 
!
    character(len=*), parameter :: name_proc='Example 2 of probq'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd), dimension(n,m) :: p, p2, x2
    real(stnd)                 :: err
!
    integer(i4b), dimension(n,m) :: ndf
!
    logical(lgl) :: upper
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE THE DEGREES OF FREEDOM OF CHI-SQUARED DISTRIBUTION .
!
    call random_number( x2(:n,:m) )
!
    x2(:n,:m) = c99*x2(:n,:m)
    where( x2(:n,:m)<one )  x2(:n,:m) = x2(:n,:m) + one
!
    ndf(:n,:m) = x2(:n,:m)
!
!   GENERATE A RANDOM PROBABILITY MATRIX p(:m,:n) .
!
    call random_number( p(:n,:m) )
!
!   COMPUTE THE QUANTILES x2(:m,:n) OF CHI-SQUARED DISTRIBUTION WITH ndf DEGREES OF FREEDOM
!   CORRESPONDING TO LOWER TAIL AREAS OF p(:m,:n) .
!
    x2(:n,:m) = pinvq( p(:n,:m), ndf(:n,:m) )
!
!   RECOMPUTE THE PROBABILITIES FROM THE QUANTILES
!   WITH probq FUNCTION.
!
    upper = false
!
    p2(:n,:m) = probq( x2(:n,:m), ndf(:n,:m), upper=upper )
!
!   CHECK THAT p(:n,:m) AND p2(:n,:m) AGREE.
!
    err = maxval( abs( p(:n,:m) - p2(:n,:m) ) )
!
!   PRINT THE RESULT OF THE TEST.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex2_probq
! ========================
!
end program ex2_probq

ex2_probq2.F90

program ex2_probq2
!
!
! Purpose
! =======
!
!   This program is intended to illustrate the use of functions PROBQ2, PINVQ2
!   in module Prob_Procedures .
!                                                                              
!                                                                              
! LATEST REVISION : 27/02/2013
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, false, one, c99, probq2, pinvq2
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=5000, m=10000
!
    real(stnd), parameter :: eps = 1.0e-4_stnd 
!
    character(len=*), parameter :: name_proc='Example 2 of probq2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd), dimension(n,m) :: p, p2, x2, df
    real(stnd)                 :: err
!
    logical(lgl) :: upper
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE THE DEGREES OF FREEDOM OF CHI-SQUARED DISTRIBUTION .
!   HERE df(:,:) ARE NOT NECESSARILY INTEGERS.
!
    call random_number( df(:n,:m) )
!
    df(:n,:m) = c99*df(:n,:m) + one
!
!   GENERATE A RANDOM PROBABILITY MATRIX p(:m,:n) .
!
    call random_number( p(:n,:m) )
!
!   COMPUTE THE QUANTILES x2(:m,:n) OF CHI-SQUARED DISTRIBUTION WITH df(:m,:n) DEGREES OF FREEDOM
!   CORRESPONDING TO LOWER TAIL AREAS OF p(:m,:n) .
!
    x2(:n,:m) = pinvq2( p(:n,:m), df(:n,:m) )
!
!   RECOMPUTE THE PROBABILITIES FROM THE QUANTILES
!   WITH probq FUNCTION.
!
    upper = false
!
    p2(:n,:m) = probq2( x2(:n,:m), df(:n,:m), upper=upper )
!
!   CHECK THAT p(:n,:m) AND p2(:n,:m) AGREE.
!
    err = maxval( abs( p(:n,:m) - p2(:n,:m) ) )
!
!   PRINT THE RESULT OF THE TEST.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex2_probq2
! =========================
!
end program ex2_probq2

ex2_probstudent.F90

program ex2_probstudent
!
!
! Purpose
! =======
!
!   This program is intended to illustrate the use of functions PROBSTUDENT, PINVSTUDENT
!   in module Prob_Procedures .
!                                                                              
!                                                                              
! LATEST REVISION : 26/02/2013
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, false, two, c99, probstudent, pinvstudent
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=5000, m=10000
!
    real(stnd), parameter :: eps = 1.0e-3_stnd 
!
    character(len=*), parameter :: name_proc='Example 2 of probstudent'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd), dimension(n,m) :: p, p2, t, df
    real(stnd)                 :: err
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE THE DEGREES OF FREEDOM OF STUDENT T-DISTRIBUTION .
!
    call random_number( df(:n,:m) )
!
    df(:n,:m) = c99*df(:n,:m)
    where( df(:n,:m)<two )  df(:n,:m) = df(:n,:m) + two
!
!   GENERATE A RANDOM PROBABILITY MATRIX p(:n,:m) .
!
    call random_number( p(:n,:m) )
!
!   COMPUTE THE TWO-TAIL QUANTILES t OF STUDENT T-DISTRIBUTION 
!   WITH df DEGREES OF FREEDOM CORRESPONDING TO AREAS OF p(:n,:m) .
!
    t(:n,:m) = pinvstudent( p(:n,:m), df(:n,:m) )
!
!   RECOMPUTE THE PROBABILITIES FROM THE QUANTILES
!   WITH probstudent FUNCTION.
!
    p2(:n,:m) = probstudent( t(:n,:m), df(:n,:m) )
!
!   CHECK THAT p AND p2 AGREE.
!
    err = maxval( abs( p(:n,:m) - p2(:n,:m) ) )
!
!   PRINT THE RESULT OF THE TEST.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex2_probstudent
! ==============================
!
end program ex2_probstudent

ex2_probt.F90

program ex2_probt
!
!
! Purpose
! =======
!
!   This program is intended to illustrate the use of functions PROBT, PINVT
!   in module Prob_Procedures .
!                                                                              
!                                                                              
! LATEST REVISION : 26/02/2013
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, false, one, c99, probt, pinvt
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=5000, m=10000
!
    real(stnd), parameter :: eps = 1.0e-4_stnd 
!
    character(len=*), parameter :: name_proc='Example 2 of probt'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd), dimension(n,m) :: p, p2, t
    real(stnd)                 :: err
!
    integer(i4b), dimension(n,m) :: ndf
!
    logical(lgl) :: upper
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE THE DEGREES OF FREEDOM OF STUDENT T-DISTRIBUTION .
!
    call random_number( t(:n,:m) )
!
    t(:n,:m) = c99*t(:n,:m)
    where( t(:n,:m)<one )  t(:n,:m) = t(:n,:m) + one
!
    ndf(:n,:m) = t(:n,:m)
!
!   GENERATE A RANDOM PROBABILITY MATRIX p(:,:) .
!
    call random_number( p(:n,:m) )
!
!   COMPUTE THE QUANTILES t(:,:) OF STUDENT T-DISTRIBUTION WITH ndf(:,:) DEGREES OF FREEDOM
!   CORRESPONDING TO LOWER TAIL AREAS OF p(:,:) .
!
    t(:n,:m) = pinvt( p(:n,:m), ndf(:n,:m) )
!
!   RECOMPUTE THE PROBABILITIES FROM THE QUANTILES
!   WITH probt FUNCTION.
!
    upper = false
!
    p2(:n,:m) = probt( t(:n,:m), ndf(:n,:m), upper=upper )
!
!   CHECK THAT p AND p2 AGREE.
!
    err = maxval( abs( p(:n,:m) - p2(:n,:m) ) )
!
!   PRINT THE RESULT OF THE TEST.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
!
! END OF PROGRAM ex2_probt
! ========================
!
end program ex2_probt

ex2_qr_cmp.F90

program ex2_qr_cmp
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines QR_CMP and QR_SOLVE
!   in modules QR_Procedures and LLSQ_Procedures .
!    
! LATEST REVISION : 06/07/2006                                                                             
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, true, qr_cmp, qr_solve
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, m=1000, n=500
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                 :: err
    real(stnd), dimension(m,n) :: a, a2
    real(stnd), dimension(n)   :: x, diagr, beta
    real(stnd), dimension(m)   :: b
!
    character(len=*), parameter :: name_proc='Example 2 of qr_cmp'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A RANDOM COEFFICIENT MATRIX a .
!
    call random_number( a )
!
!   GENERATE A RANDOM RIGHT HAND-SIDE VECTOR b .
!
    call random_number( b )
!
!   MAKE A COPY OF COEFFICIENT MATRIX a(:m,:n) .
!
    a2(:m,:n) = a(:m,:n)
!
!   EXAMPLE 2 : LINEAR LEAST SQUARES SYSTEM.
!
!   COMPUTE SOLUTION VECTOR FOR LINEAR LEAST SQUARES SYSTEM
!
!           a(:m,:n)*x(:n)=b(:m) .
!
!
!   FIRST COMPUTE QR FACTORIZATION OF a .
!
    call qr_cmp( a2, diagr, beta )
!
!   qr_cmp COMPUTES AN ORTHOGONAL FACTORIZATION OF A REAL m-BY-n MATRIX
!   a . a IS ASSUMED OF FULL RANK. THE ROUTINE COMPUTES A QR FACTORIZATION
!   a :
!
!                     a = q * r 
!
!   ON EXIT, a HAS BEEN OVERWRITTEN BY DETAILS OF ITS ORTHOGONAL
!   FACTORIZATION. 
!
!   THE MATRIX q IS REPRESENTED AS A PRODUCT OF ELEMENTARY REFLECTORS
!
!            q = h(1)*h(2)* ... *h(k), WHERE k = min( size(a,1) , size(a,2) )
!
!   EACH h(i) HAS THE FORM
!
!            h(i) = I + BETA * ( V * V' ) ,
!                      
!   WHERE BETA IS A REAL SCALAR AND V IS A REAL M-ELEMENT VECTOR WITH V(1:i-1) = 0.
!   V(i:m) IS STORED ON EXIT IN a(i:m,i) AND BETA IN beta(i).
!                      
!   THE ELEMENTS ABOVE THE DIAGONAL OF THE ARRAY a CONTAIN THE
!   CORRESPONDING ELEMENTS OF THE TRIANGULAR MATRIX r. THE ELEMENTS
!   OF THE DIAGONAL OF r ARE STORED IN THE ARRAY diagr. 
!
!
!   NOW, COMPUTE SOLUTION AND RESIDUAL VECTOR FOR LINEAR LEAST SQUARES SYSTEM
!
!             a(:m,:n)*x(:n)=b(:m) .
!
    call qr_solve( a2, diagr, beta, b, x, comp_resid=true )
!
!   qr_solve SOLVES OVERDETERMINED OR UNDERDETERMINED REAL LINEAR SYSTEMS
!
!                               a*x = b          
!
!   WITH AN m-BY-n MATRIX a, USING AN ORTHOGONAL FACTORIZATION OF a, AS 
!   COMPUTED BY qr_cmp. m>=n OR n>m IS PERMITTED, BUT a IS ASSUMED OF FULL RANK.
!
!   b IS A m RIGHT HAND SIDE VECTOR AND x IS A n SOLUTION VECTOR. SEVERAL RIGHT
!   HAND SIDES AND SOLUTION VECTORS MAY BE HANDLE IN A SINGLE CALL. IN THIS CASE,
!   b IS AN m-BY-l MATRIX AND x is AN n-BY-l MATRIX.
!   
!   IT IS ASSUMED THAT qr_cmp  HAS BEEN USED TO COMPUTE THE ORTHOGONAL 
!   FACTORIZATION OF a BEFORE CALLING qr_solve.
!
!   ON EXIT, IF comp_resid IS PRESENT AND IS EQUAL true,
!   THE RESIDUAL VECTOR b - a*x OVERWRITES b.
!
!   THE 2-NORM OF THE RESIDUAL VECTOR FOR THE SOLUTION VECTOR x, CAN ALSO BE COMPUTED
!   DIRECTLY BY SPECIFYING THE OPTIONAL REAL PARAMETER rnorm IN THE CALL OF qr_solve .
!
!   CHECK THAT THE RESIDUALS ARE ORTHOGONAL TO THE COLUMN VECTORS OF a .
!
    err = sum( abs( matmul( b, a ) ) )/ sum( abs(a) )
!
!   PRINT THE RESULT OF THE TEST.
!
    if ( err<=sqrt(epsilon(err)) ) then
        write (prtunit,*) 'Example 2 of QR_CMP is correct'
    else
        write (prtunit,*) 'Example 2 of QR_CMP is incorrect'
    end if
!
!
! END OF PROGRAM ex2_qr_cmp
! =========================
!
end program ex2_qr_cmp

ex2_qr_cmp2.F90

program ex2_qr_cmp2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines QR_CMP2 and QR_SOLVE2
!   in modules QR_Procedures and LLSQ_Procedures .
!                                                                              
! LATEST REVISION : 06/07/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, true, qr_cmp2, qr_solve2
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, m=1000, n=500
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                 :: err, tol
    real(stnd), dimension(m,n) :: a, a2
    real(stnd), dimension(n)   :: x, diagr, beta
    real(stnd), dimension(m)   :: b
!
    integer(i4b)               :: krank
    integer(i4b), dimension(n) :: ip
!
    character(len=*), parameter :: name_proc='Example 2 of qr_cmp2'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A RANDOM COEFFICIENT MATRIX a .
!
    call random_number( a )
!
!   GENERATE A DEFICIENT COEFFICIENT MATRIX a(:m,:n) .
!
    a(:m,5) = a(:m,10) + a(:m,11)
!
!   GENERATE A RANDOM RIGHT HAND-SIDE VECTOR b .
!
    call random_number( b )
!
!   MAKE A COPY OF COEFFICIENT MATRIX a(:m,:n) .
!
    a2(:m,:n) = a(:m,:n)
!
!   EXAMPLE 2 : LINEAR LEAST SQUARES SYSTEM.
!
!   COMPUTE SOLUTION VECTOR FOR LINEAR LEAST SQUARES SYSTEM
!
!           a(:m,:n)*x(:n)=b(:m) .
!
!
!   SET TOLERANCE .
!
    tol = 0.00001_stnd
!
    krank = 0
!
!   COMPUTE QR DECOMPOSITION WITH COLUMN PIVOTING OF RANDOM DATA MATRIX a .
!
    call qr_cmp2( a2(:m,:n), diagr(:n), beta(:n), ip(:n), krank, tol=tol )
!
!   qr_cmp2 COMPUTES A (COMPLETE) ORTHOGONAL FACTORIZATION OF A REAL m-BY-n MATRIX
!   a . a MAY BE RANK-DEFICIENT. THE ROUTINE FIRST COMPUTES A QR FACTORIZATION
!   WITH COLUMN PIVOTING OF a :
!
!                     a * p = q * r = q * [ r11 r12 ]
!                                         [  0  r22 ]
!
!   WITH r11 DEFINED AS THE LARGEST LEADING SUBMATRIX WHOSE ESTIMATED CONDITION
!   NUMBER, IN THE 1-NORM, IS LESS THAN 1/tol OR SUCH THAT ABS(r11[j,j])>0 IF 
!   tol IS ABSENT. THE ORDER OF r11, krank, IS THE EFFECTIVE RANK OF a. 
!
!   ON INPUT, krank=k, IMPLIES THAT THE FIRST k COLUMNS OF A ARE
!   TO BE FORCED INTO THE BASIS. PIVOTING IS PERFORMED ON THE LAST n-k
!   COLUMNS OF a.
!   WHEN krank>=min(m,n) IS USED, PIVOTING IS NOT PERFORMED. THIS IS
!   APPROPRIATE WHEN a IS KNOWN TO BE FULL RANK. krank<=0 CAN BE USED
!   WHEN PIVOTING IS DESIRED ON ALL COLUMNS OF a.
!   
!   IF THE OPTIONAL PARAMETER tau IS PRESENT, THEN r22 IS CONSIDERED TO BE NEGLIGIBLE
!   AND r12 IS ANNIHILATED BY ORTHOGONAL TRANSFORMATIONS FROM THE RIGHT,
!   ARRIVING AT THE COMPLETE ORTHOGONAL FACTORIZATION:
!  
!                     a * p = q * [ t11 0 ] * z
!                                 [  0  0 ]
!   
!   p IS A n-BY-n PERMUTATION MATRIX, q IS A m-BY-m ORTHOGONAL MATRIX,
!   r IS A m-BY-n UPPER TRIANGULAR MATRIX, t11 IS A krank-BY-krank UPPER
!   TRIANGULAR MATRIX AND z IS A n-BY-n ORTHOGONAL MATRIX.
!
!   ON EXIT, a HAS BEEN OVERWRITTEN BY DETAILS OF ITS (COMPLETE) 
!   ORTHOGONAL FACTORIZATION. 
!
!   THE MATRIX q IS REPRESENTED AS A PRODUCT OF ELEMENTARY REFLECTORS
!
!            q = h(1)*h(2)* ... *h(k), WHERE k = min( size(a,1) , size(a,2) )
!
!   EACH h(i) HAS THE FORM
!
!            h(i) = I + BETA * ( V * V' ) ,
!                      
!   WHERE BETA IS A REAL SCALAR AND V IS A REAL M-ELEMENT VECTOR WITH V(1:i-1) = 0.
!   V(i:m) IS STORED ON EXIT IN a(i:m,i) AND BETA IN beta(i).
!                      
!   IF THE OPTIONAL PARAMETER tau IS ABSENT :         
!                      
!      qr_cmp2 COMPUTES ONLY A QR FACTORIZATION WITH COLUMN PIVOTING OF a.
!                      
!      THE ELEMENTS ABOVE THE DIAGONAL OF THE ARRAY a CONTAIN THE
!      CORRESPONDING ELEMENTS OF THE TRIANGULAR MATRIX r. THE ELEMENTS
!      OF THE DIAGONAL OF r ARE STORED IN THE ARRAY diagr. 
!
!      ON EXIT, IF ip(j)=k, THEN THE jTH COLUMN OF a*p WAS 
!      THE kTH COLUMN OF a. THE MATRIX p IS REPRESENTED IN THE ARRAY 
!      ip AS FOLLOWS: IF ip(j) = i THEN THE jTH COLUMN OF p IS 
!      THE iTH CANONICAL UNIT VECTOR.
!                      
!      ON EXIT, krank CONTAINS THE EFFECTIVE RANK OF a, I.E., THE ORDER OF
!      THE SUBMATRIX r11.
!                      
!   IF THE OPTIONAL PARAMETER tau IS PRESENT :         
!                      
!      qr_cmp2 COMPUTES A COMPLETE ORTHOGONAL FACTORIZATION OF a FROM THE QR 
!      FACTORIZATION WITH COLUMN PIVOTING OF a .
!                      
!      THE FACTORIZATION IS OBTAINED BY HOUSEHOLDER'S METHOD. THE kTH TRANSFORMATION
!      MATRIX, z(k), WHICH IS USED TO INTRODUCE ZEROS INTO THE kTH ROW OF r,
!      IS GIVEN IN THE FORM
!
!             z(k) = ( I    0  ),
!                    ( 0  T(k) )
!
!      WHERE
!
!             T(k) = I + TAU * ( U(k) * U(k)' ) , U(k) = (   1  )
!                                                        (   0  )
!                                                        ( L(k) )
!
!      TAU IS A SCALAR AND L(k) IS AN (n-krank) ELEMENT VECTOR. TAU and L(k) ARE CHOSEN
!      TO ANNIHILATE THE ELEMENTS OF THE kTH ROW OF r12.
!
!      ON EXIT, THE SCALAR TAU IS RETURNED IN THE kTH ELEMENT OF tau AND THE VECTOR U(K)
!      IN THE kTH ROW OF a, SUCH THAT THE ELEMENTS OF L(k) ARE IN a(k,krank+1:n).
!
!      THE z n-BY-n ORTHOGONAL MATRIX WHICH IS APPLIED FROM THE RIGHT TO R IS 
!      GIVEN BY THE PRODUCT
!
!             z = z(1) * z(2) * ... * z(krank)
!
!      ON EXIT, THE ELEMENTS ABOVE THE DIAGONAL OF THE ARRAY SECTION a(1:krank,1:krank)
!      CONTAIN THE CORRESPONDING ELEMENTS OF THE TRIANGULAR MATRIX t11. THE ELEMENTS OF
!      THE DIAGONAL OF t11 ARE STORED IN THE ARRAY SECTION diagr(1:krank).
!                      
!      ON EXIT, IF ip(j)=k, THEN THE jTH COLUMN OF a*p WAS 
!      THE kTH COLUMN OF a. THE MATRIX p IS REPRESENTED IN THE ARRAY 
!      ip AS FOLLOWS: IF ip(j) = i THEN THE jTH COLUMN OF p IS 
!      THE iTH CANONICAL UNIT VECTOR.
!                      
!      ON EXIT, krank CONTAINS THE EFFECTIVE RANK OF a, I.E., THE ORDER OF
!      THE SUBMATRIX t11.
!                      
!   IF tol IS PRESENT AND IS IN [0,1[, THEN :
!       ON ENTRY, THE CALCULATIONS TO DETERMINE THE CONDITION NUMBER OF a
!       ARE PERFORMED. THEN, tol IS USED TO DETERMINE THE EFFECTIVE RANK
!       OF a, WHICH IS DEFINED AS THE ORDER OF THE LARGEST LEADING
!       TRIANGULAR SUBMATRIX r11 IN THE QR FACTORIZATION WITH PIVOTING OF a,
!       WHOSE ESTIMATED CONDITION NUMBER IS LESS THAN 1/tol. IF tol=0 IS SPECIFIED
!       THE NUMERICAL RANK OF a IS DETERMINED.
!       ON EXIT, THE RECIPROCAL OF THE CONDITION NUMBER IS RETURNED IN tol.
!
!   IF tol IS NOT SPECIFIED OR IS OUTSIDE [0,1[ :
!       THE CALCULATIONS TO DETERMINE THE CONDITION NUMBER OF a ARE NOT
!       PERFORMED AND CRUDE TESTS ON r(j,j) ARE DONE TO DETERMINE
!       THE NUMERICAL RANK OF a.
!
!   IF IT IS POSSIBLE THAT a MAY NOT BE FULL RANK (I.E., CERTAIN COLUMNS OF a ARE
!   LINEAR COMBINATIONS OF OTHER COLUMNS), THEN THE LINEARLY DEPENDENT COLUMNS CAN
!   USUALLY BE DETERMINED BY USING krank=0  AND tol=RELATIVE PRECISION OF THE ELEMENTS
!   IN a. IF EACH ELEMENT IS CORRECT TO, SAY, 5 DIGITS THEN tol=0.00001 SHOULD
!   BE USED. ALSO, IT MAY BE HELPFUL TO SCALE THE COLUMNS OF a SO THAT ALL ELEMENTS 
!   ARE ABOUT THE SAME ORDER OF MAGNITUDE.
!
!
!   NOW, COMPUTE SOLUTION AND RESIDUAL VECTOR FOR LINEAR LEAST SQUARES SYSTEM
!
!             a(:m,:n)*x(:n)=b(:m) .
!
    call qr_solve2( a2(:m,:n), diagr(:n), beta(:n), ip(:n), krank, b(:m), x(:n),    &
                    comp_resid=true )
!
!   qr_solve2 SOLVES OVERDETERMINED OR UNDERDETERMINED REAL LINEAR SYSTEMS
!
!                               a*x = b          
!
!   WITH AN m-BY-n MATRIX a, USING A (COMPLETE) ORTHOGONAL FACTORIZATION OF a, AS 
!   COMPUTED BY qr_cmp2. m>=n OR n>m IS PERMITTED AND a MAY BE RANK-DEFICIENT.
!
!   b IS A m RIGHT HAND SIDE VECTOR AND x IS A n SOLUTION VECTOR. SEVERAL RIGHT
!   HAND SIDES AND SOLUTION VECTORS MAY BE HANDLE IN A SINGLE CALL. IN THIS CASE,
!   b IS AN m-BY-l MATRIX AND x is AN n-BY-l MATRIX.
!   
!   IT IS ASSUMED THAT qr_cmp2  HAS BEEN USED TO COMPUTE THE (COMPLETE) ORTHOGONAL 
!   FACTORIZATION OF a BEFORE qr_solve2.
!
!   ON EXIT, IF comp_resid IS PRESENT AND IS EQUAL TO true,
!   THE RESIDUAL VECTOR b - a*x OVERWRITES b.
!
!   THE 2-NORM OF THE RESIDUAL VECTOR FOR THE SOLUTION VECTOR x, CAN ALSO BE COMPUTED
!   DIRECTLY BY SPECIFYING THE OPTIONAL REAL PARAMETER rnorm IN THE CALL OF qr_solve2 .
!
!   THE MINIMUN 2-NORM SOLUTION IS COMPUTED IF THE OPTIONAL PARAMETER tau IS PRESENT.
!   OTHERWISE, A SOLUTION IS COMPUTED SUCH THAT IF THE jTH COLUMN OF a
!   IS OMITTED FROM THE BASIS, x[j] IS SET TO ZERO.
!
!
!   CHECK THAT THE RESIDUALS ARE ORTHOGONAL TO THE COLUMN VECTORS OF a .
!
    err = sum( abs( matmul( b, a ) ) )/ sum( abs(a) )
!
!   PRINT THE RESULT OF THE TEST.
!
    if ( err<=sqrt(epsilon(err)) ) then
        write (prtunit,*) 'Example 2 of QR_CMP2 is correct'
    else
        write (prtunit,*) 'Example 2 of QR_CMP2 is incorrect'
    end if
!
!
!
! END OF PROGRAM ex2_qr_cmp2
! ==========================
!
end program ex2_qr_cmp2

ex2_select_eigval_cmp.F90

program ex2_select_eigval_cmp
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SELECT_EIGVAL_CMP
!   in module Eig_Procedures.
!                                                                              
! LATEST REVISION : 20/01/2020
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, triangle, select_eigval_cmp, trid_inviter, &
                         merror, allocate_error, norm, 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 MATRIX AND
! m IS THE NUMBER OF THE COMPUTED EIGENVALUES/EIGENVECTORS
!
    integer(i4b), parameter :: prtunit=6, n=1000, p=n*(n+1)/2, m=10
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of select_eigval_cmp'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, eps, elapsed_time
    real(stnd), dimension(:),   allocatable :: d, res2, vec
    real(stnd), dimension(:,:), allocatable :: a, res, eigvec, d_e
!
    integer(i4b) :: maxiter=2
    integer      :: iok, istart, iend, irate, imax, itime
!
    logical(lgl) :: failure, failure2, do_test, small, upper=true
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : PARTIAL EIGENVALUES/EIGENVECTORS DECOMPOSITION OF A n-BY-n REAL
!               SYMMETRIC MATRIX IN PACKED FORM USING A RATIONAL QR ALGORITHM FOR THE EIGENVALUES
!               AND THE INVERSE ITERATION TECHNIQUE FOR THE EIGENVECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
!
    err = zero
    do_test = true
!
!   DETERMINE IF YOU WANT TO COMPUTE THE m SMALLEST OR LARGEST EIGENVALUES.
!
    small = false
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), vec(p), eigvec(n,m), d(m), d_e(n,2), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM DATA MATRIX AND FROM IT
!   A SELF-ADJOINT MATRIX a .
!
    call random_number( a )
    a = a + transpose( a ) 
!
!   MAKE A COPY OF THE UPPER TRIANGLE OF SELF-ADJOINT MATRIX IN PACKED FORM.
!
    vec(:p) = pack( a, mask=triangle( upper, n, n, extra=1_i4b) )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   COMPUTE THE FIRST m EIGENVALUES OF THE SELF-ADJOINT MATRIX a (IN
!   PACKED FORM) AND SAVE THE INTERMEDIATE TRIDIAGONAL MATRIX IN PARAMETER d_e .
!
    if ( upper ) then
!
!       USE A FAST ALGORITHM.
!
        call select_eigval_cmp( vec(:p), d(:m), small, failure, d_e=d_e )
!
    else
!
!       USE A SLOW ALGORITHM.
!
        call select_eigval_cmp( vec(:p), d(:m), small, failure, upper=upper, d_e=d_e )
!
    end if
!
    if ( .not. failure ) then
!
!       COMPUTE THE ASSOCIATED m EIGENVECTORS OF THE SELF-ADJOINT MATRIX a BY
!       maxiter INVERSE ITERATIONS ON THE INTERMEDIATE TRIDIAGONAL MATRIX
!       d_e AND BACK-TRANSFORMATION.
!
        call trid_inviter( d_e(:n,1), d_e(:n,2), d(:m), eigvec(:n,:m), failure2,     &
                           matp=vec(:p), maxiter=maxiter )
!
    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 ( do_test .and. .not.failure ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( res(n,m), res2(m), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*eigvec - eigvec*d
!       WHERE d ARE THE EIGENVALUES AND eigvec THE EIGENVECTORS OF a.
!
        res(:n,:m) = matmul( a(:n,:n), eigvec(:n,:m)) - eigvec(:n,:m)*spread( d(:m), dim=1, ncopies=n)
        res2(:m) = norm( res(:n,:m), dim=2_i4b )
!
        err1 = maxval( res2(:m) )/( norm( a )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - eigvec**(t)*eigvec.
!
        call unit_matrix( a(:m,:m) )
!
        res(:m,:m) = abs( a(:m,:m) - matmul( transpose(eigvec(:n,:m)), eigvec(:n,:m) ) )
!
        err2 = maxval( res(:m,:m) )/real(n,stnd)
!
        err = max( err1, err2 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( res, res2 )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, vec, eigvec, d_e, d )
!
    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
!
    if ( do_test  .and. .not.failure ) then
        write (prtunit,*) 
        write (prtunit,*) 'Accuracy of the computed eigenvalues/eigenvectors couplets = ', err1
        write (prtunit,*) 'Orthogonality of the computed eigenvectors                 = ', err2
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', m, ' eigenvalues and eigenvectors of a ', &
       n, ' by ', n,' real symmetric matrix in packed form is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_select_eigval_cmp
! ====================================
!
end program ex2_select_eigval_cmp

ex2_select_eigval_cmp2.F90

program ex2_select_eigval_cmp2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SELECT_EIGVAL_CMP2
!   in module Eig_Procedures.
!                                                                              
! LATEST REVISION : 20/01/2020
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, four, c50, allocate_error,    &
                         triangle, merror, get_diag, select_eigval_cmp2, trid_inviter,    &
                         norm, 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 MATRIX 
!
    integer(i4b), parameter :: prtunit=6, n=1000, p=n*(n+1)/2
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of select_eigval_cmp2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, eps, val, elapsed_time
    real(stnd), dimension(:),   pointer     :: d
    real(stnd), dimension(:),   allocatable :: res2, vec
    real(stnd), dimension(:,:), allocatable :: a, res, eigvec, d_e
!
    integer(i4b) :: m, maxiter=4
    integer      :: iok, istart, iend, irate, imax, itime
!
    logical(lgl) :: failure, failure2, do_test, small, upper=true
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : PARTIAL EIGENVALUES/EIGENVECTORS DECOMPOSITION OF A n-BY-n REAL
!               SYMMETRIC MATRIX IN PACKED FORM USING A RATIONAL QR ALGORITHM FOR THE EIGENVALUES
!               AND THE INVERSE ITERATION TECHNIQUE FOR THE EIGENVECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
!
    err = zero
    do_test = true
!
!   DETERMINE IF YOU WANT TO COMPUTE THE m SMALLEST OR LARGEST EIGENVALUES.
!
    small = false
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), vec(p), d_e(n,2), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM DATA MATRIX AND FROM IT
!   A SEMI-POSITIVE MATRIX a .
!
    call random_number( a )
    a = matmul( a, transpose( a ) )
!
!   DETERMINE TRESHOLD FOR THE SUM OF THE EIGENVALUES.
!
    val = sum( get_diag(a) )/four
!
!   MAKE A COPY OF THE UPPER TRIANGLE OF SELF-ADJOINT MATRIX IN PACKED FORM.
!
    vec(:p) = pack( a, mask=triangle( upper, n, n, extra=1_i4b) )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   COMPUTE THE LARGEST m EIGENVALUES OF THE SELF-ADJOINT MATRIX a (IN PACKED FORM)
!   IN ALEBRAIC VALUE WHOSE SUM EXCEEDS val AND SAVE THE INTERMEDIATE TRIDIAGONAL
!   MATRIX IN PARAMETER d_e .
!
    if ( upper ) then
!
!       USE A FAST ALGORITHM.
!
        call select_eigval_cmp2( vec, d, small, val, failure, d_e=d_e )
!
    else
!
!       USE A SLOW ALGORITHM.
!
        call select_eigval_cmp2( vec, d, small, val, failure, upper=upper, d_e=d_e )
!
    end if
!
!   DETERMINE THE NUMBER OF EIGENVALUES AND ALLOCATE WORK ARRAY FOR
!   COMPUTING THE ASSOCIATED EIGENVECTORS.
!
    m = size( d )
!
    allocate( eigvec(n,m), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
    if ( .not. failure ) then
!
!       COMPUTE THE ASSOCIATED m EIGENVECTORS OF THE SELF-ADJOINT MATRIX a BY
!       maxiter INVERSE ITERATIONS ON THE INTERMEDIATE TRIDIAGONAL MATRIX
!       d_e AND BACK-TRANSFORMATION.
!
        call trid_inviter( d_e(:n,1), d_e(:n,2), d(:m), eigvec(:n,:m), failure2,     &
                           matp=vec(:p), maxiter=maxiter )
!
    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 ( do_test .and. .not.failure ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( res(n,m), res2(m), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*eigvec - eigvec*d
!       WHERE d ARE THE EIGENVALUES AND eigvec THE EIGENVECTORS OF a.
!
        res(:n,:m) = matmul( a(:n,:n), eigvec(:n,:m)) - eigvec(:n,:m)*spread( d(:m), dim=1, ncopies=n)
        res2(:m) = norm( res(:n,:m), dim=2_i4b )
!
        err1 = maxval( res2(:m) )/( norm( a )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - eigvec**(t)*eigvec.
!
        call unit_matrix( a(:m,:m) )
!
        res(:m,:m) = abs( a(:m,:m) - matmul( transpose(eigvec(:n,:m)), eigvec(:n,:m) ) )
!
        err2 = maxval( res(:m,:m) )/real(n,stnd)
!
        err = max( err1, err2 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( res, res2 )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, vec, eigvec, d_e, d )
!
    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
!
    if ( do_test  .and. .not.failure ) then
        write (prtunit,*) 
        write (prtunit,*) 'Accuracy of the computed eigenvalues/eigenvectors couplets = ', err1
        write (prtunit,*) 'Orthogonality of the computed eigenvectors                 = ', err2
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', m, ' eigenvalues and eigenvectors of a ', &
       n, ' by ', n,' real symmetric matrix in packed form is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_select_eigval_cmp2
! =====================================
!
end program ex2_select_eigval_cmp2

ex2_select_eigval_cmp3.F90

program ex2_select_eigval_cmp3
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SELECT_EIGVAL_CMP3
!   in module Eig_Procedures.
!                                                                              
! LATEST REVISION : 20/01/2020
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, triangle, select_eigval_cmp3,  &
                         trid_inviter, merror, allocate_error, norm, 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 MATRIX AND
! le IS THE NUMBER OF THE WANTED EIGENVALUES/EIGENVECTORS
!
    integer(i4b), parameter :: prtunit=6, n=1000, p=n*(n+1)/2, le=10
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of select_eigval_cmp3'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, eps, elapsed_time
    real(stnd), dimension(:),   allocatable :: eigval, res2, vec
    real(stnd), dimension(:,:), allocatable :: a, res, eigvec, d_e
!
    integer(i4b) :: maxiter=4, neig
    integer      :: iok, istart, iend, irate, imax, itime
!
    logical(lgl)     :: failure, failure2, do_test, small, upper=true
!   
    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 : PARTIAL EIGENVALUES/EIGENVECTORS DECOMPOSITION OF A n-BY-n REAL
!               SYMMETRIC MATRIX IN PACKED FORM USING A BISECTION ALGORITHM FOR THE EIGENVALUES
!               AND THE INVERSE ITERATION TECHNIQUE FOR THE EIGENVECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
!
    err = zero
    do_test = true
!
!   DETERMINE IF YOU WANT TO COMPUTE THE m SMALLEST OR LARGEST EIGENVALUES.
!
    small = false
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), vec(p), eigval(n), d_e(n,2), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A RANDOM DATA MATRIX AND FROM IT
!   A SELF-ADJOINT MATRIX a .
!
    call random_number( a )
    a = a + transpose( a ) 
!
!   MAKE A COPY OF THE UPPER TRIANGLE OF SELF-ADJOINT MATRIX IN PACKED FORM.
!
    vec(:p) = pack( a, mask=triangle( upper, n, n, extra=1_i4b) )
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   COMPUTE THE FIRST m EIGENVALUES OF THE SELF-ADJOINT MATRIX a (IN
!   PACKED FORM) AND SAVE THE INTERMEDIATE TRIDIAGONAL MATRIX IN PARAMETER d_e .
!
    if ( upper ) then
!
!       USE A FAST ALGORITHM.
!
        call select_eigval_cmp3( vec(:p), neig, eigval, small, failure, sort=sort, le=le, d_e=d_e )
!
    else
!
!       USE A SLOW ALGORITHM.
!
        call select_eigval_cmp3( vec(:p), neig, eigval, small, failure, upper=upper, sort=sort, le=le, d_e=d_e )
!
    end if
!
    if ( .not. failure .and. neig>0  ) then
!
!       ALLOCATE WORK ARRAY NEEDED TO STORE THE EIGENVECTORS.
!
        allocate( eigvec(n,neig), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE THE ASSOCIATED neig EIGENVECTORS OF THE SELF-ADJOINT MATRIX a BY
!       maxiter INVERSE ITERATIONS ON THE INTERMEDIATE TRIDIAGONAL MATRIX
!       d_e AND BACK-TRANSFORMATION.
!
        call trid_inviter( d_e(:n,1), d_e(:n,2), eigval(:neig), eigvec(:n,:neig), failure2,     &
                           matp=vec(:p), maxiter=maxiter )
!
    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 ( do_test .and. .not.failure .and. neig>0 ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( res(n,neig), res2(neig), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*eigvec - eigvec*d
!       WHERE d ARE THE EIGENVALUES AND eigvec THE EIGENVECTORS OF a.
!
        res(:n,:neig) = matmul( a(:n,:n), eigvec(:n,:neig)) - eigvec(:n,:neig)*spread( eigval(:neig), dim=1, ncopies=n)
        res2(:neig) = norm( res(:n,:neig), dim=2_i4b )
!
        err1 = maxval( res2(:neig) )/( norm( a )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - eigvec**(t)*eigvec.
!
        call unit_matrix( a(:neig,:neig) )
!
        res(:neig,:neig) = abs( a(:neig,:neig) - matmul( transpose(eigvec(:n,:neig)), eigvec(:n,:neig) ) )
!
        err2 = maxval( res(:neig,:neig) )/real(n,stnd)
!
        err = max( err1, err2 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( res, res2 )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, vec, d_e, eigval )
!
    if ( allocated( eigvec ) )  deallocate( eigvec )
!
    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
!
    if ( do_test  .and. .not.failure .and. neig>0 ) then
        write (prtunit,*) 
        write (prtunit,*) 'Accuracy of the computed eigenvalues/eigenvectors couplets = ', err1
        write (prtunit,*) 'Orthogonality of the computed eigenvectors                 = ', err2
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', neig, ' eigenvalues and eigenvectors of a ', &
       n, ' by ', n,' real symmetric matrix in packed form is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_select_eigval_cmp3
! =====================================
!
end program ex2_select_eigval_cmp3

ex2_select_singval_cmp.F90

program ex2_select_singval_cmp
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SELECT_SINGVAL_CMP
!   in module SVD_Procedures.
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine BD_DEFLATE2 in module SVD_Procedures.
!                                                                              
! LATEST REVISION : 25/10/2019
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c0_9, c1_5, c50, lamch, bd_deflate2,   &
                         select_singval_cmp, merror, allocate_error, norm, 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
!
    integer(i4b), parameter :: prtunit=6, n=3000, m=3000, mn=min(m,n), ls=100
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of select_singval_cmp'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, err3, eps, abstol, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, a2, leftvec, rightvec, resid, rla
    real(stnd), dimension(:),   allocatable :: s, d, e, tauo, tauq, taup, resid2
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: max_qr_steps, nsing, mnthr, mnthr_nsing
!
    logical(lgl) :: failure1, failure2, ortho, gen_q, do_test, two_stage
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 2 : PARTIAL SVD OF A n-BY-m REAL MATRIX USING THE CHAN-GOLUB-REINSCH
!               BIDIAGONAL REDUCTION ALGORITHM, A BISECTION ALGORITHM FOR
!               SINGULAR VALUES AND THE GODUNOV DEFLATION TECHNIQUE FOR
!               SINGULAR VECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps    = fudge*epsilon( err )
    abstol = sqrt( lamch('S') )
    err    = zero
!
!   SPECIFY IF NUMERICAL TESTS ARE PERFORMED.
!
    do_test = true
!
!   CHOOSE TUNING PARAMETERS FOR THE ALGORITHM.
!
!   DETERMINE CROSSOVER POINT FOR THE SVD WHEN REDUCING
!   a TO BIDIAGONAL FORM. IF max(n,m) EXCEEDS mnthr ,
!   A QR OR LQ FACTORIZATION IS USED FIRST TO REDUCE THE
!   n-BY-m MATRIX a TO A TRIANGULAR FORM.
!    
    mnthr = int( real( mn, stnd )*c1_5, i4b )
!
    two_stage = max( n, m )>=mnthr
!    two_stage = true
!    two_stage = false
!
!   DETERMINE CROSSOVER POINT FOR THE BACK-TRANSFORMATION
!   ALGORITHM WHEN COMPUTING SINGULAR VECTORS. IF max(n,m)
!   EXCEEDS mnthr (E.G. A PRELIMINARY QR OR QL IS DONE) AND ls
!   EXCEEDS mnthr_nsing, THE ORTHOGONAL MATRIX q OF THE QR OR
!   QL FACTORIZATION IS GENERATED AND THE SINGULAR VECTORS
!   ARE COMPUTED BY A MATRIX MULTIPLICATION.
!
    mnthr_nsing = int( real( mn, stnd )*c0_9, i4b )
!
    gen_q = ls>=mnthr_nsing .and. two_stage
!    gen_q = true
!    gen_q = false
!
!   ALLOCATE WORK ARRAYS.
!
    if ( two_stage ) then
        if ( gen_q ) then
            allocate( a(n,m), rla(mn,mn), s(mn), d(mn), e(mn), &
                      tauq(mn), taup(mn), stat=iok )
        else
            allocate( a(n,m), rla(mn,mn), s(mn), d(mn), e(mn), &
                      tauo(mn), tauq(mn), taup(mn), stat=iok )
        end if
    else
        allocate( a(n,m), s(mn), d(mn), e(mn), tauq(mn), &
                  taup(mn), stat=iok )
    end if
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-BY-m RANDOM REAL MATRIX a.
!
    call random_number( a )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( a2(n,m), resid(n,mn), resid2(mn), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       MAKE A COPY OF THE RANDOM DATA MATRIX .
!
        a2(:n,:m) = a(:n,:m)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL n-BY-m MATRIX a
!   IS WRITTEN
!
!                       a = U * S * V**(t)
!
!   WHERE S IS AN n-BY-m MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   min(m,n) DIAGONAL ELEMENTS, U IS AN n-BY-n ORTHOGONAL MATRIX, AND
!   V IS AN m-BY-m 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.
!
!   THIS PROGRAM ILLUSTRATES HOW TO COMPUTE THE ls LARGEST SINGULAR VALUES OF a AND THE
!   ASSOCIATED LEFT AND RIGHT SINGULAR VECTORS OF a (EG A PARTIAL SVD DECOMPOSITION OF a)
!   IN TWO STEPS:
!
!   STEP1 : COMPUTE THE ls LARGEST SINGULAR VALUES OF a BY THE GOLUB AND REINSCH
!   BIDIAGONAL REDUCTION ALGORITHM APPLIED TO a, A BISECTION METHOD APPLIED TO THE
!   GOLUB-KAHAN TRIDIAGONAL FORM OF THE RESULTING BIDIAGONAL MATRIX AND STORE INTERMEDIATE
!   RESULTS WITH SUBROUTINE select_singval_cmp.
!
!   THE OPTIONAL ARGUMENT ls OF select_singval_cmp MAY BE USED TO DETERMINE HOW MANY
!   SINGULAR VALUES MUST BE COMPUTED.
!
!   THE OPTIONAL ARGUMENT abstol OF select_singval_cmp MAY BE USED TO SET THE REQUIRED
!   PRECISION FOR THE SINGULAR VALUES. A SINGULAR VALUE IS CONSIDERED TO BE LOCATED
!   IF IT HAS BEEN DETERMINED TO LIE IN AN INTERVAL WHOSE WIDTH IS EQUAL OR LESS
!   THAN abstol. SINGULAR VALUES WILL BE COMPUTED MOST ACCURATELY WHEN abstol IS SET
!   TO THE SQUARE ROOT OF THE UNDERFLOW THRESHOLD (EG sqrt(LAMCH('S')) ).
!
    if ( two_stage ) then
!
!       STEP1A : REDUCE THE MATRIX a TO BIDIAGONAL FORM BY A TWO-STAGE ALGORITHM.
!       THE MATRIX a IS FIRST REDUCED TO TRIANGULAR FORM BY A QR OR LQ FACTORIZATION
!       IN A FIRST STAGE. THE TRIANGULAR MATRIX IS REDUCED TO BIDIAGONAL FORM IN A
!       SECOND STAGE.
!       THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!       THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM IN THE TWO-STAGE 
!       ALGORITHM ARE STORED IN a, rla, tauo, tauq AND taup.
!
        if ( gen_q ) then
!
            call select_singval_cmp( a, rla, nsing, s, failure=failure1, sort=sort, d=d, e=e, &
                                     ls=ls, abstol=abstol, tauq=tauq, taup=taup )
!
        else
!
            call select_singval_cmp( a, rla, nsing, s, failure=failure1, sort=sort, d=d, e=e, &
                                     ls=ls, abstol=abstol, tauo=tauo, tauq=tauq, taup=taup )
!
        end if
!
    else
!
!       STEP1B : REDUCE THE MATRIX a TO BIDIAGONAL FORM WITHOUT A QR OR LQ FACTORIZATION.
!       THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!       THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM
!       ARE STORED IN a, tauq, taup.
!
        call select_singval_cmp( a, nsing, s, failure=failure1, sort=sort, d=d, e=e, &
                                 ls=ls, abstol=abstol, tauq=tauq, taup=taup )
!
    end if
!
!   ON EXIT OF select_singval_cmp :
!
!   failure= false :  INDICATES SUCCESSFUL EXIT
!   failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                     THAT FULL ACCURACY WAS NOT ATTAINED IN THE
!                     COMPUTATION OF THE SINGULAR VALUES OF a.
!
!   THE SINGULAR VALUES ARE STORED IN s IN DECREASING ORDER (IF sort='d').
!
!   THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!   THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM d_e
!   ARE STORED IN PACKED FORM IN a, tauq, taup AND ALSO rla AND tauo IF A
!   TWO-STAGE ALGORITHM HAS BEEN USED.
!
!   nsing GIVES THE NUMBER OF SINGULAR VALUES REALLY COMPUTED BY select_singval_cmp.
!   nsing MAY BE GREATER THAN ls IF CLUSTERS OF SINGULAR VALUES ARE PRESENT.
!   THE nsing LARGEST SINGULAR VALUES ARE STORED IN THE FIRST nsing POSITIONS OF s
!   IN DECREASING ORDER IF sort='d'.
!
!   STEP2 : COMPUTE nsing LEFT AND RIGHT SINGULAR VECTORS OF a BY A DEFLATION TECHNIQUE
!   APPLIED TO THE INTERMEDIATE BIDIAGONAL MATRIX AND BACK-TRANSFORMATION WITH SUBROUTINE
!   bd_deflate2.
!
    if ( nsing>0 ) then
!
!       ALLOCATE WORK VARIABLES NEEDED TO STORE THE SINGULAR VECTORS.
!
        allocate( leftvec(n,nsing),    &
                  rightvec(m,nsing),   &
                  stat = iok    )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE THE FIRST nsing LEFT AND RIGHT SINGULAR VECTORS OF a BY 
!       A DEFLATION TECHNIQUE APPLIED ON THE INTERMEDIATE BIDIAGONAL MATRIX
!       d_e AND BACK-TRANSFORMATION WITH SUBROUTINE bd_deflate2 .
!
!       ON ENTRY OF bd_deflate2: PARAMETER s CONTAINS SELECTED SINGULAR VALUES OF THE BIDIAGONAL
!       MATRIX (OR OF a). THE SINGULAR VALUES MUST BE GIVEN IN DECREASING ORDER.
!
!       OPTIONAL PARAMETER ortho DETERMINES IF DEFLATION IS APPLIED SEQUENTIALLY TO ALL
!       COMPUTED SINGULAR VECTORS (ortho=true) OR ONLY IN EACH CLUSTER OF SINGULAR VALUES
!       (ortho=false). IN THE LATTER CASE, ORTHOGONALITY OF THE SINGULAR VECTORS MAY BE
!       SLIGHTLY DEGRADED, BUT COMPUTATIONS WILL BE MUCH FASTER.
!
        ortho = false
        max_qr_steps = 4_i4b
!
        if ( two_stage ) then
!
            if ( gen_q ) then
!
                call bd_deflate2( a(:n,:m), tauq(:mn), taup(:mn), rla(:mn,:mn), &
                                  d(:mn), e(:mn), s(:nsing),                    &
                                  leftvec(:n,:nsing), rightvec(:m,:nsing),      &
                                  failure=failure2, ortho=ortho,                &
                                  max_qr_steps=max_qr_steps                     )
!
            else
!
                call bd_deflate2( a(:n,:m), tauq(:mn), taup(:mn), rla(:mn,:mn), &
                                  d(:mn), e(:mn), s(:nsing),                    &
                                  leftvec(:n,:nsing), rightvec(:m,:nsing),      &
                                  failure=failure2, tauo=tauo(:mn),             &
                                  ortho=ortho, max_qr_steps=max_qr_steps        )
!
            end if
!
        else
!
            call bd_deflate2( a(:n,:m), tauq(:mn), taup(:mn), d(:mn), e(:mn), s(:nsing),   &
                              leftvec(:n,:nsing), rightvec(:m,:nsing), failure=failure2,   &
                              ortho=ortho, max_qr_steps=max_qr_steps                       )
!
        end if
!
!       ON EXIT OF bd_deflate2 :
!
!           failure= false :  INDICATES SUCCESSFUL EXIT.
!           failure= true  :  INDICATES THAT MAXIMUM ACCURACY WAS NOT OBTAIN IN THE
!                             DEFLATION ALGORITHM.

!           leftvec AND rightvec CONTAIN, RESPECTIVELY, THE FIRST nsing LEFT AND RIGHT
!           SINGULAR VECTORS OF a .
!
!       bd_deflate2 MAY FAIL IF SOME THE SINGULAR VALUES SPECIFIED IN PARAMETER s ARE NEARLY
!       IDENTICAL FOR SOME PATHOLOGICAL MATRICES.
!
    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 ( do_test .and. nsing>0 ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*v(:m,:nsing) - u(:n,:nsing)*s(:nsing,:nsing),
!       WHERE u AND v ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a.
!
        resid(:n,:nsing) = matmul(a2,rightvec) - leftvec*spread(s(:nsing),dim=1,ncopies=n)
        resid2(:nsing) = norm( resid(:n,:nsing), dim=2_i4b )
!
        err1 = maxval( resid2(:nsing) )/( norm( a2 )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u(:n,:nsing)**(t)*u(:n,:nsing).
!
        call unit_matrix( a2(:nsing,:nsing) )
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(leftvec), leftvec ) )
!
        err2 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - v(:m,:nsing)**(t)*v(:m,:nsing).
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(rightvec), rightvec ) )
!
        err3 = maxval( resid(:nsing,:nsing) )/real(m,stnd)
!
        err = max( err1, err2, err3 )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( do_test ) then
!
        deallocate( a2, resid, resid2 )
!
    end if
!
    if ( nsing>0 ) then
!
        deallocate( a, s, d, e, tauq, taup, leftvec, rightvec )
!
    else
!
        deallocate( a, s, d, e, tauq, taup )
!
    end if
!
    if ( two_stage ) then
!
        if ( gen_q ) then
            deallocate( rla )
        else
            deallocate( rla, tauo )
        end if
!
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. .not.failure1 .and. .not.failure2 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test .and. nsing>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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', nsing, ' singular values and vectors of a ', &
       n, ' by ', m,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_select_singval_cmp
! =====================================
!
end program ex2_select_singval_cmp

ex2_select_singval_cmp2.F90

program ex2_select_singval_cmp2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SELECT_SINGVAL_CMP2
!   in module SVD_Procedures.
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine BD_DEFLATE2 in module SVD_Procedures.
!                                                                              
! LATEST REVISION : 25/10/2019
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c0_9, c1_5, c50, lamch, bd_deflate2,   &
                         select_singval_cmp2, merror, allocate_error, norm, 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
!
    integer(i4b), parameter :: prtunit=6, n=6000, m=4000, mn=min(m,n), ls=100
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of select_singval_cmp2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, err3, eps, abstol, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, a2, leftvec, rightvec, resid, rla
    real(stnd), dimension(:),   allocatable :: s, d, e, tauo, tauq, taup, resid2
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: max_qr_steps, nsing, mnthr, mnthr_nsing
!
    logical(lgl) :: failure1, failure2, gen_q, ortho, do_test, two_stage
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 2 : PARTIAL SVD OF A n-BY-m REAL MATRIX USING THE CHAN-GOLUB-REINSCH
!               BIDIAGONAL REDUCTION ALGORITHM, A BISECTION ALGORITHM FOR
!               SINGULAR VALUES AND THE GODUNOV DEFLATION TECHNIQUE FOR
!               SINGULAR VECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps    = fudge*epsilon( err )
    abstol = sqrt( lamch('S') )
    err    = zero
!
!   SPECIFY IF NUMERICAL TESTS ARE PERFORMED.
!
    do_test = true
!
!   CHOOSE TUNING PARAMETERS FOR THE ALGORITHM.
!
!   DETERMINE CROSSOVER POINT FOR THE SVD WHEN REDUCING
!   a TO BIDIAGONAL FORM. IF max(n,m) EXCEEDS mnthr ,
!   A QR OR LQ FACTORIZATION IS USED FIRST TO REDUCE THE
!   n-BY-m MATRIX a TO A TRIANGULAR FORM.
!    
    mnthr = int( real( mn, stnd )*c1_5, i4b )
!
    two_stage = max( n, m )>=mnthr
!    two_stage = true
!    two_stage = false
!
!   DETERMINE CROSSOVER POINT FOR THE BACK-TRANSFORMATION
!   ALGORITHM WHEN COMPUTING SINGULAR VECTORS. IF max(n,m)
!   EXCEEDS mnthr (E.G. A PRELIMINARY QR OR QL IS DONE) AND ls
!   EXCEEDS mnthr_nsing, THE ORTHOGONAL MATRIX q OF THE QR OR
!   QL FACTORIZATION IS GENERATED AND THE SINGULAR VECTORS
!   ARE COMPUTED BY A MATRIX MULTIPLICATION.
!
    mnthr_nsing = int( real( mn, stnd )*c0_9, i4b )
!
    gen_q = ls>=mnthr_nsing .and. two_stage
!    gen_q = true
!    gen_q = false
!
!   ALLOCATE WORK ARRAYS.
!
    if ( two_stage ) then
        if ( gen_q ) then
            allocate( a(n,m), rla(mn,mn), s(mn), d(mn), e(mn), &
                      tauq(mn), taup(mn), stat=iok )
        else
            allocate( a(n,m), rla(mn,mn), s(mn), d(mn), e(mn), &
                      tauo(mn), tauq(mn), taup(mn), stat=iok )
        end if
    else
        allocate( a(n,m), s(mn), d(mn), e(mn), tauq(mn), &
                  taup(mn), stat=iok )
    end if
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-BY-m RANDOM REAL MATRIX a.
!
    call random_number( a )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( a2(n,m), resid(n,mn), resid2(mn), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       MAKE A COPY OF THE RANDOM DATA MATRIX .
!
        a2(:n,:m) = a(:n,:m)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL n-BY-m MATRIX a
!   IS WRITTEN
!
!                       a = U * S * V**(t)
!
!   WHERE S IS AN n-BY-m MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   min(m,n) DIAGONAL ELEMENTS, U IS AN n-BY-n ORTHOGONAL MATRIX, AND
!   V IS AN m-BY-m 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.
!
!   THIS PROGRAM ILLUSTRATES HOW TO COMPUTE THE ls LARGEST SINGULAR VALUES OF a AND THE
!   ASSOCIATED LEFT AND RIGHT SINGULAR VECTORS OF a (EG A PARTIAL SVD DECOMPOSITION OF a)
!   IN TWO STEPS:
!
!   STEP1 : COMPUTE THE ls LARGEST SINGULAR VALUES OF a BY THE GOLUB AND REINSCH
!   BIDIAGONAL REDUCTION ALGORITHM APPLIED TO a, A BISECTION METHOD APPLIED TO THE
!   RESULTING BIDIAGONAL MATRIX AND STORE INTERMEDIATE RESULTS WITH SUBROUTINE
!   select_singval_cmp2.
!
!   THE OPTIONAL ARGUMENT ls OF select_singval_cmp2 MAY BE USED TO DETERMINE HOW MANY
!   SINGULAR VALUES MUST BE COMPUTED.
!
!   THE OPTIONAL ARGUMENT abstol OF select_singval_cmp2 MAY BE USED TO SET THE REQUIRED
!   PRECISION FOR THE SINGULAR VALUES. A SINGULAR VALUE IS CONSIDERED TO BE LOCATED
!   IF IT HAS BEEN DETERMINED TO LIE IN AN INTERVAL WHOSE WIDTH IS EQUAL OR LESS
!   THAN abstol. SINGULAR VALUES WILL BE COMPUTED MOST ACCURATELY WHEN abstol IS SET
!   TO THE SQUARE ROOT OF THE UNDERFLOW THRESHOLD (EG sqrt(LAMCH('S')) ).
!
!   select_singval_cmp2 IS FASTER THAN select_singval_cmp, BUT MAY BE LESS ACCURATE FOR SOME
!   MATRICES.
!
    if ( two_stage ) then
!
!       STEP1A : REDUCE THE MATRIX a TO BIDIAGONAL FORM BY A TWO-STAGE ALGORITHM.
!       THE MATRIX a IS FIRST REDUCED TO TRIANGULAR FORM BY A QR OR LQ FACTORIZATION
!       IN A FIRST STAGE. THE TRIANGULAR MATRIX IS REDUCED TO BIDIAGONAL FORM IN A
!       SECOND STAGE.
!       THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!       THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM IN THE TWO-STAGE 
!       ALGORITHM ARE STORED IN a, rla, tauo, tauq AND taup.
!
        if ( gen_q ) then
!
            call select_singval_cmp2( a, rla, nsing, s, failure=failure1, sort=sort, d=d, e=e, &
                                      ls=ls, abstol=abstol, tauq=tauq, taup=taup )
!
        else
!
            call select_singval_cmp2( a, rla, nsing, s, failure=failure1, sort=sort, d=d, e=e, &
                                      ls=ls, abstol=abstol, tauo=tauo, tauq=tauq, taup=taup )
!
        end if
!
    else
!
!       STEP1B : REDUCE THE MATRIX a TO BIDIAGONAL FORM WITHOUT A QR OR LQ FACTORIZATION.
!       THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!       THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM
!       ARE STORED IN a, tauq, taup.
!
        call select_singval_cmp2( a, nsing, s, failure=failure1, sort=sort, d=d, e=e, &
                                  ls=ls, abstol=abstol, tauq=tauq, taup=taup )
!
    end if
!
!   ON EXIT OF select_singval_cmp2 :
!
!   failure= false :  INDICATES SUCCESSFUL EXIT
!   failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                      THAT FULL ACCURACY WAS NOT ATTAINED IN THE
!                      COMPUTATION OF THE SINGULAR VALUES OF a.
!
!   THE SINGULAR VALUES ARE STORED IN s IN DECREASING ORDER (IF sort='d').
!
!   THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!   THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM d_e
!   ARE STORED IN PACKED FORM IN a, tauq, taup AND ALSO rla AND tauo IF A
!   TWO-STAGE ALGORITHM HAS BEEN USED.
!
!   nsing GIVES THE NUMBER OF SINGULAR VALUES REALLY COMPUTED BY select_singval_cmp2.
!   nsing MAY BE GREATER THAN ls IF CLUSTERS OF SINGULAR VALUES ARE PRESENT.
!   THE nsing LARGEST SINGULAR VALUES ARE STORED IN THE FIRST nsing POSITIONS OF s
!   IN DECREASING ORDER IF sort='d'.
!
!   STEP2 : COMPUTE nsing LEFT AND RIGHT SINGULAR VECTORS OF a BY A DEFLATION TECHNIQUE
!   APPLIED TO THE INTERMEDIATE BIDIAGONAL MATRIX AND BACK-TRANSFORMATION WITH SUBROUTINE
!   bd_deflate2.
!
    if ( nsing>0 ) then
!
!       ALLOCATE WORK VARIABLES NEEDED TO STORE THE SINGULAR VECTORS.
!
        allocate( leftvec(n,nsing),    &
                  rightvec(m,nsing),   &
                  stat = iok    )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE THE FIRST nsing LEFT AND RIGHT SINGULAR VECTORS OF a BY 
!       A DEFLATION TECHNIQUE APPLIED ON THE INTERMEDIATE BIDIAGONAL MATRIX
!       d_e AND BACK-TRANSFORMATION WITH SUBROUTINE bd_deflate2 .
!
!       ON ENTRY OF bd_deflate2: PARAMETER s CONTAINS SELECTED SINGULAR VALUES OF THE BIDIAGONAL
!       MATRIX (OR OF a). THE SINGULAR VALUES MUST BE GIVEN IN DECREASING ORDER.
!
!       OPTIONAL PARAMETER ortho DETERMINES IF DEFLATION IS APPLIED SEQUENTIALLY TO ALL
!       COMPUTED SINGULAR VECTORS (ortho=true) OR ONLY IN EACH CLUSTER OF SINGULAR VALUES
!       (ortho=false). IN THE LATTER CASE, ORTHOGONALITY OF THE SINGULAR VECTORS MAY BE
!       SLIGHTLY DEGRADED, BUT COMPUTATIONS WILL BE MUCH FASTER.
!
        ortho = false
        max_qr_steps = 4_i4b
!
        if ( two_stage ) then
!
            if ( gen_q ) then
!
                call bd_deflate2( a(:n,:m), tauq(:mn), taup(:mn), rla(:mn,:mn), &
                                  d(:mn), e(:mn), s(:nsing),                    &
                                  leftvec(:n,:nsing), rightvec(:m,:nsing),      &
                                  failure=failure2, ortho=ortho,                &
                                  max_qr_steps=max_qr_steps                     )
!
            else
!
                call bd_deflate2( a(:n,:m), tauq(:mn), taup(:mn), rla(:mn,:mn), &
                                  d(:mn), e(:mn), s(:nsing),                    &
                                  leftvec(:n,:nsing), rightvec(:m,:nsing),      &
                                  failure=failure2, tauo=tauo(:mn),             &
                                  ortho=ortho, max_qr_steps=max_qr_steps        )
!
            end if
!
        else
!
            call bd_deflate2( a(:n,:m), tauq(:mn), taup(:mn), d(:mn), e(:mn), s(:nsing),   &
                              leftvec(:n,:nsing), rightvec(:m,:nsing), failure=failure2,   &
                              ortho=ortho, max_qr_steps=max_qr_steps                       )
!
        end if
!
!       ON EXIT OF bd_deflate2 :
!
!           failure= false :  INDICATES SUCCESSFUL EXIT.
!           failure= true  :  INDICATES THAT MAXIMUM ACCURACY WAS NOT OBTAIN IN THE
!                             DEFLATION ALGORITHM.

!           leftvec AND rightvec CONTAIN, RESPECTIVELY, THE FIRST nsing LEFT AND RIGHT
!           SINGULAR VECTORS OF a .
!
!       bd_deflate2 MAY FAIL IF SOME THE SINGULAR VALUES SPECIFIED IN PARAMETER s ARE NEARLY
!       IDENTICAL FOR SOME PATHOLOGICAL MATRICES.
!
    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 ( do_test .and. nsing>0 ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*V(:m,:nsing) - U(:n,:nsing)*S(:nsing,:nsing),
!       WHERE leftvec AND rightvec ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a.
!
        resid(:n,:nsing) = matmul(a2,rightvec) - leftvec*spread(s(:nsing),dim=1,ncopies=n)
        resid2(:nsing) = norm( resid(:n,:nsing), dim=2_i4b )
!
        err1 = maxval( resid2(:nsing) )/ ( norm( a2 )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U(:n,:nsing)**(t)*U(:n,:nsing).
!
        call unit_matrix( a2(:nsing,:nsing) )
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(leftvec), leftvec ) )
!
        err2 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - V(:m,:nsing)**(t)*V(:m,:nsing).
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(rightvec), rightvec ) )
        err3 = maxval( resid(:nsing,:nsing) )/real(m,stnd)
!
        err = max( err1, err2, err3 )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( do_test ) then
!
        deallocate( a2, resid, resid2 )
!
    end if
!
    if ( nsing>0 ) then
!
        deallocate( leftvec, rightvec )
!
    end if
!
!
    if ( two_stage ) then
!
        if ( gen_q ) then
            deallocate( a, rla, s, d, e, tauq, taup )
        else
            deallocate( a, rla, s, d, e, tauo, tauq, taup )
        end if
!
    else
!
        deallocate( a, s, d, e, tauq, taup )
!
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. .not.failure1 .and. .not.failure2 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test .and. nsing>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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', nsing, ' singular values and vectors of a ', &
       n, ' by ', m,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_select_singval_cmp2
! ======================================
!
end program ex2_select_singval_cmp2

ex2_select_singval_cmp3.F90

program ex2_select_singval_cmp3
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SELECT_SINGVAL_CMP3
!   in module SVD_Procedures.
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine BD_DEFLATE2 in module SVD_Procedures.
!                                                                              
! LATEST REVISION : 25/10/2019
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c0_9, c1_5, c50, lamch, bd_deflate2, &
                         select_singval_cmp3, merror, allocate_error, norm, 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
!
    integer(i4b), parameter :: prtunit=6, n=2000, m=1000, ls=500
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of select_singval_cmp3'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, err3, eps, abstol, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, a2, p, leftvec, rightvec, resid, ra
    real(stnd), dimension(:),   allocatable :: s, d, e, tauo, resid2
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: max_qr_steps, nsing, mnthr, mnthr_nsing
!
    logical(lgl) :: failure1, failure2, ortho, gen_p, gen_q, do_test, two_stage
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 2 : PARTIAL SVD OF A n-BY-m REAL MATRIX WITH n>=m USING THE RHALA-BARLOW
!               ONE-SIDED BIDIAGONAL REDUCTION ALGORITHM, A BISECTION ALGORITHM FOR
!               SINGULAR VALUES AND THE GODUNOV DEFLATION TECHNIQUE FOR SINGULAR VECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps    = fudge*epsilon( err )
    abstol = sqrt( lamch('S') )
    err    = zero
!
!   SPECIFY IF NUMERICAL TESTS ARE PERFORMED.
!
    do_test = true
!
!   DETERMINE CROSSOVER POINT FOR THE SVD WHEN REDUCING
!   a TO BIDIAGONAL FORM. IF n EXCEEDS mnthr ,
!   A QR FACTORIZATION IS USED FIRST TO REDUCE THE
!   n-BY-m MATRIX a TO A TRIANGULAR FORM.
!    
    mnthr = int( real( m, stnd )*c1_5, i4b )
!
    two_stage = n>=mnthr
!    two_stage = true
!    two_stage = false
!
!   DETERMINE CROSSOVER POINT FOR THE BACK-TRANSFORMATION
!   ALGORITHM WHEN COMPUTING RIGHT SINGULAR VECTORS. IF
!   ls EXCEEDS mnthr_nsing, THE RIGHT ORTHOGONAL MATRIX p
!   OF THE ONE-SIDED BIDIAGONAL REDUCTION ALGORITHM IS GENERATED
!   AND BACK-TRANSFORMATION IS DONE BY A MATRIX MULTIPLICATION.
!
    mnthr_nsing = int( real( m, stnd )*c0_9, i4b )
!
    gen_p = ls>=mnthr_nsing
!    gen_p = true
!    gen_p = false
!
!   DETERMINE CROSSOVER POINT FOR THE BACK-TRANSFORMATION
!   ALGORITHM WHEN COMPUTING LEFT SINGULAR VECTORS. IF n
!   EXCEEDS mnthr (E.G. A PRELIMINARY QR IS DONE) AND ls
!   EXCEEDS mnthr_nsing, THE ORTHOGONAL MATRIX q OF THE QR
!   FACTORIZATION IS GENERATED AND THE LEFT SINGULAR VECTORS
!   ARE COMPUTED BY A MATRIX MULTIPLICATION.
!
    gen_q = ls>=mnthr_nsing .and. two_stage
!    gen_q = true
!    gen_q = false
!
!   ALLOCATE WORK ARRAYS.
!
    if ( two_stage ) then
        if ( gen_q ) then
            allocate( a(n,m), ra(m,m), s(m), d(m),    &
                      e(m), p(m,m), stat=iok )
        else
            allocate( a(n,m), ra(m,m), s(m), d(m),    &
                      e(m), tauo(m), p(m,m), stat=iok )
        end if
    else
        allocate( a(n,m), s(m), d(m), e(m), &
                  p(m,m), stat=iok )
    end if
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-BY-m RANDOM REAL MATRIX a.
!
    call random_number( a )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( a2(n,m), resid(n,m), 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,:m) = a(:n,:m)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL n-BY-m MATRIX a
!   IS WRITTEN
!
!                       a = U * S * V**(t)
!
!   WHERE S IS AN n-BY-m MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   min(m,n) DIAGONAL ELEMENTS, U IS AN n-BY-n ORTHOGONAL MATRIX, AND
!   V IS AN m-BY-m 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.
!
!   THIS PROGRAM ILLUSTRATES HOW TO COMPUTE THE ls LARGEST SINGULAR VALUES OF a AND THE
!   ASSOCIATED LEFT AND RIGHT SINGULAR VECTORS OF a (EG A PARTIAL SVD DECOMPOSITION OF a)
!   IN TWO STEPS:
!
!   STEP1 : COMPUTE THE ls LARGEST SINGULAR VALUES OF a BY THE RHALA-BARLOW ONE-SIDED
!   BIDIAGONAL REDUCTION ALGORITHM APPLIED TO a, A BISECTION METHOD APPLIED TO THE
!   GOLUB-KAHAN TRIDIAGONAL FORM OF THE RESULTING BIDIAGONAL MATRIX AND STORE INTERMEDIATE
!   RESULTS WITH SUBROUTINE select_singval_cmp3.
!
!   THE OPTIONAL ARGUMENT ls OF select_singval_cmp3 MAY BE USED TO DETERMINE HOW MANY
!   SINGULAR VALUES MUST BE COMPUTED.
!
!   THE OPTIONAL ARGUMENT abstol OF select_singval_cmp3 MAY BE USED TO SET THE REQUIRED
!   PRECISION FOR THE SINGULAR VALUES. A SINGULAR VALUE IS CONSIDERED TO BE LOCATED
!   IF IT HAS BEEN DETERMINED TO LIE IN AN INTERVAL WHOSE WIDTH IS EQUAL OR LESS
!   THAN abstol. SINGULAR VALUES WILL BE COMPUTED MOST ACCURATELY WHEN abstol IS SET
!   TO THE SQUARE ROOT OF THE UNDERFLOW THRESHOLD (EG sqrt(LAMCH('S')) ).
!
    if ( two_stage ) then
!
!       STEP1A : REDUCE THE MATRIX a TO BIDIAGONAL FORM BY A TWO-STAGE ALGORITHM.
!       THE MATRIX a IS FIRST REDUCED TO TRIANGULAR FORM BY A QR FACTORIZATION
!       IN A FIRST STAGE. THE TRIANGULAR MATRIX IS REDUCED TO BIDIAGONAL FORM IN A
!       SECOND STAGE.
!       THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!       THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM IN THE TWO-STAGE 
!       ALGORITHM ARE STORED IN a, ra, tauo AND p.
!
        if ( gen_q ) then
!
            call select_singval_cmp3( a, ra, nsing, s, failure=failure1, sort=sort, d=d, e=e, &
                                      ls=ls, abstol=abstol, p=p, gen_p=gen_p )
!
        else
!
            call select_singval_cmp3( a, ra, nsing, s, failure=failure1, sort=sort, d=d, e=e, &
                                      ls=ls, abstol=abstol, tauo=tauo, p=p, gen_p=gen_p )
!
        end if
!
    else
!
!       STEP1B : REDUCE THE MATRIX a TO BIDIAGONAL FORM WITHOUT A QR OR LQ FACTORIZATION.
!       THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!       THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM ARE STORED IN a AND p .
!
        call select_singval_cmp3( a, nsing, s, failure=failure1, sort=sort, d=d, e=e, &
                                  ls=ls, abstol=abstol, p=p, gen_p=gen_p )
!
    end if
!
!   ON EXIT OF select_singval_cmp3 :
!
!   failure= false :  INDICATES SUCCESSFUL EXIT
!   failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                     THAT FULL ACCURACY WAS NOT ATTAINED IN THE
!                     COMPUTATION OF THE SINGULAR VALUES OF a.
!
!   THE SINGULAR VALUES ARE STORED IN s IN DECREASING ORDER (IF sort='d').
!
!   nsing GIVES THE NUMBER OF SINGULAR VALUES REALLY COMPUTED BY select_singval_cmp3.
!   nsing MAY BE GREATER THAN ls IF CLUSTERS OF SINGULAR VALUES ARE PRESENT.
!   THE nsing LARGEST SINGULAR VALUES ARE STORED IN THE FIRST nsing POSITIONS OF s
!   IN DECREASING ORDER IF sort='d'.
!
!   STEP2 : COMPUTE nsing LEFT AND RIGHT SINGULAR VECTORS OF a BY A DEFLATION TECHNIQUE
!   APPLIED TO THE INTERMEDIATE BIDIAGONAL MATRIX AND BACK-TRANSFORMATION WITH SUBROUTINE
!   bd_deflate2.
!
    if ( nsing>0 ) then
!
!       ALLOCATE WORK VARIABLES NEEDED TO STORE THE SINGULAR VECTORS.
!
        allocate( leftvec(n,nsing),    &
                  rightvec(m,nsing),   &
                  stat = iok    )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE THE FIRST nsing LEFT AND RIGHT SINGULAR VECTORS OF a BY 
!       A DEFLATION TECHNIQUE APPLIED ON THE INTERMEDIATE BIDIAGONAL MATRIX
!       d_e AND BACK-TRANSFORMATION WITH SUBROUTINE bd_deflate2 .
!
!       ON ENTRY OF bd_deflate2: PARAMETER s CONTAINS SELECTED SINGULAR VALUES OF THE BIDIAGONAL
!       MATRIX (OR OF a). THE SINGULAR VALUES MUST BE GIVEN IN DECREASING ORDER.
!
!       OPTIONAL PARAMETER ortho DETERMINES IF DEFLATION IS APPLIED SEQUENTIALLY TO ALL
!       COMPUTED SINGULAR VECTORS (ortho=true) OR ONLY IN EACH CLUSTER OF SINGULAR VALUES
!       (ortho=false). IN THE LATTER CASE, ORTHOGONALITY OF THE SINGULAR VECTORS MAY BE
!       SLIGHTLY DEGRADED, BUT COMPUTATIONS WILL BE MUCH FASTER.
!
        ortho = false
        max_qr_steps = 4_i4b
!
        if ( two_stage ) then
!
            if ( gen_q ) then
!
               call bd_deflate2( a(:n,:m), ra(:m,:m), p(:m,:m),            &
                                 d(:m), e(:m), s(:nsing),                  &
                                 leftvec(:n,:nsing), rightvec(:m,:nsing),  &
                                 failure=failure2, ortho=ortho,            &
                                 max_qr_steps=max_qr_steps                 )
!
            else
!
                call bd_deflate2( a(:n,:m), ra(:m,:m), p(:m,:m),            &
                                  d(:m), e(:m), s(:nsing),                  &
                                  leftvec(:n,:nsing), rightvec(:m,:nsing),  &
                                  failure=failure2, tauo=tauo(:m),          &
                                  ortho=ortho, max_qr_steps=max_qr_steps    )
!
            end if
!
        else
!
            call bd_deflate2( a(:n,:m), p(:m,:m), d(:m), e(:m), s(:nsing),  &
                              leftvec(:n,:nsing), rightvec(:m,:nsing),      &
                              failure=failure2, ortho=ortho,                &
                              max_qr_steps=max_qr_steps                     )
!
        end if
!
!       ON EXIT OF bd_deflate2 :
!
!           failure= false :  INDICATES SUCCESSFUL EXIT.
!           failure= true  :  INDICATES THAT MAXIMUM ACCURACY WAS NOT OBTAIN IN THE
!                             DEFLATION ALGORITHM.

!           leftvec AND rightvec CONTAIN, RESPECTIVELY, THE FIRST nsing LEFT AND RIGHT
!           SINGULAR VECTORS OF a .
!
!       bd_deflate2 MAY FAIL IF SOME THE SINGULAR VALUES SPECIFIED IN PARAMETER s ARE NEARLY
!       IDENTICAL FOR SOME PATHOLOGICAL MATRICES.
!
    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 ( do_test .and. nsing>0 ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*v(:m,:nsing) - u(:n,:nsing)*s(:nsing,:nsing),
!       WHERE u AND v ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a.
!
        resid(:n,:nsing) = matmul(a2,rightvec) - leftvec*spread(s(:nsing),dim=1,ncopies=n)
        resid2(:nsing) = norm( resid(:n,:nsing), dim=2_i4b )
!
        err1 = maxval( resid2(:nsing) )/( norm( a2 )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u(:n,:nsing)**(t)*u(:n,:nsing).
!
        call unit_matrix( a2(:nsing,:nsing) )
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(leftvec), leftvec ) )
!
        err2 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - v(:m,:nsing)**(t)*v(:m,:nsing).
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(rightvec), rightvec ) )
!
        err3 = maxval( resid(:nsing,:nsing) )/real(m,stnd)
!
        err = max( err1, err2, err3 )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( do_test ) then
!
        deallocate( a2, resid, resid2 )
!
    end if
!
    if ( nsing>0 ) then
!
        deallocate( a, s, d, e, p, leftvec, rightvec )
!
    else
!
        deallocate( a, s, d, e, p )
!
    end if
!
    if ( two_stage ) then
!
        if ( gen_q ) then
            deallocate( ra )
        else
            deallocate( ra, tauo )
        end if
!
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. .not.failure1 .and. .not.failure2 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test .and. nsing>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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', nsing, ' singular values and vectors of a ', &
       n, ' by ', m,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_select_singval_cmp3
! ======================================
!
end program ex2_select_singval_cmp3

ex2_select_singval_cmp3_bis.F90

program ex2_select_singval_cmp3
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SELECT_SINGVAL_CMP3
!   in module SVD_Procedures.
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine BD_DEFLATE2 in module SVD_Procedures.
!                                                                              
! LATEST REVISION : 25/10/2019
!                                                                              
! ================================================================================================
!
!
! USED MODULES
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c0_9, c50, lamch, bd_deflate2,     &
                         select_singval_cmp3, merror, allocate_error, norm, 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
!
    integer(i4b), parameter :: prtunit=6, n=2000, m=1000, ls=500
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of select_singval_cmp3'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, err3, eps, abstol, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, a2, p, leftvec, rightvec, resid, ra
    real(stnd), dimension(:),   allocatable :: s, d, e, tauo, resid2
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: max_qr_steps, nsing, mnthr_nsing
!
    logical(lgl) :: failure1, failure2, ortho, gen_p, do_test
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 2 : PARTIAL SVD OF A n-BY-m REAL MATRIX WITH n>=m USING THE RHALA-BARLOW
!               ONE-SIDED BIDIAGONAL REDUCTION ALGORITHM, A BISECTION ALGORITHM FOR
!               SINGULAR VALUES AND THE GODUNOV DEFLATION TECHNIQUE FOR SINGULAR VECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps    = fudge*epsilon( err )
    abstol = sqrt( lamch('S') )
    err    = zero
!
!   SPECIFY IF NUMERICAL TESTS ARE PERFORMED.
!
    do_test = true
!
!   CHOOSE TUNING PARAMETERS FOR THE ALGORITHM.
!
!   DETERMINE CROSSOVER POINT FOR THE BACK-TRANSFORMATION
!   ALGORITHM WHEN COMPUTING RIGHT SINGULAR VECTORS. IF
!   ls EXCEEDS mnthr_nsing, THE RIGHT ORTHOGONAL MATRIX p
!   OF THE ONE-SIDED BIDIAGONAL REDUCTION ALGORITHM IS GENERATED
!   AND BACK-TRANSFORMATION IS DONE BY A MATRIX MULTIPLICATION.
!
    mnthr_nsing = int( real( m, stnd )*c0_9, i4b )
!
    gen_p = ls>=mnthr_nsing
!    gen_p = true
!    gen_p = false
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,m), s(m), d(m), e(m), &
              p(m,m), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-BY-m RANDOM REAL MATRIX a.
!
    call random_number( a )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( a2(n,m), resid(n,m), 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,:m) = a(:n,:m)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL n-BY-m MATRIX a
!   IS WRITTEN
!
!                       a = U * S * V**(t)
!
!   WHERE S IS AN n-BY-m MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   min(m,n) DIAGONAL ELEMENTS, U IS AN n-BY-n ORTHOGONAL MATRIX, AND
!   V IS AN m-BY-m 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.
!
!   THIS PROGRAM ILLUSTRATES HOW TO COMPUTE THE ls LARGEST SINGULAR VALUES OF a AND THE
!   ASSOCIATED LEFT AND RIGHT SINGULAR VECTORS OF a (EG A PARTIAL SVD DECOMPOSITION OF a)
!   IN TWO STEPS:
!
!   STEP1 : COMPUTE THE ls LARGEST SINGULAR VALUES OF a BY THE RHALA-BARLOW ONE-SIDED
!   BIDIAGONAL REDUCTION ALGORITHM APPLIED TO a, A BISECTION METHOD APPLIED TO THE
!   GOLUB-KAHAN TRIDIAGONAL FORM OF THE RESULTING BIDIAGONAL MATRIX AND STORE INTERMEDIATE
!   RESULTS WITH SUBROUTINE select_singval_cmp3.
!
!   THE OPTIONAL ARGUMENT ls OF select_singval_cmp3 MAY BE USED TO DETERMINE HOW MANY
!   SINGULAR VALUES MUST BE COMPUTED.
!
!   THE OPTIONAL ARGUMENT abstol OF select_singval_cmp3 MAY BE USED TO SET THE REQUIRED
!   PRECISION FOR THE SINGULAR VALUES. A SINGULAR VALUE IS CONSIDERED TO BE LOCATED
!   IF IT HAS BEEN DETERMINED TO LIE IN AN INTERVAL WHOSE WIDTH IS EQUAL OR LESS
!   THAN abstol. SINGULAR VALUES WILL BE COMPUTED MOST ACCURATELY WHEN abstol IS SET
!   TO THE SQUARE ROOT OF THE UNDERFLOW THRESHOLD (EG sqrt(LAMCH('S')) ).
!
    call select_singval_cmp3( a, nsing, s, failure=failure1, sort=sort, d=d, e=e, &
                              ls=ls, abstol=abstol, p=p, gen_p=gen_p )
!
!   ON EXIT OF select_singval_cmp3 :
!
!   failure= false :  INDICATES SUCCESSFUL EXIT
!   failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                     THAT FULL ACCURACY WAS NOT ATTAINED IN THE
!                     COMPUTATION OF THE SINGULAR VALUES OF a.
!
!   THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!   THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM ARE STORED IN a AND p .
!
!   THE SINGULAR VALUES ARE STORED IN s IN DECREASING ORDER (IF sort='d').
!
!   nsing GIVES THE NUMBER OF SINGULAR VALUES REALLY COMPUTED BY select_singval_cmp3.
!   nsing MAY BE GREATER THAN ls IF CLUSTERS OF SINGULAR VALUES ARE PRESENT.
!   THE nsing LARGEST SINGULAR VALUES ARE STORED IN THE FIRST nsing POSITIONS OF s
!   IN DECREASING ORDER IF sort='d'.
!
!   STEP2 : COMPUTE nsing LEFT AND RIGHT SINGULAR VECTORS OF a BY A DEFLATION TECHNIQUE
!   APPLIED TO THE INTERMEDIATE BIDIAGONAL MATRIX AND BACK-TRANSFORMATION WITH SUBROUTINE
!   bd_deflate2.
!
    if ( nsing>0 ) then
!
!       ALLOCATE WORK VARIABLES NEEDED TO STORE THE SINGULAR VECTORS.
!
        allocate( leftvec(n,nsing),    &
                  rightvec(m,nsing),   &
                  stat = iok    )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE THE FIRST nsing LEFT AND RIGHT SINGULAR VECTORS OF a BY 
!       A DEFLATION TECHNIQUE APPLIED ON THE INTERMEDIATE BIDIAGONAL MATRIX
!       d_e AND BACK-TRANSFORMATION WITH SUBROUTINE bd_deflate2 .
!
!       ON ENTRY OF bd_deflate2: PARAMETER s CONTAINS SELECTED SINGULAR VALUES OF THE BIDIAGONAL
!       MATRIX (OR OF a). THE SINGULAR VALUES MUST BE GIVEN IN DECREASING ORDER.
!
!       OPTIONAL PARAMETER ortho DETERMINES IF DEFLATION IS APPLIED SEQUENTIALLY TO ALL
!       COMPUTED SINGULAR VECTORS (ortho=true) OR ONLY IN EACH CLUSTER OF SINGULAR VALUES
!       (ortho=false). IN THE LATTER CASE, ORTHOGONALITY OF THE SINGULAR VECTORS MAY BE
!       SLIGHTLY DEGRADED, BUT COMPUTATIONS WILL BE MUCH FASTER.
!
        ortho = false
        max_qr_steps = 4_i4b
!
        call bd_deflate2( a(:n,:m), p(:m,:m), d(:m), e(:m), s(:nsing),      &
                          leftvec(:n,:nsing), rightvec(:m,:nsing),          &
                          failure=failure2, ortho=ortho,                    &
                          max_qr_steps=max_qr_steps                         )
!
!       ON EXIT OF bd_deflate2 :
!
!           failure= false :  INDICATES SUCCESSFUL EXIT.
!           failure= true  :  INDICATES THAT MAXIMUM ACCURACY WAS NOT OBTAIN IN THE
!                             DEFLATION ALGORITHM.

!           leftvec AND rightvec CONTAIN, RESPECTIVELY, THE FIRST nsing LEFT AND RIGHT
!           SINGULAR VECTORS OF a .
!
!       bd_deflate2 MAY FAIL IF SOME THE SINGULAR VALUES SPECIFIED IN PARAMETER s ARE NEARLY
!       IDENTICAL FOR SOME PATHOLOGICAL MATRICES.
!
    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 ( do_test .and. nsing>0 ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*v(:m,:nsing) - u(:n,:nsing)*s(:nsing,:nsing),
!       WHERE u AND v ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a.
!
        resid(:n,:nsing) = matmul(a2,rightvec) - leftvec*spread(s(:nsing),dim=1,ncopies=n)
        resid2(:nsing) = norm( resid(:n,:nsing), dim=2_i4b )
!
        err1 = maxval( resid2(:nsing) )/( norm( a2 )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u(:n,:nsing)**(t)*u(:n,:nsing).
!
        call unit_matrix( a2(:nsing,:nsing) )
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(leftvec), leftvec ) )
!
        err2 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - v(:m,:nsing)**(t)*v(:m,:nsing).
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(rightvec), rightvec ) )
!
        err3 = maxval( resid(:nsing,:nsing) )/real(m,stnd)
!
        err = max( err1, err2, err3 )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( do_test ) then
!
        deallocate( a2, resid, resid2 )
!
    end if
!
    if ( nsing>0 ) then
!
        deallocate( a, s, d, e, p, leftvec, rightvec )
!
    else
!
        deallocate( a, s, d, e, p )
!
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. .not.failure1 .and. .not.failure2 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test .and. nsing>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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', nsing, ' singular values and vectors of a ', &
       n, ' by ', m,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_select_singval_cmp3
! ======================================
!
end program ex2_select_singval_cmp3

ex2_select_singval_cmp4.F90

program ex2_select_singval_cmp4
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SELECT_SINGVAL_CMP4
!   in module SVD_Procedures.
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine BD_DEFLATE2 in module SVD_Procedures.
!                                                                              
! LATEST REVISION : 25/10/2019
!                                                                              
! ================================================================================================
!
!
! USED MODULES
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c0_9, c1_5, c50, lamch, bd_deflate2,  &
                         select_singval_cmp4, merror, allocate_error, norm, 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
!
    integer(i4b), parameter :: prtunit=6, n=3000, m=2000, ls=2000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of select_singval_cmp4'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, err3, eps, abstol, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, a2, p, leftvec, rightvec, resid, ra
    real(stnd), dimension(:),   allocatable :: s, d, e, tauo, resid2
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: max_qr_steps, nsing, mnthr, mnthr_nsing
!
    logical(lgl) :: failure1, failure2, ortho, gen_p, gen_q, do_test, two_stage
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 2 : PARTIAL SVD OF A n-BY-m REAL MATRIX WITH n>=m USING THE RHALA-BARLOW
!               ONE-SIDED BIDIAGONAL REDUCTION ALGORITHM, A BISECTION ALGORITHM FOR
!               SINGULAR VALUES AND THE GODUNOV DEFLATION TECHNIQUE FOR SINGULAR VECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps    = fudge*epsilon( err )
    abstol = sqrt( lamch('S') )
    err    = zero
!
!   SPECIFY IF NUMERICAL TESTS ARE PERFORMED.
!
    do_test = true
!
!   CHOOSE TUNING PARAMETERS FOR THE ALGORITHM.
!
!   DETERMINE CROSSOVER POINT FOR THE SVD WHEN REDUCING
!   a TO BIDIAGONAL FORM. IF n EXCEEDS mnthr ,
!   A QR FACTORIZATION IS USED FIRST TO REDUCE THE
!   n-BY-m MATRIX a TO A TRIANGULAR FORM.
!    
    mnthr = int( real( m, stnd )*c1_5, i4b )
!
    two_stage = n>=mnthr
!    two_stage = true
!    two_stage = false
!
!   DETERMINE CROSSOVER POINT FOR THE BACK-TRANSFORMATION
!   ALGORITHM WHEN COMPUTING RIGHT SINGULAR VECTORS. IF
!   ls EXCEEDS mnthr_nsing, THE RIGHT ORTHOGONAL MATRIX p
!   OF THE ONE-SIDED BIDIAGONAL REDUCTION ALGORITHM IS GENERATED
!   AND BACK-TRANSFORMATION IS DONE BY A MATRIX MULTIPLICATION.
!
    mnthr_nsing = int( real( m, stnd )*c0_9, i4b )
!
    gen_p = ls>=mnthr_nsing
!    gen_p = true
!    gen_p = false
!
!   DETERMINE CROSSOVER POINT FOR THE BACK-TRANSFORMATION
!   ALGORITHM WHEN COMPUTING LEFT SINGULAR VECTORS. IF n
!   EXCEEDS mnthr (E.G. A PRELIMINARY QR IS DONE) AND ls
!   EXCEEDS mnthr_nsing, THE ORTHOGONAL MATRIX q OF THE QR
!   FACTORIZATION IS GENERATED AND THE LEFT SINGULAR VECTORS
!   ARE COMPUTED BY A MATRIX MULTIPLICATION.
!
    gen_q = ls>=mnthr_nsing .and. two_stage
!    gen_q = true
!    gen_q = false
!
!   ALLOCATE WORK ARRAYS.
!
    if ( two_stage ) then
        if ( gen_q ) then
            allocate( a(n,m), ra(m,m), s(m), d(m),    &
                      e(m), p(m,m), stat=iok )
        else
            allocate( a(n,m), ra(m,m), s(m), d(m),    &
                      e(m), tauo(m), p(m,m), stat=iok )
        end if
    else
        allocate( a(n,m), s(m), d(m), e(m), &
                  p(m,m), stat=iok )
    end if
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-BY-m RANDOM REAL MATRIX a.
!
    call random_number( a )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( a2(n,m), resid(n,m), 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,:m) = a(:n,:m)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL n-BY-m MATRIX a
!   IS WRITTEN
!
!                       a = U * S * V**(t)
!
!   WHERE S IS AN n-BY-m MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   min(m,n) DIAGONAL ELEMENTS, U IS AN n-BY-n ORTHOGONAL MATRIX, AND
!   V IS AN m-BY-m 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.
!
!   THIS PROGRAM ILLUSTRATES HOW TO COMPUTE THE ls LARGEST SINGULAR VALUES OF a AND THE
!   ASSOCIATED LEFT AND RIGHT SINGULAR VECTORS OF a (EG A PARTIAL SVD DECOMPOSITION OF a)
!   IN TWO STEPS:
!
!   STEP1 : COMPUTE THE ls LARGEST SINGULAR VALUES OF a BY THE RHALA-BARLOW ONE-SIDED
!   BIDIAGONAL REDUCTION ALGORITHM APPLIED TO a, A BISECTION METHOD APPLIED TO THE
!   THE RESULTING BIDIAGONAL MATRIX AND STORE INTERMEDIATE RESULTS WITH SUBROUTINE
!   select_singval_cmp4.
!
!   THE OPTIONAL ARGUMENT ls OF select_singval_cmp4 MAY BE USED TO DETERMINE HOW MANY
!   SINGULAR VALUES MUST BE COMPUTED.
!
!   THE OPTIONAL ARGUMENT abstol OF select_singval_cmp4 MAY BE USED TO SET THE REQUIRED
!   PRECISION FOR THE SINGULAR VALUES. A SINGULAR VALUE IS CONSIDERED TO BE LOCATED
!   IF IT HAS BEEN DETERMINED TO LIE IN AN INTERVAL WHOSE WIDTH IS EQUAL OR LESS
!   THAN abstol. SINGULAR VALUES WILL BE COMPUTED MOST ACCURATELY WHEN abstol IS SET
!   TO THE SQUARE ROOT OF THE UNDERFLOW THRESHOLD (EG sqrt(LAMCH('S')) ).
!
!   select_singval_cmp4 IS FASTER THAN select_singval_cmp3, BUT MAY BE LESS ACCURATE
!   FOR SOME MATRICES.
!
    if ( two_stage ) then
!
!       STEP1A : REDUCE THE MATRIX a TO BIDIAGONAL FORM BY A TWO-STAGE ALGORITHM.
!       THE MATRIX a IS FIRST REDUCED TO TRIANGULAR FORM BY A QR FACTORIZATION
!       IN A FIRST STAGE. THE TRIANGULAR MATRIX IS REDUCED TO BIDIAGONAL FORM IN A
!       SECOND STAGE.
!       THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!       THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM IN THE TWO-STAGE 
!       ALGORITHM ARE STORED IN a, ra, tauo AND p.
!
        if ( gen_q ) then
!
            call select_singval_cmp4( a, ra, nsing, s, failure=failure1, sort=sort, d=d, e=e, &
                                      ls=ls, abstol=abstol, p=p, gen_p=gen_p )
!
        else
!
            call select_singval_cmp4( a, ra, nsing, s, failure=failure1, sort=sort, d=d, e=e, &
                                      ls=ls, abstol=abstol, tauo=tauo, p=p, gen_p=gen_p )
!
        end if
!
    else
!
!       STEP1B : REDUCE THE MATRIX a TO BIDIAGONAL FORM WITHOUT A QR OR LQ FACTORIZATION.
!       THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!       THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM ARE STORED IN a AND p .
!
        call select_singval_cmp4( a, nsing, s, failure=failure1, sort=sort, d=d, e=e, &
                                  ls=ls, abstol=abstol, p=p, gen_p=gen_p )
!
    end if
!
!   ON EXIT OF select_singval_cmp4 :
!
!   failure= false :  INDICATES SUCCESSFUL EXIT
!   failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                     THAT FULL ACCURACY WAS NOT ATTAINED IN THE
!                     COMPUTATION OF THE SINGULAR VALUES OF a.
!
!   THE SINGULAR VALUES ARE STORED IN s IN DECREASING ORDER (IF sort='d').
!
!   nsing GIVES THE NUMBER OF SINGULAR VALUES REALLY COMPUTED BY select_singval_cmp4.
!   nsing MAY BE GREATER THAN ls IF CLUSTERS OF SINGULAR VALUES ARE PRESENT.
!   THE nsing LARGEST SINGULAR VALUES ARE STORED IN THE FIRST nsing POSITIONS OF s
!   IN DECREASING ORDER IF sort='d'.
!
!   STEP2 : COMPUTE nsing LEFT AND RIGHT SINGULAR VECTORS OF a BY A DEFLATION TECHNIQUE
!   APPLIED TO THE INTERMEDIATE BIDIAGONAL MATRIX AND BACK-TRANSFORMATION WITH SUBROUTINE
!   bd_deflate2.
!
    if ( nsing>0 ) then
!
!       ALLOCATE WORK VARIABLES NEEDED TO STORE THE SINGULAR VECTORS.
!
        allocate( leftvec(n,nsing),    &
                  rightvec(m,nsing),   &
                  stat = iok    )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE THE FIRST nsing LEFT AND RIGHT SINGULAR VECTORS OF a BY 
!       A DEFLATION TECHNIQUE APPLIED ON THE INTERMEDIATE BIDIAGONAL MATRIX
!       d_e AND BACK-TRANSFORMATION WITH SUBROUTINE bd_deflate2 .
!
!       ON ENTRY OF bd_deflate2: PARAMETER s CONTAINS SELECTED SINGULAR VALUES OF THE BIDIAGONAL
!       MATRIX (OR OF a). THE SINGULAR VALUES MUST BE GIVEN IN DECREASING ORDER.
!
!       OPTIONAL PARAMETER ortho DETERMINES IF DEFLATION IS APPLIED SEQUENTIALLY TO ALL
!       COMPUTED SINGULAR VECTORS (ortho=true) OR ONLY IN EACH CLUSTER OF SINGULAR VALUES
!       (ortho=false). IN THE LATTER CASE, ORTHOGONALITY OF THE SINGULAR VECTORS MAY BE
!       SLIGHTLY DEGRADED, BUT COMPUTATIONS WILL BE MUCH FASTER.
!
        ortho = false
        max_qr_steps = 4_i4b
!
        if ( two_stage ) then
!
            if ( gen_q ) then
!
               call bd_deflate2( a(:n,:m), ra(:m,:m), p(:m,:m),            &
                                 d(:m), e(:m), s(:nsing),                  &
                                 leftvec(:n,:nsing), rightvec(:m,:nsing),  &
                                 failure=failure2, ortho=ortho,            &
                                 max_qr_steps=max_qr_steps                 )
!
            else
!
                call bd_deflate2( a(:n,:m), ra(:m,:m), p(:m,:m),            &
                                  d(:m), e(:m), s(:nsing),                  &
                                  leftvec(:n,:nsing), rightvec(:m,:nsing),  &
                                  failure=failure2, tauo=tauo(:m),          &
                                  ortho=ortho, max_qr_steps=max_qr_steps    )
!
            end if
!
        else
!
            call bd_deflate2( a(:n,:m), p(:m,:m), d(:m), e(:m), s(:nsing),  &
                              leftvec(:n,:nsing), rightvec(:m,:nsing),      &
                              failure=failure2, ortho=ortho,                &
                              max_qr_steps=max_qr_steps                     )
!
        end if
!
!       ON EXIT OF bd_deflate2 :
!
!           failure= false :  INDICATES SUCCESSFUL EXIT.
!           failure= true  :  INDICATES THAT MAXIMUM ACCURACY WAS NOT OBTAIN IN THE
!                             DEFLATION ALGORITHM.

!           leftvec AND rightvec CONTAIN, RESPECTIVELY, THE FIRST nsing LEFT AND RIGHT
!           SINGULAR VECTORS OF a .
!
!       bd_deflate2 MAY FAIL IF SOME THE SINGULAR VALUES SPECIFIED IN PARAMETER s ARE NEARLY
!       IDENTICAL FOR SOME PATHOLOGICAL MATRICES.
!
    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 ( do_test .and. nsing>0 ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*v(:m,:nsing) - u(:n,:nsing)*s(:nsing,:nsing),
!       WHERE u AND v ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a.
!
        resid(:n,:nsing) = matmul(a2,rightvec) - leftvec*spread(s(:nsing),dim=1,ncopies=n)
        resid2(:nsing) = norm( resid(:n,:nsing), dim=2_i4b )
!
        err1 = maxval( resid2(:nsing) )/( norm( a2 )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u(:n,:nsing)**(t)*u(:n,:nsing).
!
        call unit_matrix( a2(:nsing,:nsing) )
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(leftvec), leftvec ) )
!
        err2 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - v(:m,:nsing)**(t)*v(:m,:nsing).
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(rightvec), rightvec ) )
!
        err3 = maxval( resid(:nsing,:nsing) )/real(m,stnd)
!
        err = max( err1, err2, err3 )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( do_test ) then
!
        deallocate( a2, resid, resid2 )
!
    end if
!
    if ( nsing>0 ) then
!
        deallocate( a, s, d, e, p, leftvec, rightvec )
!
    else
!
        deallocate( a, s, d, e, p )
!
    end if
!
    if ( two_stage ) then
!
        if ( gen_q ) then
            deallocate( ra )
        else
            deallocate( ra, tauo )
        end if
!
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. .not.failure1 .and. .not.failure2 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test .and. nsing>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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', nsing, ' singular values and vectors of a ', &
       n, ' by ', m,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_select_singval_cmp4
! ======================================
!
end program ex2_select_singval_cmp4

ex2_select_singval_cmp4_bis.F90

program ex2_select_singval_cmp4
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SELECT_SINGVAL_CMP4
!   in module SVD_Procedures.
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine BD_DEFLATE2 in module SVD_Procedures.
!                                                                              
! LATEST REVISION : 25/10/2019
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c0_9, c50, lamch, bd_deflate2,  &
                         select_singval_cmp4, merror, allocate_error, norm, 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
!
    integer(i4b), parameter :: prtunit=6, n=2000, m=1000, ls=400
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of select_singval_cmp4'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, err3, eps, abstol, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, a2, p, leftvec, rightvec, resid, ra
    real(stnd), dimension(:),   allocatable :: s, d, e, tauo, resid2
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: max_qr_steps, nsing, mnthr_nsing
!
    logical(lgl) :: failure1, failure2, ortho, gen_p, do_test
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 2 : PARTIAL SVD OF A n-BY-m REAL MATRIX WITH n>=m USING THE RHALA-BARLOW
!               ONE-SIDED BIDIAGONAL REDUCTION ALGORITHM, A BISECTION ALGORITHM FOR
!               SINGULAR VALUES AND THE GODUNOV DEFLATION TECHNIQUE FOR SINGULAR VECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps    = fudge*epsilon( err )
    abstol = sqrt( lamch('S') )
    err    = zero
!
!   SPECIFY IF NUMERICAL TESTS ARE PERFORMED.
!
    do_test = true
!
!   CHOOSE TUNING PARAMETERS FOR THE ALGORITHM.
!
!   DETERMINE CROSSOVER POINT FOR THE BACK-TRANSFORMATION
!   ALGORITHM WHEN COMPUTING RIGHT SINGULAR VECTORS. IF
!   ls EXCEEDS mnthr_nsing, THE RIGHT ORTHOGONAL MATRIX p
!   OF THE ONE-SIDED BIDIAGONAL REDUCTION ALGORITHM IS GENERATED
!   AND BACK-TRANSFORMATION IS DONE BY A MATRIX MULTIPLICATION.
!
    mnthr_nsing = int( real( m, stnd )*c0_9, i4b )
!
    gen_p = ls>=mnthr_nsing
!    gen_p = true
!    gen_p = false
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,m), s(m), d(m), e(m), &
              p(m,m), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-BY-m RANDOM REAL MATRIX a.
!
    call random_number( a )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( a2(n,m), resid(n,m), 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,:m) = a(:n,:m)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL n-BY-m MATRIX a
!   IS WRITTEN
!
!                       a = U * S * V**(t)
!
!   WHERE S IS AN n-BY-m MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   min(m,n) DIAGONAL ELEMENTS, U IS AN n-BY-n ORTHOGONAL MATRIX, AND
!   V IS AN m-BY-m 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.
!
!   THIS PROGRAM ILLUSTRATES HOW TO COMPUTE THE ls LARGEST SINGULAR VALUES OF a AND THE
!   ASSOCIATED LEFT AND RIGHT SINGULAR VECTORS OF a (EG A PARTIAL SVD DECOMPOSITION OF a)
!   IN TWO STEPS:
!
!   STEP1 : COMPUTE THE ls LARGEST SINGULAR VALUES OF a BY THE RHALA-BARLOW ONE-SIDED
!   BIDIAGONAL REDUCTION ALGORITHM APPLIED TO a, A BISECTION METHOD APPLIED TO THE
!   THE RESULTING BIDIAGONAL MATRIX AND STORE INTERMEDIATE RESULTS WITH SUBROUTINE
!   select_singval_cmp4.
!
!   THE OPTIONAL ARGUMENT ls OF select_singval_cmp4 MAY BE USED TO DETERMINE HOW MANY
!   SINGULAR VALUES MUST BE COMPUTED.
!
!   THE OPTIONAL ARGUMENT abstol OF select_singval_cmp4 MAY BE USED TO SET THE REQUIRED
!   PRECISION FOR THE SINGULAR VALUES. A SINGULAR VALUE IS CONSIDERED TO BE LOCATED
!   IF IT HAS BEEN DETERMINED TO LIE IN AN INTERVAL WHOSE WIDTH IS EQUAL OR LESS
!   THAN abstol. SINGULAR VALUES WILL BE COMPUTED MOST ACCURATELY WHEN abstol IS SET
!   TO THE SQUARE ROOT OF THE UNDERFLOW THRESHOLD (EG sqrt(LAMCH('S')) ).
!
!   select_singval_cmp4 IS FASTER THAN select_singval_cmp3, BUT MAY BE LESS ACCURATE
!   FOR SOME MATRICES.
!
    call select_singval_cmp4( a, nsing, s, failure=failure1, sort=sort, d=d, e=e, &
                              ls=ls, abstol=abstol, p=p, gen_p=gen_p )
!
!   ON EXIT OF select_singval_cmp4 :
!
!   failure= false :  INDICATES SUCCESSFUL EXIT
!   failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                     THAT FULL ACCURACY WAS NOT ATTAINED IN THE
!                     COMPUTATION OF THE SINGULAR VALUES OF a.
!
!   THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN d AND e.
!   THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM ARE STORED IN a AND p .
!
!   THE SINGULAR VALUES ARE STORED IN s IN DECREASING ORDER (IF sort='d').
!
!   nsing GIVES THE NUMBER OF SINGULAR VALUES REALLY COMPUTED BY select_singval_cmp4.
!   nsing MAY BE GREATER THAN ls IF CLUSTERS OF SINGULAR VALUES ARE PRESENT.
!   THE nsing LARGEST SINGULAR VALUES ARE STORED IN THE FIRST nsing POSITIONS OF s
!   IN DECREASING ORDER IF sort='d'.
!
!   STEP2 : COMPUTE nsing LEFT AND RIGHT SINGULAR VECTORS OF a BY A DEFLATION TECHNIQUE
!   APPLIED TO THE INTERMEDIATE BIDIAGONAL MATRIX AND BACK-TRANSFORMATION WITH SUBROUTINE
!   bd_deflate2.
!
    if ( nsing>0 ) then
!
!       ALLOCATE WORK VARIABLES NEEDED TO STORE THE SINGULAR VECTORS.
!
        allocate( leftvec(n,nsing),    &
                  rightvec(m,nsing),   &
                  stat = iok    )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       COMPUTE THE FIRST nsing LEFT AND RIGHT SINGULAR VECTORS OF a BY 
!       A DEFLATION TECHNIQUE APPLIED ON THE INTERMEDIATE BIDIAGONAL MATRIX
!       d_e AND BACK-TRANSFORMATION WITH SUBROUTINE bd_deflate2 .
!
!       ON ENTRY OF bd_deflate2: PARAMETER s CONTAINS SELECTED SINGULAR VALUES OF THE BIDIAGONAL
!       MATRIX (OR OF a). THE SINGULAR VALUES MUST BE GIVEN IN DECREASING ORDER.
!
!       OPTIONAL PARAMETER ortho DETERMINES IF DEFLATION IS APPLIED SEQUENTIALLY TO ALL
!       COMPUTED SINGULAR VECTORS (ortho=true) OR ONLY IN EACH CLUSTER OF SINGULAR VALUES
!       (ortho=false). IN THE LATTER CASE, ORTHOGONALITY OF THE SINGULAR VECTORS MAY BE
!       SLIGHTLY DEGRADED, BUT COMPUTATIONS WILL BE MUCH FASTER.
!
        ortho = false
        max_qr_steps = 4_i4b
!
        call bd_deflate2( a(:n,:m), p(:m,:m), d(:m), e(:m), s(:nsing),  &
                          leftvec(:n,:nsing), rightvec(:m,:nsing),      &
                          failure=failure2, ortho=ortho,                &
                          max_qr_steps=max_qr_steps                     )
!
!       ON EXIT OF bd_deflate2 :
!
!           failure= false :  INDICATES SUCCESSFUL EXIT.
!           failure= true  :  INDICATES THAT MAXIMUM ACCURACY WAS NOT OBTAIN IN THE
!                             DEFLATION ALGORITHM.

!           leftvec AND rightvec CONTAIN, RESPECTIVELY, THE FIRST nsing LEFT AND RIGHT
!           SINGULAR VECTORS OF a .
!
!       bd_deflate2 MAY FAIL IF SOME THE SINGULAR VALUES SPECIFIED IN PARAMETER s ARE NEARLY
!       IDENTICAL FOR SOME PATHOLOGICAL MATRICES.
!
    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 ( do_test .and. nsing>0 ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*v(:m,:nsing) - u(:n,:nsing)*s(:nsing,:nsing),
!       WHERE u AND v ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a.
!
        resid(:n,:nsing) = matmul(a2,rightvec) - leftvec*spread(s(:nsing),dim=1,ncopies=n)
        resid2(:nsing) = norm( resid(:n,:nsing), dim=2_i4b )
!
        err1 = maxval( resid2(:nsing) )/( norm( a2 )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u(:n,:nsing)**(t)*u(:n,:nsing).
!
        call unit_matrix( a2(:nsing,:nsing) )
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(leftvec), leftvec ) )
!
        err2 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - v(:m,:nsing)**(t)*v(:m,:nsing).
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(rightvec), rightvec ) )
!
        err3 = maxval( resid(:nsing,:nsing) )/real(m,stnd)
!
        err = max( err1, err2, err3 )
!
    end if
!
!   DEALLOCATE WORK ARRAYS.
!
    if ( do_test ) then
!
        deallocate( a2, resid, resid2 )
!
    end if
!
    if ( nsing>0 ) then
!
        deallocate( a, s, d, e, p, leftvec, rightvec )
!
    else
!
        deallocate( a, s, d, e, p )
!
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. .not.failure1 .and. .not.failure2 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test .and. nsing>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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', nsing, ' singular values and vectors of a ', &
       n, ' by ', m,' real matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_select_singval_cmp4
! ======================================
!
end program ex2_select_singval_cmp4

ex2_solve_lin.F90

program ex2_solve_lin
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of fonction SOLVE_LIN
!   in module Lin_Procedures . 
!                                                                              
! LATEST REVISION : 04/10/2014
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, lgl, stnd, true, false, zero, solve_lin, merror, allocate_error
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=4000, nrhs=4000
!
    character(len=*), parameter :: name_proc='Example 2 of solve_lin'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, eps, elapsed_time
    real(stnd), dimension(:,:), allocatable :: a, b, x, x2, res
!
    integer                                 :: iok, istart, iend, irate
!
    logical(lgl)   :: do_test
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 2 : REAL MATRIX AND SEVERAL RIGHT HAND-SIDES.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = sqrt( epsilon( err ) )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), b(n,nrhs), x(n,nrhs), x2(n,nrhs), 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=istart, count_rate=irate )
!
!   COMPUTE THE SOLUTION MATRIX FOR LINEAR SYSTEM
!
!            a*x = b .
!
!   BY COMPUTING THE LU DECOMPOSITION WITH PARTIAL PIVOTING AND
!   IMPLICIT ROW SCALING OF MATRIX a WITH FUNCTION solve_lin.
!   ARGUMENTS a AND b ARE NOT MODIFIED BY THE FUNCTION.
!
    x2 = solve_lin( a, b )
!
!   STOP THE TIMER.
!
    call system_clock( count=iend )
!
    elapsed_time = real( iend - istart, stnd )/real( irate, stnd )
!
    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) = x2(: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, x2 )
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,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 ex2_solve_lin
! ============================
!
end program ex2_solve_lin

ex2_solve_llsq.F90

program ex2_solve_llsq
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of fonction SOLVE_LLSQ
!   in module LLSQ_Procedures . 
!                                                                              
! LATEST REVISION : 06/07/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, solve_llsq
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=100, m=1000, nrhs=10
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                    :: err
    real(stnd), dimension(m,nrhs) :: b, res
    real(stnd), dimension(n,nrhs) :: x
    real(stnd), dimension(m,n)    :: a
!   
!   
! PARAMETERS 
! ==========
!
    character(len=*), parameter :: name_proc='Example 2 of solve_llsq'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 2 : LINEAR LEAST SQUARES SYSTEM AND SEVERAL RIGHT HAND-SIDES.
!
!
!   GENERATE A RANDOM COEFFICIENT MATRIX a .
!
    call random_number( a )
!
!   GENERATE A RANDOM RIGHT HAND-SIDE MATRIX b .
!
    call random_number( b )
!
!   COMPUTE SOLUTION MATRIX FOR LINEAR LEAST SQUARES SYSTEM
!
!             a*x(:,:)=b(:,:) .
!
    x = solve_llsq( a, b )
!
!   CHECK THAT THE RESIDUALS ARE ORTHOGONAL TO THE COLUMN VECTORS OF a .
!
    res = b - matmul( a, x )
    err = maxval( sum(abs(matmul(transpose(a),res)), dim=1) )/ sum( abs(a) )
!
    if ( err<=sqrt(epsilon(err)) ) then
        write (prtunit,*) 'Example 2 of SOLVE_LLSQ is correct'
    else
        write (prtunit,*) 'Example 2 of SOLVE_LLSQ is incorrect'
    end if
!
!
! END OF PROGRAM ex2_solve_llsq
! =============================
!
end program ex2_solve_llsq

ex2_svd_cmp.F90

program ex2_svd_cmp
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SVD_CMP
!   in module SVD_Procedures .
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine BD_INVITER2 in module SVD_Procedures.
!                                                                              
! LATEST REVISION : 28/04/2015
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, zero, true, false, bd_inviter2, svd_cmp, &
                         norm, unit_matrix, c50, 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
!
    integer(i4b), parameter :: prtunit=6, n=1000, m=1000, mn=min(m,n)
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of svd_cmp'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, err3, eps, tmp, tmp2, &
                                               min_explnorm, elapsed_time
    real(stnd), allocatable, dimension(:)   :: s, d, e, tauq, taup
    real(stnd), allocatable, dimension(:,:) :: a, a2, leftvec, rightvec, resid
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: maxiter=2, nsing
!
    logical(lgl) :: failure1, failure2, do_test
!   
    character    :: sort='d'
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : ALL SINGULAR VALUES AND nsing SINGULAR VECTORS OF A n-BY-m REAL MATRIX
!               BY THE INVERSE ITERATION METHOD (eg PARTIAL SVD DECOMPOSITION). nsing
!               IS DETERMINED AS THE NUMBER OF SINGULAR TRIPLETS WHICH DESCRIBED AT LEAST
!               90% OF THE FROBENIUS NORM OF THE REAL MATRIX.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,m), s(mn), d(mn), e(mn), tauq(mn), taup(mn), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-BY-m RANDOM REAL MATRIX a.
!
    call random_number( a )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAY.
!
        allocate( a2(n,m), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       MAKE A COPY OF THE RANDOM DATA MATRIX .
!
        a2(:n,:m) = a(:n,:m)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL n-BY-m MATRIX a
!   IS WRITTEN
!
!                       a = U * S * V**(t)
!
!   WHERE s IS AN n-BY-m MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   min(m,n) DIAGONAL ELEMENTS, u IS AN n-BY-n ORTHOGONAL MATRIX, AND
!   v IS AN m-BY-m 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.
!
!   THIS PROGRAM ILLUSTRATES HOW TO COMPUTE ALL THE SINGULAR VALUES OF a AND
!   ONLY nsing LEFT AND RIGHT SINGULAR VECTORS OF a (EG A PARTIAL SVD DECOMPOSITION OF a)
!   IN TWO STEPS. nsing IS DETERMINED AS THE NUMBER OF SINGULAR TRIPLETS WHICH DESCRIBED
!   AT LEAST 90% OF THE FROBENIUS NORM OF a.
!
!   SEE EXAMPLE ex1_svd_cmp.f90, IF YOU WANT TO COMPUTE A FULL SVD OF a.  
!   THIS PROGRAM SHOWS HOW TO COMPUTE A PARTIAL SVD OF a WITH THE SUBROUTINES
!   svd_cmp AND bd_inviter2.
!
!   STEP1 : COMPUTE ALL SINGULAR VALUES OF a AND STORE INTERMEDIATE RESULTS WITH SUBROUTINE svd_cmp.
!
    call svd_cmp( a, s, failure=failure1, sort=sort, d=d, e=e, tauq=tauq, taup=taup  )
!
!   ON EXIT OF svd_cmp :
!
!   failure= false :  INDICATES SUCCESSFUL EXIT
!   failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                     THAT FULL ACCURACY WAS NOT ATTAINED IN THE BIDIAGONAL
!                     SVD OF AN INTERMEDIATE BIDIAGONAL FORM B OF a.
!
!   s IS OVERWRITTEN WITH THE SINGULAR VALUES OF a.
!
!   IF SORT = 'a' OR 'A', THE SINGULAR VALUES ARE SORTED INTO ASCENDING ORDER.
!   IF SORT = 'd' OR 'D', THE SINGULAR VALUES ARE SORTED INTO DESCENDING ORDER.
!   HERE, SORT = 'd' IS USED THIS IS REQUIRED FOR THE USE OF bd_inviter2 .
!                
!   IF THE PARAMETER v IS ABSENT, svd_cmp COMPUTES ONLY THE SINGULAR VALUES OF a             
!   AND, OPTIONALLY, STORES THE INTERMEDIATE BIDIAGONAL FORM OF a AND THE ORTHOGONAL
!   MATRICES USED TO REDUCE a TO BIDIAGONAL FORM.
!
!   THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN THE OPTIONAL ARGUMENTS d AND e.
!   THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM d_e ARE STORED 
!   IN mat, tauq, taup, WHEN THE OPTIONAL ARGUMENTS tauq AND taup ARE PRESENT.
!
!   NOW SELECT THE NUMBER OF SINGULAR TRIPLETS SUCH THAT THEY DESCRIBE AT LEAST 90%
!   OF THE NORM OF THE REAL MATRIX a.
!
    min_explnorm = 90._stnd
!
    tmp  = zero
    tmp2 = c100/sum( s(:mn)**2 )
!
    do nsing= 1_i4b, mn
!
        tmp = tmp + tmp2*s(nsing)**2
        if ( tmp>=min_explnorm ) exit
!
    end do
!
!   CHECK THE nsing VALUE.
!
    nsing = min( nsing, mn )
!
!   ALLOCATE WORK ARRAYS FOR THE SINGULAR VECTORS.
!
    allocate( leftvec(n,nsing), rightvec(m,nsing), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   STEP2 : COMPUTE THE FIRST nsing LEFT AND RIGHT SINGULAR VECTORS OF a BY maxiter
!   INVERSE ITERATIONS ON THE INTERMEDIATE BIDIAGONAL MATRIX
!   d_e AND BACK-TRANSFORMATION WITH SUBROUTINE bd_inviter2 .
!
    call bd_inviter2( a, tauq, taup, d, e, s(:nsing), leftvec, rightvec, failure=failure2, maxiter=maxiter )
!
!   ON ENTRY, PARAMETER s CONTAINS SELECTED SINGULAR VALUES OF THE BIDIAGONAL MATRIX d_e (OR a).
!   THE SINGULAR VALUES MUST BE GIVEN IN DECREASING ORDER.
!
!   ON EXIT OF bd_inviter2 :
!
!   failure= false :  INDICATES SUCCESSFUL EXIT.
!   failure= true  :  INDICATES THAT THE ALGORITHM FAILS TO CONVERGE.
!
!   THE SINGULAR VECTORS OF THE BIDIAGONAL FORM d_e ARE COMPUTED USING maxiter INVERSE ITERATIONS
!   FOR THE nsing SINGULAR VALUES AT ONE STEP. THE SINGULAR VECTORS OF d_e ARE THEN ORTHOGONALIZED BY 
!   THE MODIFIED GRAM-SCHMIDT ALGORITHM IF NECESSARY. THE SINGULAR VECTORS OF a ARE FINALLY COMPUTED 
!   BY BACK TRANSFORMATIONS. ON EXIT, leftvec AND rightvec CONTAIN THE FIRST nsing LEFT AND RIGHT
!   SINGULAR VECTORS OF a, RESPECTIVELY.
!
!   NOTE THAT bd_inviter2 MAY FAIL IF SOME THE SINGULAR VALUES SPECIFIED IN PARAMETER s ARE NEARLY
!   IDENTICAL.
!
!   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 ( do_test ) then
!
!       ALLOCATE WORK ARRAY.
!
        allocate( resid(n,nsing), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*V(:m,:nsing) - U(:n,:nsing)*S(:nsing,:nsing),
!       WHERE leftvec AND rightvec ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a.
!
        resid(:n,:nsing) = matmul(a2,rightvec) - leftvec*spread(s(:nsing),dim=1,ncopies=n)
        a2(:nsing,1_i4b) = norm( resid(:n,:nsing), dim=2_i4b )
        err1 = maxval( a2(:nsing,1_i4b) )/ ( sum( abs(s(:mn)) )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U(:n,:nsing)**(t)*U(:n,:nsing).
!
        call unit_matrix( a2(:nsing,:nsing) )
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(leftvec), leftvec ) )
        err2 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - V(:m,:nsing)**(t)*V(:m,:nsing).
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(rightvec), rightvec ) )
        err3 = maxval( resid(:nsing,:nsing) )/real(m,stnd)
!
        err = max( err1, err2, err3 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, a2, resid, leftvec, rightvec, s, d, e, tauq, taup )
!
    else
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, leftvec, rightvec, s, d, e, tauq, taup )
!
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. .not.failure1 .and. .not.failure2 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing all singular values and ', nsing, ' singular vectors of a', &
       n, ' by', m,' real matrix is', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_svd_cmp
! ==========================
!
end program ex2_svd_cmp

ex2_svd_cmp2.F90

program ex2_svd_cmp2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SVD_CMP2
!   in module SVD_Procedures .
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine BD_DEFLATE2 in module SVD_Procedures.
!                                                                              
! LATEST REVISION : 28/04/2015
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, zero, true, false, bd_deflate2, svd_cmp2, &
                         norm, unit_matrix, c50, 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
!
    integer(i4b), parameter :: prtunit=6, n=1000, m=1000, mn=min(m,n)
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of svd_cmp2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err, err1, err2, err3, eps, tmp, tmp2, &
                                               min_explnorm, elapsed_time
    real(stnd), allocatable, dimension(:)   :: s, d, e, tauq, taup
    real(stnd), allocatable, dimension(:,:) :: a, a2, leftvec, rightvec, resid
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: nsing, max_qr_steps
!
    logical(lgl) :: failure1, failure2, ortho, do_test
!   
    character    :: sort='d'
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : ALL SINGULAR VALUES AND nsing SINGULAR VECTORS OF A n-BY-m REAL MATRIX
!               BY A DEFLATION METHOD (eg PARTIAL SVD DECOMPOSITION).
!               nsing IS DETERMINED AS THE NUMBER OF SINGULAR TRIPLETS WHICH DESCRIBED
!               AT LEAST 90% OF THE FROBENIUS NORM OF THE REAL MATRIX.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,m), s(mn), d(mn), e(mn), tauq(mn), taup(mn), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A n-BY-m RANDOM REAL MATRIX a.
!
    call random_number( a )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAY.
!
        allocate( a2(n,m), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       MAKE A COPY OF THE RANDOM DATA MATRIX .
!
        a2(:n,:m) = a(:n,:m)
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   THE SINGULAR VALUE DECOMPOSITION (SVD) OF A REAL n-BY-m MATRIX a
!   IS WRITTEN
!
!                       a = U * S * V**(t)
!
!   WHERE s IS AN n-BY-m MATRIX WHICH IS ZERO EXCEPT FOR ITS
!   min(m,n) DIAGONAL ELEMENTS, u IS AN n-BY-n ORTHOGONAL MATRIX, AND
!   v IS AN m-BY-m 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.
!
!   THIS PROGRAM ILLUSTRATES HOW TO COMPUTE ALL THE SINGULAR VALUES OF a AND
!   ONLY nsing LEFT AND RIGHT SINGULAR VECTORS OF a (EG A PARTIAL SVD DECOMPOSITION OF a)
!   IN TWO STEPS. nsing IS DETERMINED AS THE NUMBER OF SINGULAR TRIPLETS WHICH DESCRIBED
!   AT LEAST 90% OF THE FROBENIUS NORM OF a.
!
!   SEE EXAMPLE ex1_svd_cmp2.f90, IF YOU WANT TO COMPUTE A FULL SVD OF a.  
!   THIS PROGRAM SHOWS HOW TO COMPUTE A PARTIAL SVD OF a WITH THE SUBROUTINES
!   svd_cmp2 AND bd_deflate2.
!
!   STEP1 : COMPUTE ALL SINGULAR VALUES OF a AND STORE INTERMEDIATE RESULTS WITH SUBROUTINE svd_cmp2.
!
    call svd_cmp2( a, s, failure=failure1, sort=sort, d=d, e=e, tauq=tauq, taup=taup  )
!
!   ON EXIT OF svd_cmp2 :
!
!   failure= false :  INDICATES SUCCESSFUL EXIT
!   failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                     THAT FULL ACCURACY WAS NOT ATTAINED IN THE BIDIAGONAL
!                     SVD OF AN INTERMEDIATE BIDIAGONAL FORM B OF a.
!
!   s IS OVERWRITTEN WITH THE SINGULAR VALUES OF a.
!
!   IF SORT = 'a' OR 'A', THE SINGULAR VALUES ARE SORTED INTO ASCENDING ORDER.
!   IF SORT = 'd' OR 'D', THE SINGULAR VALUES ARE SORTED INTO DESCENDING ORDER.
!   HERE, SORT = 'd' IS USED THIS IS REQUIRED FOR THE USE OF bd_deflate2 .
!                
!   IF THE PARAMETER u_vt IS ABSENT, svd_cmp2 COMPUTES ONLY THE SINGULAR VALUES OF a             
!   AND, OPTIONALLY, STORES THE INTERMEDIATE BIDIAGONAL FORM OF a AND THE ORTHOGONAL
!   MATRICES USED TO REDUCE a TO BIDIAGONAL FORM.
!
!   THE INTERMEDIATE BIDIAGONAL FORM OF a IS STORED IN THE OPTIONAL ARGUMENTS d AND e.
!   THE ORTHOGONAL MATRICES USED TO REDUCE a TO BIDIAGONAL FORM d_e ARE STORED 
!   IN mat, tauq, taup, WHEN THE OPTIONAL ARGUMENTS tauq AND taup ARE PRESENT.
!
!   NOW SELECT THE NUMBER OF SINGULAR TRIPLETS SUCH THAT THEY DESCRIBE AT LEAST 90%
!   OF THE NORM OF THE REAL MATRIX a.
!
    min_explnorm = 90._stnd
!
    tmp  = zero
    tmp2 = c100/sum( s(:mn)**2 )
!
    do nsing= 1_i4b, mn
!
        tmp = tmp + tmp2*s(nsing)**2
        if ( tmp>=min_explnorm ) exit
!
    end do
!
!   CHECK THE nsing VALUE.
!
    nsing = min( nsing, mn )
!
!   ALLOCATE WORK ARRAYS FOR THE SINGULAR VECTORS.
!
    allocate( leftvec(n,nsing), rightvec(m,nsing), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   STEP2 : COMPUTE THE FIRST nsing LEFT AND RIGHT SINGULAR VECTORS OF a BY A DEFLATION TECHNIQUE
!   ON THE INTERMEDIATE BIDIAGONAL MATRIX d_e AND BACK-TRANSFORMATION WITH SUBROUTINE bd_deflate2 .
!
    ortho = true
    max_qr_steps = 4_i4b
!
    call bd_deflate2( a(:n,:m), tauq(:mn), taup(:mn), d(:mn), e(:mn), s(:nsing),   &
                      leftvec(:n,:nsing), rightvec(:m,:nsing), failure=failure2,   &
                      ortho=ortho, max_qr_steps=max_qr_steps                       )
!
!   ON ENTRY, PARAMETER s CONTAINS SELECTED SINGULAR VALUES OF THE BIDIAGONAL MATRIX d_e (OR a).
!   THE SINGULAR VALUES MUST BE GIVEN IN DECREASING ORDER.
!
!   ON EXIT OF bd_deflate2 :
!
!   failure= false :  INDICATES SUCCESSFUL EXIT.
!   failure= true  :  INDICATES THAT MAXIMUM ACCURACY WAS NOT OBTAIN IN THE DEFLATION ALGORITHM.
!
!   THE SINGULAR VECTORS OF THE BIDIAGONAL FORM d_e CORRESPONDING TO THE nsing SINGULAR VALUES ARE
!   COMPUTED USING A DEFLATION TECHNIQUE. THE SINGULAR VECTORS OF a ARE FINALLY COMPUTED BY BACK
!   TRANSFORMATIONS.
!   ON EXIT, leftvec AND rightvec CONTAIN, RESPECTIVELY, THE nsing LEFT AND RIGHT SINGULAR VECTORS OF a,
!   ASSOCIATED WITH THE SINGULAR VALUES SPECIFIED IN s(:nsing).

!   bd_deflate2 MAY FAIL IF SOME THE SINGULAR VALUES SPECIFIED IN PARAMETER s ARE NEARLY
!   IDENTICAL.
!
!   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 ( do_test ) then
!
!       ALLOCATE WORK ARRAY.
!
        allocate( resid(n,nsing), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*V(:m,:nsing) - U(:n,:nsing)*S(:nsing,:nsing),
!       WHERE leftvec AND rightvec ARE THE LEFT AND RIGHT SINGULAR VECTORS OF a.
!
        resid(:n,:nsing) = matmul(a2,rightvec) - leftvec*spread(s(:nsing),dim=1,ncopies=n)
        a2(:nsing,1_i4b) = norm( resid(:n,:nsing), dim=2_i4b )
        err1 = maxval( a2(:nsing,1_i4b) )/ ( sum( abs(s(:mn)) )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U(:n,:nsing)**(t)*U(:n,:nsing).
!
        call unit_matrix( a2(:nsing,:nsing) )
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(leftvec), leftvec ) )
        err2 = maxval( resid(:nsing,:nsing) )/real(n,stnd)
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - V(:m,:nsing)**(t)*V(:m,:nsing).
!
        resid(:nsing,:nsing) = abs( a2(:nsing,:nsing) - matmul( transpose(rightvec), rightvec ) )
        err3 = maxval( resid(:nsing,:nsing) )/real(m,stnd)
!
        err = max( err1, err2, err3 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, a2, resid, leftvec, rightvec, s, d, e, tauq, taup )
!
    else
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, leftvec, rightvec, s, d, e, tauq, taup )
!
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. .not.failure1 .and. .not.failure2 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing all singular values and ', nsing, ' singular vectors of a', &
       n, ' by', m,' real matrix is', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_svd_cmp2
! ===========================
!
end program ex2_svd_cmp2

ex2_symtrid_bisect.F90

program ex2_symtrid_bisect
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SYMTRID_BISECT
!   in module Eig_Procedures .
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine TRID_DEFLATE in module EIG_Procedures.
!                                                                              
! LATEST REVISION : 08/05/2016
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, symtrid_cmp, symtrid_bisect, &
                         trid_deflate, lamch, 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
!
    integer(i4b), parameter :: prtunit=6, n=3000, neig=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of symtrid_bisect'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err, eps, abstol, elapsed_time
    real(stnd), allocatable, dimension(:)   :: eigval, resid2, d, e
    real(stnd), allocatable, dimension(:,:) :: a, eigvec, a2
!
    integer       :: iok, istart, iend, irate, imax, itime
    integer(i4b)  :: max_qr_steps, neig2
!
    logical(lgl)  :: failure1, failure2, do_test, ortho
!   
    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 2 : FIRST neig EIGENVALUES AND, OPTIONALLY, EIGENVECTORS OF
!               A REAL SYMMETRIC MATRIX USING BISECTION AND A DEFLATION METHOD
!               FOR THE EIGENVECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps    = fudge*epsilon( err )
    abstol = sqrt( lamch('s') )
    err    = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(n,n), eigvec(n,neig), eigval(n), d(n), e(n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A 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), resid2(neig), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       SAVE 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 )
!
!   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 TO TRIDIAGONAL FORM THE SELF-ADJOINT MATRIX a AND SAVE
!   THE INTERMEDIATE TRIDIAGONAL MATRIX IN PARAMETERS d AND e WITH
!   SUBROUTINE symtrid_cmp.
!
    call symtrid_cmp( a, d, e, store_q=true )
!
!   ON EXIT OF symtrid_cmp, THE UPPER TRIANGLE OF a IS OVERWRITTEN WITH THE HOUSEHOLDER TRANSFORMATIONS
!   USED TO REDUCE a TO TRIDIAGONAL FORM IF THE PARAMETER store_q IS PRESENT AND SET TO true, OTHERWISE
!   THE UPPER TRIANGLE OF a IS DESTROYED AND THE HOUSEHOLDER TRANSFORMATIONS ARE NOT SAVED.
!   PARAMETERS d AND e STORE, RESPECTIVELY, THE DIAGONAL AND THE OFF-DIAGONAL ELEMENTS OF THE
!   INTERMEDIATE TRIDIAGONAL FORM OF a .
!
!   NEXT, COMPUTE neig EIGENVALUES OF THE INTERMEDIATE TRIDIAGONAL MATRIX BY A BISECTION METHOD
!   WITH HIGH ACCURACY. THE EIGENVALUES ARE COMPUTED WITH MAXIMUM ACCURACY WHEN OPTIONAL PARAMETER
!   abstol IS SET TO sqrt( lamch('s') ), WHICH IS THE SQUARE ROOT OF THE UNDERFLOW THRESHOLD.
!
    call symtrid_bisect( d, e, neig2, eigval, failure=failure1, sort=sort, le=neig, abstol=abstol )
!
!   ON EXIT OF symtrid_bisect:
!
!       failure= false :  INDICATES SUCCESSFUL EXIT.
!       failure= true  :  INDICATES THAT THE ALGORITHM DID NOT CONVERGE AND
!                         THAT FULL ACCURACY WAS NOT ATTAINED IN THE BISECTION ALGORITHM. 
!                         APPLIED TO THE INTERMEDIATE TRIDIAGONAL FORM OF a.
!
!       eigval IS OVERWRITTEN WITH THE REQUESTED 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.
!
!   FINALLY, COMPUTE THE FIRST neig EIGENVECTORS OF THE SELF-ADJOINT MATRIX a BY A
!   DEFLATION TECHNIQUE APPLIED ON THE INTERMEDIATE TRIDIAGONAL MATRIX
!   d_e AND BACK-TRANSFORMATION.
!
!   ON ENTRY OF SUBROUTINE trid_deflate, PARAMETER eigval CONTAINS SELECTED
!   EIGENVALUES OF THE TRIDIAGONAL MATRIX.
!   THE EIGENVALUES VALUES MUST BE GIVEN IN DECREASING ORDER.
!
    ortho = false
    max_qr_steps = 4_i4b
!
    call trid_deflate( d(:n), e(:n), eigval(:neig), eigvec(:n,:neig), failure=failure2,     &
                       mat=a, ortho=ortho, max_qr_steps=max_qr_steps )
!
!   ON EXIT OF trid_deflate :
!
!       failure= false :  INDICATES SUCCESSFUL EXIT.
!       failure= true  :  INDICATES THAT MAXIMUM ACCURACY WAS NOT OBTAIN IN THE ALGORITHM.
!
!       eigvec CONTAINS THE neig EIGENVECTORS OF a ASSOCIATED WITH THE EIGENVALUES eigval(:neig).
!
!   trid_deflate MAY FAIL IF SOME THE EIGENVALUES SPECIFIED IN PARAMETER eigval ARE NEARLY
!   IDENTICAL AND IF THESE EIGENVALUES ARE NOT COMPUTED WITH HIGH ACCURACY.
!
!   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 ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*U - U*D
!
        a(:n,:neig) = matmul( a2, eigvec ) - eigvec*spread( eigval(:neig), 1, n )
        resid2(:neig) = norm( a(:n,:neig), dim=2_i4b )
        err1 =  maxval( resid2(:neig) )/( norm( a2 )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U.
!
        call unit_matrix( a(:neig,:neig) )
!
        a2(:neig,:neig) = abs( a(:neig,:neig) - matmul( transpose( eigvec ), eigvec ) )
        err2 = maxval(a2(:neig,:neig))/real(n,stnd)
!
        err = max( err1, err2 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, a2, eigvec, eigval, d, e, resid2 )
!
    else
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a, eigvec, eigval, d, e )
!
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. .not.failure1 .and. .not.failure2 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', neig, ' eigenvalues and eigenvectors of a ', &
       n, ' by ', n,' real symmetric matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_symtrid_bisect
! =================================
!
end program ex2_symtrid_bisect

ex2_symtrid_cmp.F90

program ex2_symtrid_cmp
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines SYMTRID_CMP and
!   ORTHO_GEN_SYMTRID in module EIG_Procedures .
!                                                                              
! LATEST REVISION : 28/05/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, symtrid_cmp,    &
                         ortho_gen_symtrid, triangle, 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
!
    integer(i4b), parameter :: prtunit=6, n=3000, p=n*(n+1)/2
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of symtrid_cmp'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err, eps, elapsed_time
    real(stnd), allocatable, dimension(:)   :: d, e, a_packed
    real(stnd), allocatable, dimension(:,:) :: a, q, resid, trid
!
    integer(i4b) :: l
!
    integer      :: 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 : TRIDIAGONAL REDUCTION OF A REAL SYMMETRIC
!   MATRIX STORED IN PACKED FORM.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a_packed(p), q(n,n), d(n), e(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) )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAY.
!
        allocate( a(n,n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       UNPACK AND SAVE RANDOM SELF-ADJOINT MATRIX a .
!
        a(:n,:n) = unpack( a_packed(:p), mask=triangle( true, n, n, extra=1_i4b), field=zero )
!
        do l = 1_i4b, n-1_i4b
             a(l+1_i4b:n,l) = a(l,l+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 )
!
!   CALL symtrid_cmp AND ortho_gen_symtrid_cmp TO REDUCE THE MATRIX a
!   IN PACKED FORM TO TRIDIAGONAL FORM
!
!                      a = Q*TRID*Q**(t)
!
!   WHERE Q IS ORTHOGONAL AND TRID IS A SYMMETRIC TRIDIAGONAL MATRIX.
!
!   ON ENTRY OF symtrid_cmp, a_packed MUST CONTAINS THE LEADING n-BY-n UPPER TRIANGULAR PART
!   OF THE MATRIX TO BE REDUCED IN PACKED FORMAT.
!
    call symtrid_cmp( a_packed(:p), d, e, store_q=true )
!
!   ON EXIT OF symtrid_cmp:
!
!         ARGUMENTS d AND e CONTAIN, RESPECTIVELY, THE DIAGONAL AND
!         OFF-DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX TRID.
!
!         IF THE OPTIONAL ARGUMENT store_q IS PRESENT AND SET TO TRUE,
!         THE LINEAR ARRAY a_packed IS OVERWRITTEN BY THE MATRIX Q
!         AS A PRODUCT OF ELEMENTARY REFLECTORS.
!
!   UNPACKED THE MATRIX IN ORDER TO GENERATE Q BY A CALL TO ortho_gen_symtrid.
!
    q(:n,:n) = unpack( a_packed(:p), mask=triangle( true, n, n, extra=1_i4b), field=zero )
!
!   ortho_gen_symtrid GENERATES THE MATRIX Q STORED AS A PRODUCT OF
!   ELEMENTARY REFLECTORS AFTER A CALL TO symtrid_cmp WITH store_q=true.
!
    call ortho_gen_symtrid( q )
!
!   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 ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( trid(n,n), resid(n,n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
!       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( a(:n,:n), q(:n,:n)  )           &
                       - matmul( q(:n,:n), trid(:n,:n) )
!
        trid(:n,1_i4b) = norm( resid(:n,:n), dim=2_i4b )
        err1 =  maxval( trid(:n,1_i4b) )/( norm( a )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - Q**(t)*Q.
!
        call unit_matrix( a(:n,:n) )
!
        resid(:n,:n) = abs( a(:n,:n) - matmul( transpose(q(:n,:n )), q(:n,:n) ) )
        err2 = maxval( resid(:n,:n) )/real(n,stnd)
!
        err = max( err1, err2 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a_packed, q, d, e, a, trid, resid )
!
    else
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a_packed, q, d, e )
!
    endif
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) 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,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing the tridiagonal reduction of a ', &
       n, ' by ', n,' real symmetric matrix in packed form is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_symtrid_cmp
! ==============================
!
end program ex2_symtrid_cmp

ex2_symtrid_cmp2.F90

program ex2_symtrid_cmp2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines SYMTRID_CMP2 and
!   ORTHO_GEN_SYMTRID in module EIG_Procedures.
!                                                                              
! LATEST REVISION : 10/09/2019
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, symtrid_cmp2, &
                         ortho_gen_symtrid, symtrid_qri2, 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 MATRIX USED
! TO COMPUTE THE MATRIX CROSS-PRODUCT, m MUST BE GREATER THAN n, OTHERWISE
! symtrid_cmp2 WILL STOP WITH AN ERROR MESSAGE.
!
    integer(i4b), parameter :: prtunit=6, m=3000, n=1000
!   
    real(stnd), parameter  :: fudge=c50
!
    character, parameter :: sort='d'
!
    character(len=*), parameter :: name_proc='Example 2 of symtrid_cmp2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err, eps, elapsed_time
    real(stnd), allocatable, dimension(:)   :: d, e
    real(stnd), allocatable, dimension(:,:) :: a, at, ata, resid
!
    integer :: iok, istart, iend, irate, imax, itime
!
    logical(lgl) :: do_test, failure
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 1 : EIGEN DECOMPOSITION OF A REAL SYMMETRIC MATRIX PRODUCT,
!               a**(t)*a, USING THE ONE-SIDED RALHA METHOD.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a(m,n), d(n), e(n), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A m-by-n RANDOM DATA MATRIX a .
!
    call random_number( a )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( ata(n,n), at(n,m), resid(n,n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
        at(:n,:m) = transpose( a(:m,:n) )
!
!       COMPUTE THE SYMMETRIC MATRIX CROSS-PRODUCT.
!
        ata(:n,:n) = matmul( at(:n,:m), a(:m,:n) )
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   CALL symtrid_cmp2 AND ortho_gen_symtrid TO REDUCE THE MATRIX CROSS-PRODUCT TO TRIDIAGONAL FORM
!
!                      a**(t)*a = Q*TRID*Q**(t)
!
!   WHERE Q IS ORTHOGONAL AND TRID IS A SYMMETRIC TRIDIAGONAL MATRIX.
!
!   ON ENTRY OF symtrid_cmp2, a MUST CONTAINS THE INITIAL m-by-n MATRIX USED
!   FOR COMPUTING THE MATRIX CROSS-PRODUCT. THE ORTHOGONAL MATRIX Q IS STORED
!   IN FACTORED FORM IF THE LOGICAL ARGUMENT store_q IS SET TO true.
!
    call symtrid_cmp2( a(:m,:n), d, e, store_q=true )
!
!   ON EXIT OF symtrid_cmp2:
!
!         ARGUMENTS d AND e CONTAIN, RESPECTIVELY, THE DIAGONAL AND
!         OFF-DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX TRID.
!
!         IF THE LOGICAL ARGUMENT store_q IS SET TO TRUE ON ENTRY,
!         THE LEADING n-BY-n LOWER TRIANGULAR PART OF a IS OVERWRITTEN
!         BY THE MATRIX Q AS A PRODUCT OF ELEMENTARY REFLECTORS.
!
!   ortho_gen_symtrid GENERATES THE MATRIX Q STORED AS A PRODUCT OF
!   ELEMENTARY REFLECTORS AFTER A CALL TO symtrid_cmp2 WITH store_q=true.
!
    call ortho_gen_symtrid( a(:n,:n), false )
!
!   COMPUTE EIGENDECOMPOSITION OF a**(t)*a WITH SUBROUTINE symtrid_qri2:
!
!                            a**(t)*a = U*D*U**(t)
!
!   WHERE U ARE THE EIGENVECTORS AND D IS THE DIAGONAL MATRIX, WITH
!   EIGENVALUES ON THE DIAGONAL.
!
    call symtrid_qri2( d(:n), e(:n), failure, a(:n,:n), sort=sort )
!
!   ON EXIT OF symtrid_qri2:
!
!         ARGUMENTS d AND a(:n:n) CONTAIN, RESPECTIVELY, THE EIGENVALUES AND
!         EIGENVECTORS OF a**(t)*a.
!
!   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 ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*U - U*D
!
        resid(:n,:n) = matmul( ata(:n,:n), a(:n,:n)  )    &
                       - a(:n,:n)*spread( d(:n), 1, n )
!
        e(:n) = norm( resid(:n,:n), dim=2_i4b )
        err1 =  maxval( e(:n) )/( norm( ata )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U.
!
        call unit_matrix( ata(:n,:n) )
!
        at(:n,:n) = transpose( a(:n,:n) )
!
        resid(:n,:n) = abs( ata(:n,:n) - matmul( at(:n,:n), a(:n,:n) ) )
        err2 = maxval( resid(:n,:n) )/real(n,stnd)
!
        err = max( err1, err2 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( ata, resid, at )
!
    endif
!
!   DEALLOCATE WORK ARRAYS.
!
    deallocate( a, d, e )
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) then
        write (prtunit,*) 
        write (prtunit,*) 'Accuracy of the computed eigendecomposition a**(t)*a = U*D*U**(t) = ', err1
        write (prtunit,*) 'Orthogonality of the computed eigenvectors U**(t)*U - I           = ', err2
    end if
!
    write (prtunit,*) 
    write (*,'(a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing the eigendecomposition of a ',       &
       n, ' by ', n,' real symmetric matrix product is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_symtrid_cmp2
! ===============================
!
end program ex2_symtrid_cmp2

ex2_symtrid_qri.F90

program ex2_symtrid_qri
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SYMTRID_QRI
!   in module Eig_Procedures.
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine TRID_INVITER in module Eig_Procedures.
!
! LATEST REVISION : 26/01/2021
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, one, two, c50,     &
                         trid_inviter, symtrid_qri, norm, unit_matrix 
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=4000, neig=2
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of symtrid_qri'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err, eps
    real(stnd), dimension(n)                :: d, e, e2, eigval
    real(stnd), dimension(n,neig)           :: eigvec
    real(stnd), allocatable, dimension(:,:) :: a, a2, resid
!
    integer      :: iok
    integer(i4b) :: maxiter=2, l
!
    logical(lgl) :: failure, do_test
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
!
    err = zero
    do_test = true
!
!   GENERATE A (1-2-1) TRIDIAGONAL MATRIX.
!   THE DIAGONAL ELEMENTS ARE STORED IN d .
!   THE OFF-DIAGONAL ELEMENTS ARE STORED IN e .
!
    call random_number( d(:n) )
    call random_number( e(:n) )
!
!    d(:n) = two
!    e(:n) = one
!
!   SAVE THE TRIDIAGONAL FORM .
!
    eigval(:n) = d(:n)
    e2(:n)     = e(:n)
!
!   COMPUTE EIGENVALUES OF THE TRIDIAGONAL MATRIX.
!
    call symtrid_qri( eigval(:n), e2(:n), failure, sort=sort )
!
    if ( .not.failure ) then
!
!       COMPUTE THE FIRST neig EIGENVECTORS OF THE (1-2-1) TRIDIAGONAL MATRIX BY maxiter INVERSE ITERATIONS.
!
        call trid_inviter( d(:n), e(:n), eigval(:neig), eigvec(:n,:neig), failure, maxiter=maxiter )
!
        if ( do_test ) then
!
            allocate( a(n,n), a2(neig,neig), resid(n,neig), stat=iok )
!
            if ( iok/=0 ) then
                write (prtunit,*)  'Problem in attempt to allocate memory !'
                stop
            end if
!
!           FORM THE TRIDIAGONAL MATRIX
!
            do l = 1_i4b, n-1_i4b
                a(l,l)       = d(l)
                a(l+1_i4b,l) = e(l)
                a(l,l+1_i4b) = e(l)
            end do
            a(n,n) = d(n)
!
!           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.
!
            resid = matmul( a, eigvec ) - eigvec*spread( eigval(:neig), 1, n )
            err1 = norm(resid)/( norm(a)*real(n,stnd) )
!
!           CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u**(t)*u
!           WHERE u are THE EIGENVECTORS OF THE TRIDIAGONAL MATRIX a.
!
            call unit_matrix( a2 )
!
            resid(:neig,:neig) = a2 - matmul( transpose( eigvec ), eigvec )
            err2 = norm(resid(:neig,:neig))/real(n,stnd)
!
            err = max( err1, err2 )
!
            deallocate( a, a2, resid )
!
        end if
!
    end if
!
    if ( err<=eps .and. .not.failure ) then
        write (prtunit,*) 'Example 2 of SYMTRID_QRI is correct'
    else
        write (prtunit,*) 'Example 2 of SYMTRID_QRI is incorrect'
    end if
!
!
! END OF PROGRAM ex2_symtrid_qri
! ==============================
!
end program ex2_symtrid_qri

ex2_symtrid_qri2.F90

program ex2_symtrid_qri2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine SYMTRID_QRI2
!   in module Eig_Procedures .
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine TRID_INVITER in module Eig_Procedures.
!
! LATEST REVISION : 22/07/2010
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, one, two, c50,     &
                         trid_inviter, symtrid_qri2, norm, unit_matrix 
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, n=4000, neig=2
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of symtrid_qri2'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err, eps
    real(stnd), dimension(n)                :: d, e, e2, eigval
    real(stnd), dimension(n,neig)           :: eigvec
    real(stnd), allocatable, dimension(:,:) :: a, a2, resid
!
    integer      :: iok
    integer(i4b) :: maxiter=2, l
!
    logical(lgl) :: failure, do_test
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
!
    err = zero
    do_test = true
!
!   GENERATE A (1-2-1) TRIDIAGONAL MATRIX.
!   THE DIAGONAL ELEMENTS ARE STORED IN d .
!   THE OFF-DIAGONAL ELEMENTS ARE STORED IN e .
!
    call random_number( d(:n) )
    call random_number( e(:n) )
!
!    d(:n) = two
!    e(:n) = one
!
!   SAVE THE TRIDIAGONAL FORM .
!
    eigval(:n) = d(:n)
    e2(:n)     = e(:n)
!
!   COMPUTE EIGENVALUES OF THE TRIDIAGONAL MATRIX.
!
    call symtrid_qri2( eigval(:n), e2(:n), failure, sort=sort )
!
    if ( .not. failure ) then
!
!       COMPUTE THE FIRST neig EIGENVECTORS OF THE (1-2-1) TRIDIAGONAL MATRIX BY maxiter INVERSE ITERATIONS.
!
        call trid_inviter( d(:n), e(:n), eigval(:neig), eigvec(:n,:neig), failure, maxiter=maxiter )
!
        if ( do_test ) then
!
            allocate( a(n,n), a2(neig,neig), resid(n,neig), stat=iok )
!
            if ( iok/=0 ) then
                write (prtunit,*)  'Problem in attempt to allocate memory !'
                stop
            end if
!
!           FORM THE TRIDIAGONAL MATRIX
!
            do l = 1_i4b, n-1_i4b
                a(l,l)       = d(l)
                a(l+1_i4b,l) = e(l)
                a(l,l+1_i4b) = e(l)
            end do
            a(n,n) = d(n)
!
!           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.
!
            resid = matmul( a, eigvec ) - eigvec*spread( eigval(:neig), 1, n )
            err1 = norm(resid)/( norm(a)*real(n,stnd) )
!
!           CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - u**(t)*u
!           WHERE u are THE EIGENVECTORS OF THE TRIDIAGONAL MATRIX a.
!
            call unit_matrix( a2 )
!
            resid(:neig,:neig) = a2 - matmul( transpose( eigvec ), eigvec )
            err2 = norm(resid(:neig,:neig))/real(n,stnd)
!
            err = max( err1, err2 )
!
            deallocate( a, a2, resid )
!
        end if
!
    end if
!
    if ( err<=eps .and. .not.failure ) then
        write (prtunit,*) 'Example 2 of SYMTRID_QRI2 is correct'
    else
        write (prtunit,*) 'Example 2 of SYMTRID_QRI2 is incorrect'
    end if
!
!
! END OF PROGRAM ex2_symtrid_qri2
! ===============================
!
end program ex2_symtrid_qri2

ex2_trid_deflate.F90

program ex2_trid_deflate
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine TRID_DEFLATE
!   in module Eig_Procedures .
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutines SYMTRID_CMP and SYMTRID_BISECT
!    in module EIG_Procedures.
!                                                                              
! LATEST REVISION : 23/05/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, lamch, triangle, trid_deflate,   &
                         symtrid_cmp, symtrid_bisect, 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
!
    integer(i4b), parameter :: prtunit=6, n=3000, p=(n*(n+1))/2, nvec=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of trid_deflate'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err, eps, safmin, abstol, elapsed_time
    real(stnd), allocatable, dimension(:,:) :: a, resid, eigvec
    real(stnd), allocatable, dimension(:)   :: a_packed, eigval, resid2, d, e
!
    integer       :: iok, istart, iend, irate, imax, itime
    integer(i4b)  :: max_qr_steps, i, neig
!
    logical(lgl)  :: failure, failure2, do_test, upper=true, ortho
!   
    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 2 : EIGENVALUES AND, OPTIONALLY, SELECTED EIGENVECTORS
!               OF A REAL SYMMETRIC MATRIX IN PACKED FORM USING A
!               DEFLATION METHOD.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    safmin = lamch( 'S' )
    abstol = sqrt( safmin )
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a_packed(p), eigvec(n,nvec), eigval(n), d(n), e(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,nvec), resid2(nvec), 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-1_i4b
             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 )
!
!   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 MATRIX (STORED IN PACKED FORM) TO SYMMETRIC TRIDIAGONAL
!   FORM BY ORTHOGONAL TRANSFORMATIONS WITH SUBROUTINE symtrid_cmp. THE ORTHOGONAL
!   TRANSFORMATIONS ARE SAVED IF THE OPTIONAL PARAMETER store_q IS SET TO TRUE.
!
    call symtrid_cmp( a_packed(:p), d(:n), e(:n), store_q=true )
!
!   ON EXIT OF symtrid_cmp:
!
!       a_packed IS OVERWRITTEN WITH THE HOUSEHOLDER TRANSFORMATIONS USED TO REDUCE a
!       TO TRIDIAGONAL FORM IF THE OPTIONAL PARAMETER store_q IS SET TO TRUE,
!       OTHERWISE a IS DESTROYED.
!
!       ARGUMENTS d and e CONTAIN, RESPECTIVELY THE DIAGONAL AND OFF-DIAGONAL
!       ELEMENTS OF THE TRIDIAGONAL MATRIX.
!
!   SECOND, COMPUTE ALL EIGENVALUES OF THE SELF-ADJOINT MATRIX a TO HIGH
!   ACCURACY WITH SUBROUTINE symtrid_bisect.
!
    call symtrid_bisect( d(:n), e(:n), neig, eigval(:n), failure, &
                         sort=sort, abstol=abstol )
!
!   ON EXIT OF symtrid_bisect:
!
!       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 AN INTERMEDIATE TRIDIAGONAL FORM TRID OF a.
!
!       eigval 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.
!
!   NEXT COMPUTE THE FIRST nvec EIGENVECTORS OF THE SELF-ADJOINT MATRIX a BY A
!   DEFLATION TECHNIQUE APPLIED ON THE INTERMEDIATE TRIDIAGONAL MATRIX
!   d_e AND BACK-TRANSFORMATION.
!
!   ON ENTRY OF SUBROUTINE trid_deflate, PARAMETER eigval CONTAINS SELECTED
!   EIGENVALUES OF THE TRIDIAGONAL MATRIX.
!   THE EIGENVALUES VALUES MUST BE GIVEN IN DECREASING ORDER.
!
    ortho = false
    max_qr_steps = 4_i4b
!
    call trid_deflate( d(:n), e(:n), eigval(:nvec), eigvec(:n,:nvec), failure=failure2,     &
                       matp=a_packed, ortho=ortho, max_qr_steps=max_qr_steps )
!
!   ON EXIT OF trid_deflate :
!
!       failure= false :  INDICATES SUCCESSFUL EXIT
!       failure= true  :  INDICATES THAT MAXIMUM ACCURACY WAS NOT OBTAIN IN THE ALGORITHM

!       eigvec CONTAINS THE nvec EIGENVECTORS OF a ASSOCIATED WITH THE EIGENVALUES eigval(:nvec).
!
!   trid_deflate MAY FAIL IF SOME THE EIGENVALUES SPECIFIED IN PARAMETER eigval ARE NEARLY
!   IDENTICAL AND IF THESE EIGENVALUES ARE NOT COMPUTED WITH HIGH ACCURACY.
!
!   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 ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*U - U*D
!
        resid(:n,:nvec) = matmul( a, eigvec ) - eigvec*spread( eigval(:nvec), 1, n )
        resid2(:nvec) = norm( resid(:n,:nvec), dim=2_i4b )
!
        err1 =  maxval( resid2(:nvec) )/( norm( a )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U.
!
        call unit_matrix( a(:nvec,:nvec) )
!
        resid(:nvec,:nvec) = abs( a(:nvec,:nvec) - matmul( transpose( eigvec ), eigvec ) )
!
        err2 = maxval(resid(:nvec,:nvec))/real(n,stnd)
!
        err = max( err1, err2 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a_packed, eigvec, eigval, d, e, a, resid, resid2 )
!
    else
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a_packed, eigvec, eigval, d, e )
!
    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
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing all eigenvalues and ', nvec, ' eigenvectors of a ', &
       n, ' by ', n,' real symmetric matrix in packed form is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_trid_deflate
! ===============================
!
end program ex2_trid_deflate

ex2_trid_inviter.F90

program ex2_trid_inviter
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine TRID_INVITER
!   in module Eig_Procedures .
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine EIGVAL_CMP in module EIG_Procedures.
!                                                                              
! LATEST REVISION : 08/05/2016
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, c50, triangle, trid_inviter,   &
                         eigval_cmp, 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
!
    integer(i4b), parameter :: prtunit=6, n=3000, p=(n*(n+1))/2, nvec=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 2 of trid_inviter'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err, eps, elapsed_time
    real(stnd), allocatable, dimension(:,:) :: a, resid, eigvec, d_e
    real(stnd), allocatable, dimension(:)   :: a_packed, eigval, resid2
!
    integer       :: iok, istart, iend, irate, imax, itime
    integer(i4b)  :: maxiter=2, i
!
    logical(lgl)  :: failure1, failure2, do_test, upper=true
!   
    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 2 : EIGENVALUES AND, OPTIONALLY, SELECTED EIGENVECTORS OF
!               A REAL SYMMETRIC MATRIX STORED IN PACKED FORM USING
!               THE INVERSE ITERATION METHOD.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    err = zero
!
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( a_packed(p), eigvec(n,nvec), eigval(n), d_e(n,2), 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,nvec), resid2(nvec), 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-1_i4b
             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 )
!
!   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, COMPUTE ALL EIGENVALUES OF THE SELF-ADJOINT MATRIX a IN PACKED FORM
!   AND SAVE THE INTERMEDIATE TRIDIAGONAL MATRIX IN PARAMETER d_e WITH
!   SUBROUTINE eigval_cmp.
!
    call eigval_cmp( a_packed, eigval, failure=failure1, sort=sort, d_e=d_e )
!
!   ON EXIT OF eigval_cmp:
!
!       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 AN INTERMEDIATE TRIDIAGONAL FORM TRID OF a.
!
!       a_packed IS OVERWRITTEN WITH THE HOUSEHOLDER TRANSFORMATIONS USED TO REDUCE a
!       TO TRIDIAGONAL FORM IF THE OPTIONAL PARAMETER d_e IS PRESENT, OTHERWISE
!       a_packed IS DESTROYED.
!
!       eigval 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.
!
!       d_e IS AN OPTIONAL ARGUMENT TO SAVE THE INTERMEDIATE TRIDIAGONAL FORM OF a.
!
!   NEXT COMPUTE THE FIRST nvec EIGENVECTORS OF THE SELF-ADJOINT MATRIX a BY
!   maxiter INVERSE ITERATIONS ON THE INTERMEDIATE TRIDIAGONAL MATRIX
!   d_e AND BACK-TRANSFORMATION.
!
    call trid_inviter( d_e(:n,1), d_e(:n,2), eigval(:nvec), eigvec(:n,:nvec), failure=failure2,   &
                       matp=a_packed, maxiter=maxiter )
!
!   ON EXIT OF trid_inviter :
!
!       failure= false :  INDICATES SUCCESSFUL EXIT
!       failure= true  :  INDICATES THAT MAXIMUM ACCURACY WAS NOT OBTAIN IN THE ALGORITHM

!       eigvec CONTAINS THE nvec EIGENVECTORS OF a ASSOCIATED WITH THE EIGENVALUES eigval(:nvec).
!
!   trid_inviter MAY FAIL IF SOME THE EIGENVALUES SPECIFIED IN PARAMETER eigval ARE NEARLY
!   IDENTICAL.
!
!   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 ( do_test ) then
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION a*U - U*D
!
        resid(:n,:nvec) = matmul( a, eigvec ) - eigvec*spread( eigval(:nvec), 1, n )
        resid2(:nvec) = norm( resid(:n,:nvec), dim=2_i4b )
!
        err1 =  maxval( resid2(:nvec) )/( norm( a )*real(n,stnd) )
!
!       CHECK FOR SMALL RESIDUALS OF THE EXPRESSION I - U**(t)*U.
!
        call unit_matrix( a(:nvec,:nvec) )
!
        resid(:nvec,:nvec) = abs( a(:nvec,:nvec) - matmul( transpose( eigvec ), eigvec ) )
!
        err2 = maxval(resid(:nvec,:nvec))/real(n,stnd)
!
        err = max( err1, err2 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a_packed, eigvec, eigval, d_e, a, resid, resid2 )
!
    else
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( a_packed, eigvec, eigval, d_e )
!
    end if
!
!   CHECK THE RESULTS FOR SMALL RESIDUALS.
!
    if ( err<=eps .and. .not.failure1 .and. .not.failure2 ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing all eigenvalues and ', nvec, ' eigenvectors of a ', &
       n, ' by ', n,' real symmetric matrix in packed form is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex2_trid_inviter
! ===============================
!
end program ex2_trid_inviter

ex3_llsq_qr_solve.F90

program ex3_llsq_qr_solve
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine LLSQ_QR_SOLVE
!   in modules LLSQ_Procedures .
!                                                                              
! LATEST REVISION : 25/07/2014
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, llsq_qr_solve
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, m=1000, nb=10
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                  :: err
    real(stnd), dimension(m)    :: a
    real(stnd), dimension(m,nb) :: resid, b
    real(stnd), dimension(nb)   :: x
!
    character(len=*), parameter :: name_proc='Example 3 of llsq_qr_solve'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A RANDOM COEFFICIENT VECTOR a .
!
    call random_number( a )
!
!   GENERATE A RANDOM RIGHT HAND-SIDE MATRIX b .
!
    call random_number( b )
!
!   EXAMPLE 3 : LINEAR LEAST SQUARES SYSTEM.
!
!   COMPUTE SOLUTION VECTOR FOR LINEAR LEAST SQUARES SYSTEM
!
!           a(:m)*x(:nb)=b(:m,:nb) .
!
!
    call llsq_qr_solve( a(:m), b(:m,:nb), x(:nb), resid=resid(:m,:nb) )
!
!   llsq_qr_solve COMPUTES SOLUTION(S) TO REAL LINEAR LEAST SQUARES PROBLEMS 
!   OF THE FORM:
!
!                       Minimize 2-norm(| b - a*x |)
!
!   USING AN ORTHOGONAL FACTORIZATION WITH COLUMNS PIVOTING OF a. a IS A m VECTOR
!   OR AN m-BY-n MATRIX WHICH MAY BE RANK-DEFICIENT. IF a IS A MATRIX, m>=n OR
!   n>m IS PERMITTED.
!
!   SEVERAL RIGHT HAND SIDE VECTORS b AND SOLUTION VECTORS x CAN BE
!   HANDLED IN A SINGLE CALL; THEY ARE STORED AS THE COLUMNS OF THE
!   m-BY-nb RIGHT HAND SIDE MATRIX b AND THE n-BY-nb SOLUTION
!   MATRIX x, RESPECTIVELY. IN OTHER WORDS, THE ARGUMENTS b AND x MAY
!   BE VECTORS OR MATRICES.
!
!   a AND b ARE NOT OVERWRITTEN BY llsq_qr_solve. THE OPTIONAL ARGUMENTS krank,
!   tol AND min_norm MUST NOT BE PRESENT IF a IS A m-VECTOR.
!
!   ON INPUT, IF THE OPTIONAL PARAMETER krank IS SPECIFIED AND IF krank=k,
!   THIS IMPLIES THAT THE FIRST k COLUMNS OF a ARE TO BE FORCED INTO THE BASIS.
!   PIVOTING IS PERFORMED ON THE LAST n-k COLUMNS OF a.
!   
!   WHEN krank>=min(m,n) IS USED, PIVOTING IS NOT PERFORMED. THIS IS
!   APPROPRIATE WHEN a IS KNOWN TO BE FULL RANK. krank<=0 CAN BE USED
!   WHEN PIVOTING IS DESIRED ON ALL COLUMNS OF a.
!   
!   BY DEFAULT, PIVOTING IS DONE ON ALL THE COLUMNS OF a.
!   
!   ON EXIT, IF THE OPTIONAL PARAMETER krank IS SPECIFIED,
!   krank CONTAINS THE EFFECTIVE RANK OF a. I.E., THE NUMBER
!   OF INDEPENDENT COLUMNS IN MATRIX a.
!                      
!   IF tol IS PRESENT AND IS IN [0,1[, THEN :
!       ON ENTRY, SPECIFIC CALCULATIONS TO DETERMINE THE EFFECTIVE RANK a
!       ARE PERFORMED. tol IS USED TO DETERMINE THE EFFECTIVE RANK
!       OF a, WHICH IS THEN DEFINED AS THE ORDER OF THE LARGEST LEADING
!       TRIANGULAR SUBMATRIX r11 IN THE QR FACTORIZATION WITH PIVOTING OF a,
!       WHOSE ESTIMATED CONDITION NUMBER IN THE 1-NORM IS LESS THAN 1/tol.
!       IF tol=0 IS SPECIFIED THE NUMERICAL RANK OF a IS DETERMINED.
!       ON EXIT, THE RECIPROCAL OF THE CONDITION NUMBER IS RETURNED IN tol.
!
!   IF tol IS NOT SPECIFIED OR IS OUTSIDE [0,1[ :
!       THE CALCULATIONS TO DETERMINE THE EFFECTIVE RANK OF a ARE NOT
!       PERFORMED AND CRUDE TESTS ON r(j,j) ARE DONE TO DETERMINE
!       THE NUMERICAL RANK OF a.
!
!   IF IT IS POSSIBLE THAT a MAY NOT BE FULL RANK (I.E., CERTAIN COLUMNS OF a ARE
!   LINEAR COMBINATIONS OF OTHER COLUMNS), THEN THE LINEARLY DEPENDENT COLUMNS CAN
!   USUALLY BE DETERMINED BY USING krank=0  AND tol=RELATIVE PRECISION OF THE ELEMENTS
!   IN a. IF EACH ELEMENT IS CORRECT TO, SAY, 5 DIGITS THEN tol=0.00001 SHOULD
!   BE USED. ALSO, IT MAY BE HELPFUL TO SCALE THE COLUMNS OF a SO THAT ALL ELEMENTS 
!   ARE ABOUT THE SAME ORDER OF MAGNITUDE.
!   
!   ON EXIT, IF THE OPTIONAL PARAMETER resid IS PRESENT,
!   THE RESIDUAL VECTOR OR MATRIX b - a*x is COMPUTED AND
!
!                               resid = b - a*x .
!
!   THE 2-NORM OF THE RESIDUAL VECTOR(S) FOR THE SOLUTION VECTOR(S) x, CAN ALSO BE COMPUTED
!   DIRECTLY BY SPECIFYING THE OPTIONAL PARAMETER rnorm IN THE CALL OF llsq_qr_solve .
!
!   THE MINIMUN 2-NORM SOLUTION(S) ARE COMPUTED IF THE OPTIONAL LOGICAL PARAMETER min_norm IS
!   PRESENT AND IS SET TO true. OTHERWISE, SOLUTION(S) ARE COMPUTED SUCH THAT IF THE jTH COLUMN
!   OF a IS OMITTED FROM THE BASIS, x[j] OR x[j,:nb] IS SET TO ZERO.
!
!
!   CHECK THAT THE RESIDUALS ARE ORTHOGONAL TO THE COEFFICIENT VECTOR a .
!
    err = maxval( abs( matmul( a, resid ) ) )/ sum( abs(a) )
!
!   PRINT THE RESULT OF THE TEST.
!
    if ( err<=sqrt(epsilon(err)) ) then
        write (prtunit,*) 'Example 3 of LLSQ_QR_SOLVE is correct'
    else
        write (prtunit,*) 'Example 3 of LLSQ_QR_SOLVE is incorrect'
    end if
!
!
! END OF PROGRAM ex1_llsq_qr_solve
! ================================
!
end program ex3_llsq_qr_solve

ex3_qr_cmp2.F90

program ex3_qr_cmp2
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutines QR_CMP2 and QR_SOLVE2
!   in modules QR_Procedures and LLSQ_Procedures .
!                                                                              
! LATEST REVISION : 06/07/2006
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : i4b, stnd, true, qr_cmp2, qr_solve2
#ifdef _MATMUL
    use Statpack, only : matmul=>matmul2
#endif
!   
!
! STRONG TYPING IMPOSED 
! =====================
!    
    implicit none
!   
!   
! PARAMETERS 
! ==========
!
! prtunit IS THE PRINTING UNIT
!
    integer(i4b), parameter :: prtunit=6, m=1000, n=500, k=min(m,n)
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                 :: err, tol
    real(stnd), dimension(m,n) :: a, a2
    real(stnd), dimension(n)   :: x, diagr, beta
    real(stnd), dimension(m)   :: b
    real(stnd), dimension(k)   :: tau
!
    integer(i4b)               :: krank
    integer(i4b), dimension(n) :: ip
!
    character(len=*), parameter :: name_proc='Example 3 of qr_cmp2'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!
!   PRINT LABEL OF THE EXAMPLE.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   GENERATE A RANDOM COEFFICIENT MATRIX a .
!
    call random_number( a )
!
!   GENERATE A DEFICIENT COEFFICIENT MATRIX a(:m,:n) .
!
    a(:m,5) = a(:m,10) + a(:m,11)
!
!   GENERATE A RANDOM RIGHT HAND-SIDE VECTOR b .
!
    call random_number( b )
!
!   MAKE A COPY OF COEFFICIENT MATRIX a(:m,:n) .
!
    a2(:m,:n) = a(:m,:n)
!
!   EXAMPLE 3 : LINEAR LEAST SQUARES SYSTEM WITH A MINIMAL 2-NORM SOLUTION.
!
!   COMPUTE MINIMAL 2-NORM SOLUTION VECTOR FOR LINEAR LEAST SQUARES SYSTEM
!
!                          a(:m,:n)*x(:n)=b(:m) .
!
!
!   SET TOLERANCE .
!
    tol = 0.00001_stnd
!
    krank = 0
!
!   COMPUTE COMPLETE QR DECOMPOSITION OF RANDOM DATA MATRIX a .
!
    call qr_cmp2( a2(:m,:n), diagr(:n), beta(:n), ip(:n), krank,    &
                  tol=tol, tau=tau(:k) )
!
!   qr_cmp2 COMPUTES A (COMPLETE) ORTHOGONAL FACTORIZATION OF A REAL m-BY-n MATRIX
!   a . a MAY BE RANK-DEFICIENT. THE ROUTINE FIRST COMPUTES A QR FACTORIZATION
!   WITH COLUMN PIVOTING OF a :
!
!                     a * p = q * r = q * [ r11 r12 ]
!                                         [  0  r22 ]
!
!   WITH r11 DEFINED AS THE LARGEST LEADING SUBMATRIX WHOSE ESTIMATED CONDITION
!   NUMBER, IN THE 1-NORM, IS LESS THAN 1/tol OR SUCH THAT ABS(r11[j,j])>0 IF 
!   tol IS ABSENT. THE ORDER OF r11, krank, IS THE EFFECTIVE RANK OF a. 
!
!   ON INPUT, krank=k, IMPLIES THAT THE FIRST k COLUMNS OF A ARE
!   TO BE FORCED INTO THE BASIS. PIVOTING IS PERFORMED ON THE LAST n-k
!   COLUMNS OF a.
!   WHEN krank>=min(m,n) IS USED, PIVOTING IS NOT PERFORMED. THIS IS
!   APPROPRIATE WHEN a IS KNOWN TO BE FULL RANK. krank<=0 CAN BE USED
!   WHEN PIVOTING IS DESIRED ON ALL COLUMNS OF a.
!   
!   IF THE OPTIONAL PARAMETER tau IS PRESENT, THEN r22 IS CONSIDERED TO BE NEGLIGIBLE
!   AND r12 IS ANNIHILATED BY ORTHOGONAL TRANSFORMATIONS FROM THE RIGHT,
!   ARRIVING AT THE COMPLETE ORTHOGONAL FACTORIZATION:
!  
!                     a * p = q * [ t11 0 ] * z
!                                 [  0  0 ]
!   
!   p IS A n-BY-n PERMUTATION MATRIX, q IS A m-BY-m ORTHOGONAL MATRIX,
!   r IS A m-BY-n UPPER TRIANGULAR MATRIX, t11 IS A krank-BY-krank UPPER
!   TRIANGULAR MATRIX AND z IS A n-BY-n ORTHOGONAL MATRIX.
!
!   ON EXIT, a HAS BEEN OVERWRITTEN BY DETAILS OF ITS (COMPLETE) 
!   ORTHOGONAL FACTORIZATION. 
!
!   THE MATRIX q IS REPRESENTED AS A PRODUCT OF ELEMENTARY REFLECTORS
!
!            q = h(1)*h(2)* ... *h(k), WHERE k = min( size(a,1) , size(a,2) )
!
!   EACH h(i) HAS THE FORM
!
!            h(i) = I + BETA * ( V * V' ) ,
!                      
!   WHERE BETA IS A REAL SCALAR AND V IS A REAL M-ELEMENT VECTOR WITH V(1:i-1) = 0.
!   V(i:m) IS STORED ON EXIT IN a(i:m,i) AND BETA IN beta(i).
!                      
!   IF THE OPTIONAL PARAMETER tau IS ABSENT :         
!                      
!      qr_cmp2 COMPUTES ONLY A QR FACTORIZATION WITH COLUMN PIVOTING OF a.
!                      
!      THE ELEMENTS ABOVE THE DIAGONAL OF THE ARRAY a CONTAIN THE
!      CORRESPONDING ELEMENTS OF THE TRIANGULAR MATRIX r. THE ELEMENTS
!      OF THE DIAGONAL OF r ARE STORED IN THE ARRAY diagr. 
!
!      ON EXIT, IF ip(j)=k, THEN THE jTH COLUMN OF a*p WAS 
!      THE kTH COLUMN OF a. THE MATRIX p IS REPRESENTED IN THE ARRAY 
!      ip AS FOLLOWS: IF ip(j) = i THEN THE jTH COLUMN OF p IS 
!      THE iTH CANONICAL UNIT VECTOR.
!                      
!      ON EXIT, krank CONTAINS THE EFFECTIVE RANK OF a, I.E., THE ORDER OF
!      THE SUBMATRIX r11.
!                      
!   IF THE OPTIONAL PARAMETER tau IS PRESENT :         
!                      
!      qr_cmp2 COMPUTES A COMPLETE ORTHOGONAL FACTORIZATION OF a FROM THE QR 
!      FACTORIZATION WITH COLUMN PIVOTING OF a .
!                      
!      THE FACTORIZATION IS OBTAINED BY HOUSEHOLDER'S METHOD. THE kTH TRANSFORMATION
!      MATRIX, z(k), WHICH IS USED TO INTRODUCE ZEROS INTO THE kTH ROW OF r,
!      IS GIVEN IN THE FORM
!
!             z(k) = ( I    0  ),
!                    ( 0  T(k) )
!
!      WHERE
!
!             T(k) = I + TAU * ( U(k) * U(k)' ) , U(k) = (   1  )
!                                                        (   0  )
!                                                        ( L(k) )
!
!      TAU IS A SCALAR AND L(k) IS AN (n-krank) ELEMENT VECTOR. TAU and L(k) ARE CHOSEN
!      TO ANNIHILATE THE ELEMENTS OF THE kTH ROW OF r12.
!
!      ON EXIT, THE SCALAR TAU IS RETURNED IN THE kTH ELEMENT OF tau AND THE VECTOR U(K)
!      IN THE kTH ROW OF a, SUCH THAT THE ELEMENTS OF L(k) ARE IN a(k,krank+1:n).
!
!      THE z n-BY-n ORTHOGONAL MATRIX WHICH IS APPLIED FROM THE RIGHT TO R IS 
!      GIVEN BY THE PRODUCT
!
!             z = z(1) * z(2) * ... * z(krank)
!
!      ON EXIT, THE ELEMENTS ABOVE THE DIAGONAL OF THE ARRAY SECTION a(1:krank,1:krank)
!      CONTAIN THE CORRESPONDING ELEMENTS OF THE TRIANGULAR MATRIX t11. THE ELEMENTS OF
!      THE DIAGONAL OF t11 ARE STORED IN THE ARRAY SECTION diagr(1:krank).
!                      
!      ON EXIT, IF ip(j)=k, THEN THE jTH COLUMN OF a*p WAS 
!      THE kTH COLUMN OF a. THE MATRIX p IS REPRESENTED IN THE ARRAY 
!      ip AS FOLLOWS: IF ip(j) = i THEN THE jTH COLUMN OF p IS 
!      THE iTH CANONICAL UNIT VECTOR.
!                      
!      ON EXIT, krank CONTAINS THE EFFECTIVE RANK OF a, I.E., THE ORDER OF
!      THE SUBMATRIX t11.
!                      
!   IF tol IS PRESENT AND IS IN [0,1[, THEN :
!       ON ENTRY, THE CALCULATIONS TO DETERMINE THE CONDITION NUMBER OF a
!       ARE PERFORMED. THEN, tol IS USED TO DETERMINE THE EFFECTIVE RANK
!       OF a, WHICH IS DEFINED AS THE ORDER OF THE LARGEST LEADING
!       TRIANGULAR SUBMATRIX r11 IN THE QR FACTORIZATION WITH PIVOTING OF a,
!       WHOSE ESTIMATED CONDITION NUMBER IS LESS THAN 1/tol. IF tol=0 IS SPECIFIED
!       THE NUMERICAL RANK OF a IS DETERMINED.
!       ON EXIT, THE RECIPROCAL OF THE CONDITION NUMBER IS RETURNED IN tol.
!
!   IF tol IS NOT SPECIFIED OR IS OUTSIDE [0,1[ :
!       THE CALCULATIONS TO DETERMINE THE CONDITION NUMBER OF a ARE NOT
!       PERFORMED AND CRUDE TESTS ON r(j,j) ARE DONE TO DETERMINE
!       THE NUMERICAL RANK OF a.
!
!   IF IT IS POSSIBLE THAT a MAY NOT BE FULL RANK (I.E., CERTAIN COLUMNS OF a ARE
!   LINEAR COMBINATIONS OF OTHER COLUMNS), THEN THE LINEARLY DEPENDENT COLUMNS CAN
!   USUALLY BE DETERMINED BY USING krank=0  AND tol=RELATIVE PRECISION OF THE ELEMENTS
!   IN a. IF EACH ELEMENT IS CORRECT TO, SAY, 5 DIGITS THEN tol=0.00001 SHOULD
!   BE USED. ALSO, IT MAY BE HELPFUL TO SCALE THE COLUMNS OF a SO THAT ALL ELEMENTS 
!   ARE ABOUT THE SAME ORDER OF MAGNITUDE.
!
!
!   NOW, COMPUTE  MINIMAL 2-NORM SOLUTION VECTOR AND RESIDUAL VECTOR
!   FOR LINEAR LEAST SQUARES SYSTEM
!
!                     a(:m,:n)*x(:n)=b(:m) .
!
    call qr_solve2( a2(:m,:n), diagr(:n), beta(:n), ip(:n), krank, b(:m), x(:n),    &
                    comp_resid=true, tau=tau(:k) )
!
!   qr_solve2 SOLVES OVERDETERMINED OR UNDERDETERMINED REAL LINEAR SYSTEMS
!
!                               a*x = b          
!
!   WITH AN m-BY-n MATRIX a, USING A (COMPLETE) ORTHOGONAL FACTORIZATION OF a, AS 
!   COMPUTED BY qr_cmp2. m>=n OR n>m IS PERMITTED AND a MAY BE RANK-DEFICIENT.
!
!   b IS A m RIGHT HAND SIDE VECTOR AND x IS A n SOLUTION VECTOR. SEVERAL RIGHT
!   HAND SIDES AND SOLUTION VECTORS MAY BE HANDLE IN A SINGLE CALL. IN THIS CASE,
!   b IS AN m-BY-l MATRIX AND x is AN n-BY-l MATRIX.
!   
!   IT IS ASSUMED THAT qr_cmp2  HAS BEEN USED TO COMPUTE THE (COMPLETE) ORTHOGONAL 
!   FACTORIZATION OF a BEFORE qr_solve2.
!
!   ON EXIT, IF comp_resid IS PRESENT AND IS EQUAL TO true,
!   THE RESIDUAL VECTOR b - a*x OVERWRITES b.
!
!   THE 2-NORM OF THE RESIDUAL VECTOR FOR THE SOLUTION VECTOR x, CAN ALSO BE COMPUTED
!   DIRECTLY BY SPECIFYING THE OPTIONAL REAL PARAMETER rnorm IN THE CALL OF qr_solve2 .
!
!   THE MINIMUN 2-NORM SOLUTION IS COMPUTED IF THE OPTIONAL PARAMETER tau IS PRESENT.
!   OTHERWISE, A SOLUTION IS COMPUTED SUCH THAT IF THE jTH COLUMN OF a
!   IS OMITTED FROM THE BASIS, x[j] IS SET TO ZERO.
!
!
!   CHECK THAT THE RESIDUALS ARE ORTHOGONAL TO THE COLUMN VECTORS OF a .
!
    err = sum( abs( matmul( b, a ) ) )/ sum( abs(a) )
!
!   PRINT THE RESULT OF THE TEST.
!
    if ( err<=sqrt(epsilon(err)) ) then
        write (prtunit,*) 'Example 3 of QR_CMP2 is correct'
    else
        write (prtunit,*) 'Example 23 of QR_CMP2 is incorrect'
    end if
!
!
!
! END OF PROGRAM ex3_qr_cmp2
! ==========================
!
end program ex3_qr_cmp2

ex3_trid_deflate.F90

program ex3_trid_deflate
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine TRID_DEFLATE
!   in module Eig_Procedures .
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine SYMTRID_BISECT in module Eig_Procedures.
!
! LATEST REVISION : 23/05/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, one, two, c50, unit_matrix,          &
                         lamch, trid_deflate, symtrid_bisect, 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
!
    integer(i4b), parameter :: prtunit=6, n=3000, neig=3000
!
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 3 of trid_deflate'
!   
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err, eps, abstol, &
                                               normr, normt, elapsed_time
    real(stnd), allocatable, dimension(:)   :: d, e, eigval, temp, temp2
    real(stnd), allocatable, dimension(:,:) :: resid, eigvec
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: neig2, j, max_qr_steps
!
    logical(lgl) :: failure, do_test, ortho
!   
    character    :: sort='d'
!   
!
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 3 : SELECTED EIGENVALUES AND EIGENVECTORS OF
!               A REAL SYMMETRIC TRIDIAGONAL MATRIX USING
!               BISECTION AND DEFLATION METHODS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    abstol = sqrt( lamch('s') )
!
    err = zero
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( d(n), e(n), eigval(n), eigvec(n,neig), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   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) = 0.5_stnd
!    e(:n) = 0.5_stnd
!
!   GENERATE A RANDOM TRIDIAGONAL MATRIX.
!
    call random_number( d(:n) )
    call random_number( e(:n) )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( resid(n,neig), temp(n), temp2(n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   COMPUTE THE FIRST neig EIGENVALUES OF THE TRIDIAGONAL MATRIX TO HIGH ACCURACY BY BISECTION
!   WITH SUBROUTINE symtrid_bisect.
!
    call symtrid_bisect( d, e, neig2, eigval, failure, sort=sort, le=neig, abstol=abstol )
!
!   ON EXIT OF symtrid_bisect:
!
!       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 TRIDIAGONAL MATRIX.
!
!       eigval IS OVERWRITTEN WITH THE EIGENVALUES OF THE TRIDIAGONAL MATRIX.
!       IF SORT = 'a' OR 'A', THE EIGENVALUES ARE SORTED INTO ASCENDING ORDER.
!       IF SORT = 'd' OR 'D', THE EIGENVALUES ARE SORTED INTO DESCENDING ORDER.
!
    if ( .not. failure ) then
!
!       COMPUTE THE FIRST neig EIGENVECTORS OF THE TRIDIAGONAL MATRIX BY A
!       DEFLATION TECHNIQUE WITH SUBROUTINE trid_deflate.
!
!       ON ENTRY, PARAMETER eigval CONTAINS SELECTED EIGENVALUES OF THE TRIDIAGONAL MATRIX.
!       THE EIGENVALUES VALUES MUST BE GIVEN IN DECREASING ORDER.
!
        ortho = false
        max_qr_steps = 4_i4b
!
        call trid_deflate( d(:n), e(:n), eigval(:neig), eigvec(:n,:neig), failure,   &
                           ortho=ortho, max_qr_steps=max_qr_steps )
!
!       ON EXIT OF trid_deflate :
!
!       failure= false :  INDICATES SUCCESSFUL EXIT
!       failure= true  :  INDICATES THAT MAXIMUM ACCURACY WAS NOT OBTAIN IN THE ALGORITHM

!       eigvec CONTAINS THE neig EIGENVECTORS ASSOCIATED WITH THE EIGENVALUES eigval(:neig).
!
!       trid_deflate MAY FAIL IF SOME THE EIGENVALUES SPECIFIED IN PARAMETER eigval ARE NEARLY
!       IDENTICAL AND IF THESE EIGENVALUES ARE NOT COMPUTED WITH HIGH ACCURACY.
!
    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 ( 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.
!
        do j=1_i4b, neig
!
            temp(1_i4b:n) = eigvec(1_i4b:n,j)
!
            temp2(1_i4b)         = d(1_i4b)*temp(1_i4b) + e(1_i4b)*temp(2_i4b)
            temp2(2_i4b:n-1_i4b) = e(1_i4b:n-2_i4b)*temp(1_i4b:n-2_i4b)           +   &
                                   d(2_i4b:n-1_i4b)*temp(2_i4b:n-1_i4b)           +   &
                                   e(2_i4b:n-1_i4b)*temp(3_i4b:n)
            temp2(n)             = e(n-1_i4b)*temp(n-1_i4b) + d(n)*temp(n)
!
            resid(1_i4b:n,j) = temp2(1_i4b:n) - eigval(j)*temp(1_i4b:n)
!
        end do
!
        temp(:neig) = norm( resid(:n,:neig), dim=2_i4b )
!
        normr = maxval( temp(:neig) )
        normt = sqrt( sum( d(1_i4b:n)**2 ) + sum( e(1_i4b:n-1_i4b)**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 a.
!
        call unit_matrix( resid(:neig,:neig) )
!
        resid(:neig,:neig) = abs( resid(:neig,:neig) - matmul( transpose( eigvec ), eigvec ) )
!
        normr = maxval( resid(:neig,:neig) )
!
        err2  = normr/real(n,stnd)
!
        err = max( err1, err2 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( d, e, eigval, eigvec, resid, temp, temp2 )
!
    else
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( d, e, eigval, eigvec )
!
    end if
!
    if ( err<=eps .and. .not.failure ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', neig,' eigenvalues and eigenvectors of a ', &
       n, ' by ', n,' real symmetric tridiagonal matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex3_trid_deflate
! ===============================
!
end program ex3_trid_deflate

ex3_trid_inviter.F90

program ex3_trid_inviter
!
!
! Purpose
! =======
!
!   This program is intended to demonstrate the use of subroutine TRID_INVITER
!   in module EIG_Procedures .
!                                                                              
!                                                     
! Further Details
! ===============
!
!    The program also shows the use of subroutine SYMTRID_BISECT in module EIG_Procedures.
!
! LATEST REVISION : 23/05/2017
!                                                                              
! ================================================================================================
!
!
! USED MODULES 
! ============
!
    use Statpack, only : lgl, i4b, stnd, true, false, zero, half, one, two, c50, trid_inviter,    &
                         symtrid_bisect, unit_matrix, norm, lamch, 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
!
    integer(i4b), parameter :: prtunit=6, n=3000, neig=3000
!   
    real(stnd), parameter  :: fudge=c50
!
    character(len=*), parameter :: name_proc='Example 3 of trid_inviter'
!
!
! SPECIFICATIONS FOR VARIABLES
! ============================
!
    real(stnd)                              :: err1, err2, err, eps, abstol, &
                                               normr, normt, elapsed_time
    real(stnd), allocatable, dimension(:)   :: diag, sup, sup2, eigval
    real(stnd), allocatable, dimension(:,:) :: resid, eigvec
!
    integer      :: iok, istart, iend, irate, imax, itime
    integer(i4b) :: neig2, maxiter=2
!
    logical(lgl) :: failure, do_test
!   
    character    :: sort='d'
!   
!   
! EXECUTABLE STATEMENTS
! =====================
!
!   PRINT LABEL OF THE TEST.
!
    write (prtunit,*)
    write (prtunit,*) name_proc,' :'
    write (prtunit,*) repeat('*', len(name_proc) )
    write (prtunit,*)
!
!   EXAMPLE 3 : SELECTED EIGENVALUES AND EIGENVECTORS OF
!               A REAL SYMMETRIC TRIDIAGONAL MATRIX USING
!               BISECTION FOR THE EIGENVALUES AND INVERSE
!               ITERATION METHOD FOR THE EIGENVECTORS.
!
!   SET THE REQUIRED PRECISION OF THE RESULTS.
!
    eps = fudge*epsilon( err )
    abstol = sqrt( lamch('s') )
!
    err = zero
    do_test = true
!
!   ALLOCATE WORK ARRAYS.
!
    allocate( diag(n), sup(n), eigval(n), eigvec(n,neig), stat=iok )
!
    if ( iok/=0 ) then
        call merror( name_proc//allocate_error )
    end if
!
!   GENERATE A (1-2-1) TRIDIAGONAL MATRIX.
!   THE DIAGONAL ELEMENTS ARE STORED IN diag .
!   THE OFF-DIAGONAL ELEMENTS ARE STORED IN sup .
!
!    diag(:n) = two
!    sup(:n)  = one
!
!    diag(:n) = 0.5_stnd
!    sup(:n)  = 0.5_stnd
!
!   GENERATE A RANDOM TRIDIAGONAL MATRIX.
!
    call random_number( diag(:n) )
    call random_number( sup(:n) )
!
    if ( do_test ) then
!
!       ALLOCATE WORK ARRAYS.
!
        allocate( resid(n,neig), sup2(n), stat=iok )
!
        if ( iok/=0 ) then
            call merror( name_proc//allocate_error )
        end if
!
    end if
!
!   START TIMING THE COMPUTATIONS.
!
    call system_clock( count_rate=irate, count_max=imax  )
    call system_clock( count=istart )
!
!   COMPUTE SELECTED EIGENVALUES OF THE TRIDIAGONAL MATRIX BY BISECTION.
!
    call symtrid_bisect( diag, sup, neig2, eigval, failure, sort=sort, le=neig, abstol=abstol )
!
    if ( .not. failure ) then
!
!       COMPUTE THE FIRST neig EIGENVECTORS OF THE TRIDIAGONAL MATRIX BY maxiter INVERSE ITERATIONS
!       WITH SUBROUTINE trid_inviter.
!
!       ON ENTRY, PARAMETER eigval CONTAINS SELECTED EIGENVALUES OF THE TRIDIAGONAL MATRIX.
!       THE EIGENVALUES VALUES MUST BE GIVEN IN DECREASING ORDER.
!
        call trid_inviter( diag(:n), sup(:n), eigval(:neig), eigvec(:n,:neig), failure, maxiter=maxiter )
!
!       ON EXIT OF trid_inviter :
!
!       failure= false :  INDICATES SUCCESSFUL EXIT
!       failure= true  :  INDICATES THAT MAXIMUM ACCURACY WAS NOT OBTAIN IN THE ALGORITHM

!       eigvec CONTAINS THE neig EIGENVECTORS ASSOCIATED WITH THE EIGENVALUES eigval(:neig).
!
!       trid_inviter MAY FAIL IF SOME THE EIGENVALUES SPECIFIED IN PARAMETER eigval ARE NEARLY
!       IDENTICAL.
!
    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 ( 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 .
!
        sup2(:n) = eoshift( sup(:n), -1 )
        resid(:n,:neig) = spread( diag(:n),         dim=2, ncopies=neig )*eigvec                                + &
                          spread( sup2(:n),         dim=2, ncopies=neig )*eoshift( eigvec, shift=-1, dim=1 )    + &
                          eoshift( spread(sup2(:n), dim=2, ncopies=neig)*eigvec, shift=1 )                      - &
                          spread( eigval(:neig),    dim=1, ncopies=n )*eigvec
!
        sup(:neig) = norm( resid(:n,:neig), dim=2_i4b )
!
        normr = maxval( sup(:neig) )
        normt = sqrt( sum( diag(1_i4b:n)**2 ) + sum( sup(1_i4b:n-1_i4b)**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( resid(:neig,:neig) )
!
        resid(:neig,:neig) = abs( resid(:neig,:neig) - matmul( transpose( eigvec ), eigvec ) )
!
        normr = maxval( resid(:neig,:neig) )
!
        err2  = normr/real(n,stnd)
!
        err = max( err1, err2 )
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( diag, sup, eigval, eigvec, resid, sup2 )
!
    else
!
!       DEALLOCATE WORK ARRAYS.
!
        deallocate( diag, sup, eigval, eigvec )
!
    end if
!
    if ( err<=eps .and. .not.failure ) then
        write (prtunit,*) name_proc//' is correct'
    else
        write (prtunit,*) name_proc//' is incorrect'
    end if
!
    if ( do_test ) 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,i5,a,i5,a,i5,a,0pd12.4,a)')    &
      'The elapsed time for computing ', neig,' eigenvalues and eigenvectors of a ', &
       n, ' by ', n,' real symmetric tridiagonal matrix is ', elapsed_time, ' seconds'
!
!
! END OF PROGRAM ex3_trid_inviter
! ===============================
!
end program ex3_trid_inviter