Skip to content

Commit 1023129

Browse files
loiseaujcloiseaujc
committed
Moved handle_gees_info
1 parent b60888d commit 1023129

File tree

2 files changed

+47
-44
lines changed

2 files changed

+47
-44
lines changed

‎src/lapack/stdlib_linalg_lapack_aux.fypp‎

Lines changed: 44 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -44,6 +44,7 @@ module stdlib_linalg_lapack_aux
4444
public :: handle_getri_info
4545
public :: handle_gesdd_info
4646
public :: handle_gesv_info
47+
public :: handle_gees_info
4748

4849
! SELCTG is a LOGICAL FUNCTION of three DOUBLE PRECISION arguments
4950
! used to select eigenvalues to sort to the top left of the Schur form.
@@ -1389,4 +1390,47 @@ module stdlib_linalg_lapack_aux
13891390

13901391
end subroutine handle_gesv_info
13911392

1393+
!> Wrapper function to handle GEES error codes
1394+
elemental subroutine handle_gees_info(this, info, m, n, ldvs, err)
1395+
character(len=*), intent(in) :: this
1396+
integer(ilp), intent(in) :: info, m, n, ldvs
1397+
type(linalg_state_type), intent(out) :: err
1398+
1399+
! Process GEES output
1400+
select case (info)
1401+
case (0_ilp)
1402+
! Success
1403+
case (-1_ilp)
1404+
! Vector not wanted, but task is wrong
1405+
err = linalg_state_type(this, LINALG_INTERNAL_ERROR,'Invalid Schur vector task request')
1406+
case (-2_ilp)
1407+
! Vector not wanted, but task is wrong
1408+
err = linalg_state_type(this, LINALG_INTERNAL_ERROR,'Invalid sorting task request')
1409+
case (-4_ilp,-6_ilp)
1410+
! Vector not wanted, but task is wrong
1411+
err = linalg_state_type(this, LINALG_VALUE_ERROR,'Invalid/non-square input matrix size:',[m,n])
1412+
case (-11_ilp)
1413+
err = linalg_state_type(this, LINALG_VALUE_ERROR,'Schur vector matrix has insufficient size',[ldvs,n])
1414+
case (-13_ilp)
1415+
err = linalg_state_type(this, LINALG_INTERNAL_ERROR,'Insufficient working storage size')
1416+
case (1_ilp:)
1417+
1418+
if (info==n+2) then
1419+
err = linalg_state_type(this, LINALG_ERROR, 'Ill-conditioned problem: could not sort eigenvalues')
1420+
elseif (info==n+1) then
1421+
err = linalg_state_type(this, LINALG_ERROR, 'Some selected eigenvalues lost property due to sorting')
1422+
elseif (info==n) then
1423+
err = linalg_state_type(this, LINALG_ERROR, 'Convergence failure: no converged eigenvalues')
1424+
else
1425+
err = linalg_state_type(this, LINALG_ERROR, 'Convergence failure; converged range is',[info,n])
1426+
end if
1427+
1428+
case default
1429+
1430+
err = linalg_state_type(this, LINALG_INTERNAL_ERROR, 'GEES catastrophic error: info=', info)
1431+
1432+
end select
1433+
1434+
end subroutine handle_gees_info
1435+
13921436
end module stdlib_linalg_lapack_aux

‎src/stdlib_linalg_schur.fypp‎

Lines changed: 3 additions & 44 deletions
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@
33
submodule (stdlib_linalg) stdlib_linalg_schur
44
use stdlib_linalg_constants
55
use stdlib_linalg_lapack, only: gees
6+
use stdlib_linalg_lapack_aux, only: handle_gees_info
67
use stdlib_linalg_state, only: linalg_state_type, linalg_error_handling, LINALG_ERROR, &
78
LINALG_INTERNAL_ERROR, LINALG_VALUE_ERROR
89
implicit none
@@ -35,48 +36,6 @@ submodule (stdlib_linalg) stdlib_linalg_schur
3536
gees_sort_eigs = merge(GEES_SORTED_VECTORS,GEES_NOT,sorted)
3637
end function gees_sort_eigs
3738

38-
!> Wrapper function to handle GEES error codes
39-
elemental subroutine handle_gees_info(info, m, n, ldvs, err)
40-
integer(ilp), intent(in) :: info, m, n, ldvs
41-
type(linalg_state_type), intent(out) :: err
42-
43-
! Process GEES output
44-
select case (info)
45-
case (0_ilp)
46-
! Success
47-
case (-1_ilp)
48-
! Vector not wanted, but task is wrong
49-
err = linalg_state_type(this, LINALG_INTERNAL_ERROR,'Invalid Schur vector task request')
50-
case (-2_ilp)
51-
! Vector not wanted, but task is wrong
52-
err = linalg_state_type(this, LINALG_INTERNAL_ERROR,'Invalid sorting task request')
53-
case (-4_ilp,-6_ilp)
54-
! Vector not wanted, but task is wrong
55-
err = linalg_state_type(this, LINALG_VALUE_ERROR,'Invalid/non-square input matrix size:',[m,n])
56-
case (-11_ilp)
57-
err = linalg_state_type(this, LINALG_VALUE_ERROR,'Schur vector matrix has insufficient size',[ldvs,n])
58-
case (-13_ilp)
59-
err = linalg_state_type(this, LINALG_INTERNAL_ERROR,'Insufficient working storage size')
60-
case (1_ilp:)
61-
62-
if (info==n+2) then
63-
err = linalg_state_type(this, LINALG_ERROR, 'Ill-conditioned problem: could not sort eigenvalues')
64-
elseif (info==n+1) then
65-
err = linalg_state_type(this, LINALG_ERROR, 'Some selected eigenvalues lost property due to sorting')
66-
elseif (info==n) then
67-
err = linalg_state_type(this, LINALG_ERROR, 'Convergence failure: no converged eigenvalues')
68-
else
69-
err = linalg_state_type(this, LINALG_ERROR, 'Convergence failure; converged range is',[info,n])
70-
end if
71-
72-
case default
73-
74-
err = linalg_state_type(this, LINALG_INTERNAL_ERROR, 'GEES catastrophic error: info=', info)
75-
76-
end select
77-
78-
end subroutine handle_gees_info
79-
8039
#:for rk, rt, ri in RC_KINDS_TYPES
8140
!> Workspace query
8241
module subroutine get_schur_${ri}$_workspace(a,lwork,err)
@@ -112,7 +71,7 @@ submodule (stdlib_linalg) stdlib_linalg_schur
11271
call gees(jobvs,sort,do_not_select,n,amat,m,sdim,wr_dummy,#{if rt.startswith('r')}#wi_dummy, #{endif}#&
11372
vs_dummy,m,work_dummy,lwork,#{if rt.startswith('c')}#rwork_dummy,#{endif}#bwork_dummy,info)
11473
if (info==0) lwork = nint(real(work_dummy(1),kind=${rk}$),kind=ilp)
115-
call handle_gees_info(info,m,n,m,err0)
74+
call handle_gees_info(this,info,m,n,m,err0)
11675
call linalg_error_handling(err0,err)
11776

11877
contains
@@ -275,7 +234,7 @@ submodule (stdlib_linalg) stdlib_linalg_schur
275234
! Compute Schur decomposition
276235
call gees(jobvs,sort,eig_select,nt,t,mt,sdim,eigs,#{if rt.startswith('r')}#eigi,#{endif}# &
277236
vs,ldvs,work,lwork,#{if rt.startswith('c')}#rwork,#{endif}#bwork,info)
278-
call handle_gees_info(info,m,n,m,err0)
237+
call handle_gees_info(this,info,m,n,m,err0)
279238

280239

281240
end if

0 commit comments

Comments
 (0)