Skip to content

Navigation Menu

Sign in
Appearance settings

Search code, repositories, users, issues, pull requests...

Provide feedback

We read every piece of feedback, and take your input very seriously.

Saved searches

Use saved searches to filter your results more quickly
Sign up
Appearance settings

Commit e07bff5

Browse files
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)

AltStyle によって変換されたページ (->オリジナル) /