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 7b572c7

Browse files
authored
Regrouped lapack handling functions (#1013)
2 parents 089d316 + e07bff5 commit 7b572c7

9 files changed

+356
-318
lines changed

‎src/lapack/stdlib_linalg_lapack_aux.fypp

Lines changed: 332 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,8 @@
33
module stdlib_linalg_lapack_aux
44
use stdlib_linalg_constants
55
use stdlib_linalg_blas
6+
use stdlib_linalg_state, only: linalg_state_type, linalg_error_handling, LINALG_ERROR, &
7+
LINALG_INTERNAL_ERROR, LINALG_VALUE_ERROR, LINALG_SUCCESS
68
use ieee_arithmetic, only: ieee_support_inf, ieee_support_nan
79
implicit none
810
private
@@ -38,6 +40,17 @@ module stdlib_linalg_lapack_aux
3840
public :: stdlib_select_${ri}$
3941
public :: stdlib_selctg_${ri}$
4042
#:endfor
43+
public :: handle_potrf_info
44+
public :: handle_getri_info
45+
public :: handle_gesdd_info
46+
public :: handle_gesv_info
47+
public :: handle_gees_info
48+
public :: handle_geqrf_info
49+
public :: handle_orgqr_info
50+
public :: handle_gelsd_info
51+
public :: handle_geev_info
52+
public :: handle_ggev_info
53+
public :: handle_heev_info
4154

4255
! SELCTG is a LOGICAL FUNCTION of three DOUBLE PRECISION arguments
4356
! used to select eigenvalues to sort to the top left of the Schur form.
@@ -1275,4 +1288,323 @@ module stdlib_linalg_lapack_aux
12751288

12761289
#:endfor
12771290

1291+
!----------------------------------------------------------------------------
1292+
!----- -----
1293+
!----- AUXILIARY INFO HANDLING FUNCTIONS FOR LAPACK SUBROUTINES -----
1294+
!----- -----
1295+
!----------------------------------------------------------------------------
1296+
1297+
! Cholesky factorization
1298+
elemental subroutine handle_potrf_info(this,info,triangle,lda,n,err)
1299+
character(len=*), intent(in) :: this
1300+
character, intent(in) :: triangle
1301+
integer(ilp), intent(in) :: info,lda,n
1302+
type(linalg_state_type), intent(out) :: err
1303+
1304+
! Process output
1305+
select case (info)
1306+
case (0)
1307+
! Success
1308+
case (-1)
1309+
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'invalid triangle selection: ', &
1310+
triangle,'. should be U/L')
1311+
case (-2)
1312+
err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size n=',n)
1313+
case (-4)
1314+
err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid lda=',lda,': is < n = ',n)
1315+
case (1:)
1316+
err = linalg_state_type(this,LINALG_ERROR,'cannot complete factorization:',info, &
1317+
'-th order leading minor is not positive definite')
1318+
case default
1319+
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'catastrophic error')
1320+
end select
1321+
1322+
end subroutine handle_potrf_info
1323+
1324+
elemental subroutine handle_getri_info(this,info,lda,n,err)
1325+
character(len=*), intent(in) :: this
1326+
integer(ilp), intent(in) :: info,lda,n
1327+
type(linalg_state_type), intent(out) :: err
1328+
1329+
! Process output
1330+
select case (info)
1331+
case (0)
1332+
! Success
1333+
case (:-1)
1334+
err = linalg_state_type(this,LINALG_ERROR,'invalid matrix size a=',[lda,n])
1335+
case (1:)
1336+
! Matrix is singular
1337+
err = linalg_state_type(this,LINALG_ERROR,'singular matrix')
1338+
case default
1339+
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'catastrophic error')
1340+
end select
1341+
end subroutine handle_getri_info
1342+
1343+
elemental subroutine handle_gesdd_info(this,err,info,m,n)
1344+
character(len=*), intent(in) :: this
1345+
!> Error handler
1346+
type(linalg_state_type), intent(inout) :: err
1347+
!> GESDD return flag
1348+
integer(ilp), intent(in) :: info
1349+
!> Input matrix size
1350+
integer(ilp), intent(in) :: m,n
1351+
1352+
select case (info)
1353+
case (0)
1354+
! Success!
1355+
err%state = LINALG_SUCCESS
1356+
case (-1)
1357+
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Invalid task ID on input to GESDD.')
1358+
case (-5,-3:-2)
1359+
err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size: a=',[m,n])
1360+
case (-8)
1361+
err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix U size, with a=',[m,n])
1362+
case (-10)
1363+
err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix V size, with a=',[m,n])
1364+
case (-4)
1365+
err = linalg_state_type(this,LINALG_VALUE_ERROR,'A contains invalid/NaN values.')
1366+
case (1:)
1367+
err = linalg_state_type(this,LINALG_ERROR,'SVD computation did not converge.')
1368+
case default
1369+
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'Unknown error returned by GESDD.')
1370+
end select
1371+
1372+
end subroutine handle_gesdd_info
1373+
1374+
elemental subroutine handle_gesv_info(this,info,lda,n,nrhs,err)
1375+
character(len=*), intent(in) :: this
1376+
integer(ilp), intent(in) :: info,lda,n,nrhs
1377+
type(linalg_state_type), intent(out) :: err
1378+
1379+
! Process output
1380+
select case (info)
1381+
case (0)
1382+
! Success
1383+
case (-1)
1384+
err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid problem size n=',n)
1385+
case (-2)
1386+
err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid rhs size n=',nrhs)
1387+
case (-4)
1388+
err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size a=',[lda,n])
1389+
case (-7)
1390+
err = linalg_state_type(this,LINALG_ERROR,'invalid matrix size a=',[lda,n])
1391+
case (1:)
1392+
err = linalg_state_type(this,LINALG_ERROR,'singular matrix')
1393+
case default
1394+
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'catastrophic error')
1395+
end select
1396+
1397+
end subroutine handle_gesv_info
1398+
1399+
!> Wrapper function to handle GEES error codes
1400+
elemental subroutine handle_gees_info(this, info, m, n, ldvs, err)
1401+
character(len=*), intent(in) :: this
1402+
integer(ilp), intent(in) :: info, m, n, ldvs
1403+
type(linalg_state_type), intent(out) :: err
1404+
1405+
! Process GEES output
1406+
select case (info)
1407+
case (0_ilp)
1408+
! Success
1409+
case (-1_ilp)
1410+
! Vector not wanted, but task is wrong
1411+
err = linalg_state_type(this, LINALG_INTERNAL_ERROR,'Invalid Schur vector task request')
1412+
case (-2_ilp)
1413+
! Vector not wanted, but task is wrong
1414+
err = linalg_state_type(this, LINALG_INTERNAL_ERROR,'Invalid sorting task request')
1415+
case (-4_ilp,-6_ilp)
1416+
! Vector not wanted, but task is wrong
1417+
err = linalg_state_type(this, LINALG_VALUE_ERROR,'Invalid/non-square input matrix size:',[m,n])
1418+
case (-11_ilp)
1419+
err = linalg_state_type(this, LINALG_VALUE_ERROR,'Schur vector matrix has insufficient size',[ldvs,n])
1420+
case (-13_ilp)
1421+
err = linalg_state_type(this, LINALG_INTERNAL_ERROR,'Insufficient working storage size')
1422+
case (1_ilp:)
1423+
1424+
if (info==n+2) then
1425+
err = linalg_state_type(this, LINALG_ERROR, 'Ill-conditioned problem: could not sort eigenvalues')
1426+
elseif (info==n+1) then
1427+
err = linalg_state_type(this, LINALG_ERROR, 'Some selected eigenvalues lost property due to sorting')
1428+
elseif (info==n) then
1429+
err = linalg_state_type(this, LINALG_ERROR, 'Convergence failure: no converged eigenvalues')
1430+
else
1431+
err = linalg_state_type(this, LINALG_ERROR, 'Convergence failure; converged range is',[info,n])
1432+
end if
1433+
1434+
case default
1435+
1436+
err = linalg_state_type(this, LINALG_INTERNAL_ERROR, 'GEES catastrophic error: info=', info)
1437+
1438+
end select
1439+
1440+
end subroutine handle_gees_info
1441+
1442+
elemental subroutine handle_geqrf_info(this,info,m,n,lwork,err)
1443+
character(len=*), intent(in) :: this
1444+
integer(ilp), intent(in) :: info,m,n,lwork
1445+
type(linalg_state_type), intent(out) :: err
1446+
1447+
! Process output
1448+
select case (info)
1449+
case (0)
1450+
! Success
1451+
case (-1)
1452+
err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size m=',m)
1453+
case (-2)
1454+
err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size n=',n)
1455+
case (-4)
1456+
err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size a=',[m,n])
1457+
case (-7)
1458+
err = linalg_state_type(this,LINALG_ERROR,'invalid input for lwork=',lwork)
1459+
case default
1460+
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'catastrophic error')
1461+
end select
1462+
1463+
end subroutine handle_geqrf_info
1464+
1465+
elemental subroutine handle_orgqr_info(this,info,m,n,k,lwork,err)
1466+
character(len=*), intent(in) :: this
1467+
integer(ilp), intent(in) :: info,m,n,k,lwork
1468+
type(linalg_state_type), intent(out) :: err
1469+
1470+
! Process output
1471+
select case (info)
1472+
case (0)
1473+
! Success
1474+
case (-1)
1475+
err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size m=',m)
1476+
case (-2)
1477+
err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size n=',n)
1478+
case (-4)
1479+
err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid k=min(m,n)=',k)
1480+
case (-5)
1481+
err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size a=',[m,n])
1482+
case (-8)
1483+
err = linalg_state_type(this,LINALG_ERROR,'invalid input for lwork=',lwork)
1484+
case default
1485+
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'catastrophic error')
1486+
end select
1487+
1488+
end subroutine handle_orgqr_info
1489+
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+
12781610
end module stdlib_linalg_lapack_aux

‎src/stdlib_linalg_cholesky.fypp

Lines changed: 2 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@
44
submodule (stdlib_linalg) stdlib_linalg_cholesky
55
use stdlib_linalg_constants
66
use stdlib_linalg_lapack, only: potrf
7+
use stdlib_linalg_lapack_aux, only: handle_potrf_info
78
use stdlib_linalg_state, only: linalg_state_type, linalg_error_handling, LINALG_ERROR, &
89
LINALG_INTERNAL_ERROR, LINALG_VALUE_ERROR
910
implicit none
@@ -13,31 +14,6 @@ submodule (stdlib_linalg) stdlib_linalg_cholesky
1314

1415
contains
1516

16-
elemental subroutine handle_potrf_info(info,triangle,lda,n,err)
17-
character, intent(in) :: triangle
18-
integer(ilp), intent(in) :: info,lda,n
19-
type(linalg_state_type), intent(out) :: err
20-
21-
! Process output
22-
select case (info)
23-
case (0)
24-
! Success
25-
case (-1)
26-
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'invalid triangle selection: ', &
27-
triangle,'. should be U/L')
28-
case (-2)
29-
err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size n=',n)
30-
case (-4)
31-
err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid lda=',lda,': is < n = ',n)
32-
case (1:)
33-
err = linalg_state_type(this,LINALG_ERROR,'cannot complete factorization:',info, &
34-
'-th order leading minor is not positive definite')
35-
case default
36-
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'catastrophic error')
37-
end select
38-
39-
end subroutine handle_potrf_info
40-
4117
#:for rk,rt,ri in RC_KINDS_TYPES
4218

4319
! Compute the Cholesky factorization of a symmetric / Hermitian matrix, A = L*L^T = U^T*U.
@@ -84,7 +60,7 @@ submodule (stdlib_linalg) stdlib_linalg_cholesky
8460

8561
! Compute factorization
8662
call potrf(triangle,n,a,lda,info)
87-
call handle_potrf_info(info,triangle,lda,n,err0)
63+
call handle_potrf_info(this, info,triangle,lda,n,err0)
8864

8965
! Zero-out the unused part of matrix A
9066
clean_unused: if (other_zeroed_ .and. err0%ok()) then

0 commit comments

Comments
(0)

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