Skip to content

Commit e07bff5

Browse files
loiseaujcloiseaujc
committed
Moved handle_gelsd, handle_geev, handle_ggev, handle_heev
1 parent f4ba488 commit e07bff5

File tree

3 files changed

+131
-121
lines changed

3 files changed

+131
-121
lines changed

‎src/lapack/stdlib_linalg_lapack_aux.fypp‎

Lines changed: 124 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -47,6 +47,10 @@ module stdlib_linalg_lapack_aux
4747
public :: handle_gees_info
4848
public :: handle_geqrf_info
4949
public :: handle_orgqr_info
50+
public :: handle_gelsd_info
51+
public :: handle_geev_info
52+
public :: handle_ggev_info
53+
public :: handle_heev_info
5054

5155
! SELCTG is a LOGICAL FUNCTION of three DOUBLE PRECISION arguments
5256
! used to select eigenvalues to sort to the top left of the Schur form.
@@ -1483,4 +1487,124 @@ module stdlib_linalg_lapack_aux
14831487

14841488
end subroutine handle_orgqr_info
14851489

1490+
elemental subroutine handle_gelsd_info(this,info,lda,n,ldb,nrhs,err)
1491+
character(len=*), intent(in) :: this
1492+
integer(ilp), intent(in) :: info,lda,n,ldb,nrhs
1493+
type(linalg_state_type), intent(out) :: err
1494+
1495+
! Process output
1496+
select case (info)
1497+
case (0)
1498+
! Success
1499+
case (:-1)
1500+
err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid problem size a=',[lda,n], &
1501+
', b=',[ldb,nrhs])
1502+
case (1:)
1503+
err = linalg_state_type(this,LINALG_ERROR,'SVD did not converge.')
1504+
case default
1505+
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'catastrophic error')
1506+
end select
1507+
1508+
end subroutine handle_gelsd_info
1509+
1510+
!> Process GEEV output flags
1511+
pure subroutine handle_geev_info(this,err,info,shapea)
1512+
character(len=*), intent(in) :: this
1513+
!> Error handler
1514+
type(linalg_state_type), intent(inout) :: err
1515+
!> GEEV return flag
1516+
integer(ilp), intent(in) :: info
1517+
!> Input matrix size
1518+
integer(ilp), intent(in) :: shapea(2)
1519+
1520+
select case (info)
1521+
case (0)
1522+
! Success!
1523+
err%state = LINALG_SUCCESS
1524+
case (-1)
1525+
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Invalid task ID: left eigenvectors.')
1526+
case (-2)
1527+
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Invalid task ID: right eigenvectors.')
1528+
case (-5,-3)
1529+
err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size: a=',shapea)
1530+
case (-9)
1531+
err = linalg_state_type(this,LINALG_VALUE_ERROR,'insufficient left vector matrix size.')
1532+
case (-11)
1533+
err = linalg_state_type(this,LINALG_VALUE_ERROR,'insufficient right vector matrix size.')
1534+
case (-13)
1535+
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Insufficient work array size.')
1536+
case (1:)
1537+
err = linalg_state_type(this,LINALG_ERROR,'Eigenvalue computation did not converge.')
1538+
case default
1539+
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Unknown error returned by geev.')
1540+
end select
1541+
1542+
end subroutine handle_geev_info
1543+
1544+
!> Process GGEV output flags
1545+
pure subroutine handle_ggev_info(this,err,info,shapea,shapeb)
1546+
character(len=*), intent(in) :: this
1547+
!> Error handler
1548+
type(linalg_state_type), intent(inout) :: err
1549+
!> GEEV return flag
1550+
integer(ilp), intent(in) :: info
1551+
!> Input matrix size
1552+
integer(ilp), intent(in) :: shapea(2),shapeb(2)
1553+
1554+
select case (info)
1555+
case (0)
1556+
! Success!
1557+
err%state = LINALG_SUCCESS
1558+
case (-1)
1559+
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Invalid task ID: left eigenvectors.')
1560+
case (-2)
1561+
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Invalid task ID: right eigenvectors.')
1562+
case (-5,-3)
1563+
err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size: a=',shapea)
1564+
case (-7)
1565+
err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size: b=',shapeb)
1566+
case (-12)
1567+
err = linalg_state_type(this,LINALG_VALUE_ERROR,'insufficient left vector matrix size.')
1568+
case (-14)
1569+
err = linalg_state_type(this,LINALG_VALUE_ERROR,'insufficient right vector matrix size.')
1570+
case (-16)
1571+
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Insufficient work array size.')
1572+
case (1:)
1573+
err = linalg_state_type(this,LINALG_ERROR,'Eigenvalue computation did not converge.')
1574+
case default
1575+
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Unknown error returned by ggev.')
1576+
end select
1577+
1578+
end subroutine handle_ggev_info
1579+
1580+
!> Process SYEV/HEEV output flags
1581+
elemental subroutine handle_heev_info(this,err,info,m,n)
1582+
character(len=*), intent(in) :: this
1583+
!> Error handler
1584+
type(linalg_state_type), intent(inout) :: err
1585+
!> SYEV/HEEV return flag
1586+
integer(ilp), intent(in) :: info
1587+
!> Input matrix size
1588+
integer(ilp), intent(in) :: m,n
1589+
1590+
select case (info)
1591+
case (0)
1592+
! Success!
1593+
err%state = LINALG_SUCCESS
1594+
case (-1)
1595+
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Invalid eigenvector request.')
1596+
case (-2)
1597+
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Invalid triangular section request.')
1598+
case (-5,-3)
1599+
err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size: a=',[m,n])
1600+
case (-8)
1601+
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'insufficient workspace size.')
1602+
case (1:)
1603+
err = linalg_state_type(this,LINALG_ERROR,'Eigenvalue computation did not converge.')
1604+
case default
1605+
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Unknown error returned by syev/heev.')
1606+
end select
1607+
1608+
end subroutine handle_heev_info
1609+
14861610
end module stdlib_linalg_lapack_aux

‎src/stdlib_linalg_eigenvalues.fypp‎

Lines changed: 5 additions & 101 deletions
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,7 @@ submodule (stdlib_linalg) stdlib_linalg_eigenvalues
77
!! Compute eigenvalues and eigenvectors
88
use stdlib_linalg_constants
99
use stdlib_linalg_lapack, only: geev, ggev, heev, syev
10+
use stdlib_linalg_lapack_aux, only: handle_geev_info, handle_ggev_info, handle_heev_info
1011
use stdlib_linalg_state, only: linalg_state_type, linalg_error_handling, LINALG_ERROR, &
1112
LINALG_INTERNAL_ERROR, LINALG_VALUE_ERROR, LINALG_SUCCESS
1213
use, intrinsic:: ieee_arithmetic, only: ieee_value, ieee_positive_inf, ieee_quiet_nan
@@ -36,103 +37,6 @@ submodule (stdlib_linalg) stdlib_linalg_eigenvalues
3637
if (present(upper)) symmetric_triangle_task = merge('U','L',upper)
3738
end function symmetric_triangle_task
3839

39-
!> Process GEEV output flags
40-
pure subroutine handle_geev_info(err,info,shapea)
41-
!> Error handler
42-
type(linalg_state_type), intent(inout) :: err
43-
!> GEEV return flag
44-
integer(ilp), intent(in) :: info
45-
!> Input matrix size
46-
integer(ilp), intent(in) :: shapea(2)
47-
48-
select case (info)
49-
case (0)
50-
! Success!
51-
err%state = LINALG_SUCCESS
52-
case (-1)
53-
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Invalid task ID: left eigenvectors.')
54-
case (-2)
55-
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Invalid task ID: right eigenvectors.')
56-
case (-5,-3)
57-
err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size: a=',shapea)
58-
case (-9)
59-
err = linalg_state_type(this,LINALG_VALUE_ERROR,'insufficient left vector matrix size.')
60-
case (-11)
61-
err = linalg_state_type(this,LINALG_VALUE_ERROR,'insufficient right vector matrix size.')
62-
case (-13)
63-
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Insufficient work array size.')
64-
case (1:)
65-
err = linalg_state_type(this,LINALG_ERROR,'Eigenvalue computation did not converge.')
66-
case default
67-
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Unknown error returned by geev.')
68-
end select
69-
70-
end subroutine handle_geev_info
71-
72-
!> Process GGEV output flags
73-
pure subroutine handle_ggev_info(err,info,shapea,shapeb)
74-
!> Error handler
75-
type(linalg_state_type), intent(inout) :: err
76-
!> GEEV return flag
77-
integer(ilp), intent(in) :: info
78-
!> Input matrix size
79-
integer(ilp), intent(in) :: shapea(2),shapeb(2)
80-
81-
select case (info)
82-
case (0)
83-
! Success!
84-
err%state = LINALG_SUCCESS
85-
case (-1)
86-
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Invalid task ID: left eigenvectors.')
87-
case (-2)
88-
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Invalid task ID: right eigenvectors.')
89-
case (-5,-3)
90-
err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size: a=',shapea)
91-
case (-7)
92-
err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size: b=',shapeb)
93-
case (-12)
94-
err = linalg_state_type(this,LINALG_VALUE_ERROR,'insufficient left vector matrix size.')
95-
case (-14)
96-
err = linalg_state_type(this,LINALG_VALUE_ERROR,'insufficient right vector matrix size.')
97-
case (-16)
98-
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Insufficient work array size.')
99-
case (1:)
100-
err = linalg_state_type(this,LINALG_ERROR,'Eigenvalue computation did not converge.')
101-
case default
102-
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Unknown error returned by ggev.')
103-
end select
104-
105-
end subroutine handle_ggev_info
106-
107-
!> Process SYEV/HEEV output flags
108-
elemental subroutine handle_heev_info(err,info,m,n)
109-
!> Error handler
110-
type(linalg_state_type), intent(inout) :: err
111-
!> SYEV/HEEV return flag
112-
integer(ilp), intent(in) :: info
113-
!> Input matrix size
114-
integer(ilp), intent(in) :: m,n
115-
116-
select case (info)
117-
case (0)
118-
! Success!
119-
err%state = LINALG_SUCCESS
120-
case (-1)
121-
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Invalid eigenvector request.')
122-
case (-2)
123-
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Invalid triangular section request.')
124-
case (-5,-3)
125-
err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size: a=',[m,n])
126-
case (-8)
127-
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'insufficient workspace size.')
128-
case (1:)
129-
err = linalg_state_type(this,LINALG_ERROR,'Eigenvalue computation did not converge.')
130-
case default
131-
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Unknown error returned by syev/heev.')
132-
end select
133-
134-
end subroutine handle_heev_info
135-
13640
#:for rk,rt,ri in RC_KINDS_TYPES
13741
#:for ep,ei in EIG_PROBLEM_LIST
13842

@@ -370,7 +274,7 @@ submodule (stdlib_linalg) stdlib_linalg_eigenvalues
370274
#:endif
371275
umat,ldu,vmat,ldv,&
372276
work_dummy,lwork,#{if rt.startswith('complex')}#rwork,#{endif}#info)
373-
call handle_${ei}$_info(err0,info,shape(amat)#{if ei=='ggev'}#,shape(bmat)#{endif}#)
277+
call handle_${ei}$_info(this,err0,info,shape(amat)#{if ei=='ggev'}#,shape(bmat)#{endif}#)
374278

375279
! Compute eigenvalues
376280
if (info==0) then
@@ -390,7 +294,7 @@ submodule (stdlib_linalg) stdlib_linalg_eigenvalues
390294
#:endif
391295
umat,ldu,vmat,ldv,&
392296
work,lwork,#{if rt.startswith('complex')}#rwork,#{endif}#info)
393-
call handle_${ei}$_info(err0,info,shape(amat)#{if ei=='ggev'}#,shape(bmat)#{endif}#)
297+
call handle_${ei}$_info(this,err0,info,shape(amat)#{if ei=='ggev'}#,shape(bmat)#{endif}#)
394298

395299
endif
396300

@@ -584,7 +488,7 @@ submodule (stdlib_linalg) stdlib_linalg_eigenvalues
584488
#:else
585489
call syev(task,triangle,n,amat,lda,lambda,work_dummy,lwork,info)
586490
#:endif
587-
call handle_heev_info(err0,info,m,n)
491+
call handle_heev_info(this,err0,info,m,n)
588492

589493
! Compute eigenvalues
590494
if (info==0) then
@@ -599,7 +503,7 @@ submodule (stdlib_linalg) stdlib_linalg_eigenvalues
599503
#:else
600504
call syev(task,triangle,n,amat,lda,lambda,work,lwork,info)
601505
#:endif
602-
call handle_heev_info(err0,info,m,n)
506+
call handle_heev_info(this,err0,info,m,n)
603507

604508
endif
605509

‎src/stdlib_linalg_least_squares.fypp‎

Lines changed: 2 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
88
!! Least-squares solution to Ax=b
99
use stdlib_linalg_constants
1010
use stdlib_linalg_lapack, only: gelsd, stdlib_ilaenv
11+
use stdlib_linalg_lapack_aux, only: handle_gelsd_info
1112
use stdlib_linalg_state, only: linalg_state_type, linalg_error_handling, LINALG_ERROR, &
1213
LINALG_INTERNAL_ERROR, LINALG_VALUE_ERROR
1314
implicit none
@@ -16,25 +17,6 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
1617

1718
contains
1819

19-
elemental subroutine handle_gelsd_info(info,lda,n,ldb,nrhs,err)
20-
integer(ilp), intent(in) :: info,lda,n,ldb,nrhs
21-
type(linalg_state_type), intent(out) :: err
22-
23-
! Process output
24-
select case (info)
25-
case (0)
26-
! Success
27-
case (:-1)
28-
err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid problem size a=',[lda,n], &
29-
', b=',[ldb,nrhs])
30-
case (1:)
31-
err = linalg_state_type(this,LINALG_ERROR,'SVD did not converge.')
32-
case default
33-
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'catastrophic error')
34-
end select
35-
36-
end subroutine handle_gelsd_info
37-
3820
#:for rk,rt,ri in RC_KINDS_TYPES
3921
! Workspace needed by gelsd
4022
elemental subroutine ${ri}$gelsd_space(m,n,nrhs,lrwork,liwork,lcwork)
@@ -334,7 +316,7 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
334316
acond = singular(1)/singular(mnmin)
335317

336318
! Process output
337-
call handle_gelsd_info(info,lda,n,ldb,nrhs,err0)
319+
call handle_gelsd_info(this,info,lda,n,ldb,nrhs,err0)
338320

339321
endif
340322

0 commit comments

Comments
 (0)