Moved handle_gelsd, handle_geev, handle_ggev, handle_heev

Author: loiseaujc

src/lapack/stdlib_linalg_lapack_aux.fypp

@@ -47,6 +47,10 @@ module stdlib_linalg_lapack_aux
  public :: handle_gees_info
  public :: handle_geqrf_info
  public :: handle_orgqr_info
+ public :: handle_gelsd_info
+ public :: handle_geev_info
+ public :: handle_ggev_info
+ public :: handle_heev_info
 
  ! SELCTG is a LOGICAL FUNCTION of three DOUBLE PRECISION arguments 
  ! used to select eigenvalues to sort to the top left of the Schur form. 
@@ -1483,4 +1487,124 @@ module stdlib_linalg_lapack_aux
 
  end subroutine handle_orgqr_info 
 
+ elemental subroutine handle_gelsd_info(this,info,lda,n,ldb,nrhs,err)
+ character(len=*), intent(in) :: this
+ integer(ilp), intent(in) :: info,lda,n,ldb,nrhs
+ type(linalg_state_type), intent(out) :: err
+
+ ! Process output
+ select case (info)
+ case (0)
+ ! Success
+ case (:-1)
+ err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid problem size a=',[lda,n], &
+ ', b=',[ldb,nrhs])
+ case (1:)
+ err = linalg_state_type(this,LINALG_ERROR,'SVD did not converge.')
+ case default
+ err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'catastrophic error')
+ end select
+
+ end subroutine handle_gelsd_info
+
+ !> Process GEEV output flags
+ pure subroutine handle_geev_info(this,err,info,shapea)
+ character(len=*), intent(in) :: this
+ !> Error handler
+ type(linalg_state_type), intent(inout) :: err
+ !> GEEV return flag
+ integer(ilp), intent(in) :: info
+ !> Input matrix size
+ integer(ilp), intent(in) :: shapea(2)
+
+ select case (info)
+ case (0)
+ ! Success!
+ err%state = LINALG_SUCCESS
+ case (-1)
+ err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Invalid task ID: left eigenvectors.')
+ case (-2)
+ err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Invalid task ID: right eigenvectors.')
+ case (-5,-3)
+ err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size: a=',shapea)
+ case (-9)
+ err = linalg_state_type(this,LINALG_VALUE_ERROR,'insufficient left vector matrix size.')
+ case (-11)
+ err = linalg_state_type(this,LINALG_VALUE_ERROR,'insufficient right vector matrix size.')
+ case (-13)
+ err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Insufficient work array size.')
+ case (1:)
+ err = linalg_state_type(this,LINALG_ERROR,'Eigenvalue computation did not converge.')
+ case default
+ err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Unknown error returned by geev.')
+ end select
+
+ end subroutine handle_geev_info
+
+ !> Process GGEV output flags
+ pure subroutine handle_ggev_info(this,err,info,shapea,shapeb)
+ character(len=*), intent(in) :: this
+ !> Error handler
+ type(linalg_state_type), intent(inout) :: err
+ !> GEEV return flag
+ integer(ilp), intent(in) :: info
+ !> Input matrix size
+ integer(ilp), intent(in) :: shapea(2),shapeb(2)
+
+ select case (info)
+ case (0)
+ ! Success!
+ err%state = LINALG_SUCCESS
+ case (-1)
+ err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Invalid task ID: left eigenvectors.')
+ case (-2)
+ err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Invalid task ID: right eigenvectors.')
+ case (-5,-3)
+ err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size: a=',shapea)
+ case (-7)
+ err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size: b=',shapeb) 
+ case (-12)
+ err = linalg_state_type(this,LINALG_VALUE_ERROR,'insufficient left vector matrix size.')
+ case (-14)
+ err = linalg_state_type(this,LINALG_VALUE_ERROR,'insufficient right vector matrix size.')
+ case (-16)
+ err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Insufficient work array size.')
+ case (1:)
+ err = linalg_state_type(this,LINALG_ERROR,'Eigenvalue computation did not converge.')
+ case default
+ err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Unknown error returned by ggev.')
+ end select
+
+ end subroutine handle_ggev_info
+
+ !> Process SYEV/HEEV output flags
+ elemental subroutine handle_heev_info(this,err,info,m,n)
+ character(len=*), intent(in) :: this
+ !> Error handler
+ type(linalg_state_type), intent(inout) :: err
+ !> SYEV/HEEV return flag
+ integer(ilp), intent(in) :: info
+ !> Input matrix size
+ integer(ilp), intent(in) :: m,n
+
+ select case (info)
+ case (0)
+ ! Success!
+ err%state = LINALG_SUCCESS
+ case (-1)
+ err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Invalid eigenvector request.')
+ case (-2)
+ err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Invalid triangular section request.')
+ case (-5,-3)
+ err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size: a=',[m,n])
+ case (-8)
+ err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'insufficient workspace size.')
+ case (1:)
+ err = linalg_state_type(this,LINALG_ERROR,'Eigenvalue computation did not converge.')
+ case default
+ err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Unknown error returned by syev/heev.')
+ end select
+
+ end subroutine handle_heev_info
+
 end module stdlib_linalg_lapack_aux

src/stdlib_linalg_eigenvalues.fypp

@@ -7,6 +7,7 @@ submodule (stdlib_linalg) stdlib_linalg_eigenvalues
 !! Compute eigenvalues and eigenvectors 
  use stdlib_linalg_constants
  use stdlib_linalg_lapack, only: geev, ggev, heev, syev
+ use stdlib_linalg_lapack_aux, only: handle_geev_info, handle_ggev_info, handle_heev_info
  use stdlib_linalg_state, only: linalg_state_type, linalg_error_handling, LINALG_ERROR, &
  LINALG_INTERNAL_ERROR, LINALG_VALUE_ERROR, LINALG_SUCCESS 
  use, intrinsic:: ieee_arithmetic, only: ieee_value, ieee_positive_inf, ieee_quiet_nan
@@ -36,103 +37,6 @@ submodule (stdlib_linalg) stdlib_linalg_eigenvalues
  if (present(upper)) symmetric_triangle_task = merge('U','L',upper)
  end function symmetric_triangle_task
 
- !> Process GEEV output flags
- pure subroutine handle_geev_info(err,info,shapea)
- !> Error handler
- type(linalg_state_type), intent(inout) :: err
- !> GEEV return flag
- integer(ilp), intent(in) :: info
- !> Input matrix size
- integer(ilp), intent(in) :: shapea(2)
-
- select case (info)
- case (0)
- ! Success!
- err%state = LINALG_SUCCESS
- case (-1)
- err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Invalid task ID: left eigenvectors.')
- case (-2)
- err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Invalid task ID: right eigenvectors.')
- case (-5,-3)
- err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size: a=',shapea)
- case (-9)
- err = linalg_state_type(this,LINALG_VALUE_ERROR,'insufficient left vector matrix size.')
- case (-11)
- err = linalg_state_type(this,LINALG_VALUE_ERROR,'insufficient right vector matrix size.')
- case (-13)
- err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Insufficient work array size.')
- case (1:)
- err = linalg_state_type(this,LINALG_ERROR,'Eigenvalue computation did not converge.')
- case default
- err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Unknown error returned by geev.')
- end select
-
- end subroutine handle_geev_info
-
- !> Process GGEV output flags
- pure subroutine handle_ggev_info(err,info,shapea,shapeb)
- !> Error handler
- type(linalg_state_type), intent(inout) :: err
- !> GEEV return flag
- integer(ilp), intent(in) :: info
- !> Input matrix size
- integer(ilp), intent(in) :: shapea(2),shapeb(2)
-
- select case (info)
- case (0)
- ! Success!
- err%state = LINALG_SUCCESS
- case (-1)
- err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Invalid task ID: left eigenvectors.')
- case (-2)
- err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Invalid task ID: right eigenvectors.')
- case (-5,-3)
- err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size: a=',shapea)
- case (-7)
- err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size: b=',shapeb) 
- case (-12)
- err = linalg_state_type(this,LINALG_VALUE_ERROR,'insufficient left vector matrix size.')
- case (-14)
- err = linalg_state_type(this,LINALG_VALUE_ERROR,'insufficient right vector matrix size.')
- case (-16)
- err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Insufficient work array size.')
- case (1:)
- err = linalg_state_type(this,LINALG_ERROR,'Eigenvalue computation did not converge.')
- case default
- err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Unknown error returned by ggev.')
- end select
-
- end subroutine handle_ggev_info
-
- !> Process SYEV/HEEV output flags
- elemental subroutine handle_heev_info(err,info,m,n)
- !> Error handler
- type(linalg_state_type), intent(inout) :: err
- !> SYEV/HEEV return flag
- integer(ilp), intent(in) :: info
- !> Input matrix size
- integer(ilp), intent(in) :: m,n
-
- select case (info)
- case (0)
- ! Success!
- err%state = LINALG_SUCCESS
- case (-1)
- err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Invalid eigenvector request.')
- case (-2)
- err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Invalid triangular section request.')
- case (-5,-3)
- err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size: a=',[m,n])
- case (-8)
- err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'insufficient workspace size.')
- case (1:)
- err = linalg_state_type(this,LINALG_ERROR,'Eigenvalue computation did not converge.')
- case default
- err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Unknown error returned by syev/heev.')
- end select
-
- end subroutine handle_heev_info
-
  #:for rk,rt,ri in RC_KINDS_TYPES
  #:for ep,ei in EIG_PROBLEM_LIST
 
@@ -370,7 +274,7 @@ submodule (stdlib_linalg) stdlib_linalg_eigenvalues
  #:endif 
  umat,ldu,vmat,ldv,&
  work_dummy,lwork,#{if rt.startswith('complex')}#rwork,#{endif}#info)
- call handle_${ei}$_info(err0,info,shape(amat)#{if ei=='ggev'}#,shape(bmat)#{endif}#)
+ call handle_${ei}$_info(this,err0,info,shape(amat)#{if ei=='ggev'}#,shape(bmat)#{endif}#)
 
  ! Compute eigenvalues
  if (info==0) then
@@ -390,7 +294,7 @@ submodule (stdlib_linalg) stdlib_linalg_eigenvalues
  #:endif 
  umat,ldu,vmat,ldv,& 
  work,lwork,#{if rt.startswith('complex')}#rwork,#{endif}#info)
- call handle_${ei}$_info(err0,info,shape(amat)#{if ei=='ggev'}#,shape(bmat)#{endif}#)
+ call handle_${ei}$_info(this,err0,info,shape(amat)#{if ei=='ggev'}#,shape(bmat)#{endif}#)
 
  endif
 
@@ -584,7 +488,7 @@ submodule (stdlib_linalg) stdlib_linalg_eigenvalues
  #:else
  call syev(task,triangle,n,amat,lda,lambda,work_dummy,lwork,info)
  #:endif
- call handle_heev_info(err0,info,m,n)
+ call handle_heev_info(this,err0,info,m,n)
 
  ! Compute eigenvalues
  if (info==0) then
@@ -599,7 +503,7 @@ submodule (stdlib_linalg) stdlib_linalg_eigenvalues
  #:else
  call syev(task,triangle,n,amat,lda,lambda,work,lwork,info)
  #:endif
- call handle_heev_info(err0,info,m,n)
+ call handle_heev_info(this,err0,info,m,n)
 
  endif
 

src/stdlib_linalg_least_squares.fypp

@@ -8,6 +8,7 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
 !! Least-squares solution to Ax=b
  use stdlib_linalg_constants
  use stdlib_linalg_lapack, only: gelsd, stdlib_ilaenv
+ use stdlib_linalg_lapack_aux, only: handle_gelsd_info
  use stdlib_linalg_state, only: linalg_state_type, linalg_error_handling, LINALG_ERROR, &
  LINALG_INTERNAL_ERROR, LINALG_VALUE_ERROR
  implicit none
@@ -16,25 +17,6 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
 
  contains
 
- elemental subroutine handle_gelsd_info(info,lda,n,ldb,nrhs,err)
- integer(ilp), intent(in) :: info,lda,n,ldb,nrhs
- type(linalg_state_type), intent(out) :: err
-
- ! Process output
- select case (info)
- case (0)
- ! Success
- case (:-1)
- err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid problem size a=',[lda,n], &
- ', b=',[ldb,nrhs])
- case (1:)
- err = linalg_state_type(this,LINALG_ERROR,'SVD did not converge.')
- case default
- err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'catastrophic error')
- end select
-
- end subroutine handle_gelsd_info
-
  #:for rk,rt,ri in RC_KINDS_TYPES
  ! Workspace needed by gelsd
  elemental subroutine ${ri}$gelsd_space(m,n,nrhs,lrwork,liwork,lcwork)
@@ -334,7 +316,7 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
  acond = singular(1)/singular(mnmin)
 
  ! Process output
- call handle_gelsd_info(info,lda,n,ldb,nrhs,err0)
+ call handle_gelsd_info(this,info,lda,n,ldb,nrhs,err0)
 
  endif