Skip to content

Commit 9aa8b47

Browse files
github-actions[bot]github-actions[bot]
committed
Regrouped lapack handling functions (fortran-lang#1013)
2 parents 02e9900 + 7b572c7 commit 9aa8b47

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)