Skip to content

Commit 3501bc9

Browse files
wassup05wassup05
committed
Merge branch 'master' of github.com:wassup05/stdlib into path
2 parents 45824b5 + d8a90aa commit 3501bc9

30 files changed

+746
-406
lines changed

‎CMakeLists.txt

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -31,6 +31,13 @@ if(CMAKE_Fortran_COMPILER_ID STREQUAL GNU AND CMAKE_Fortran_COMPILER_VERSION VER
3131
message(FATAL_ERROR "GCC Version 9 or newer required")
3232
endif()
3333

34+
# --- silence gfortran-15 argument-mismatch warnings
35+
if(CMAKE_Fortran_COMPILER_ID STREQUAL GNU
36+
AND CMAKE_Fortran_COMPILER_VERSION VERSION_GREATER_EQUAL 15.0
37+
AND CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 16.0)
38+
add_compile_options("$<$<COMPILE_LANGUAGE:Fortran>:-Wno-external-argument-mismatch>")
39+
endif()
40+
3441
# --- compiler feature checks
3542
include(CheckFortranSourceCompiles)
3643
include(CheckFortranSourceRuns)

‎doc/specs/stdlib_math.md

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -459,7 +459,7 @@ Experimental
459459

460460
Elemenal function.
461461

462-
### Description
462+
#### Description
463463

464464
`rad2deg` converts phase angles from radians to degrees.
465465

‎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

0 commit comments

Comments
 (0)
pFad - Phonifier reborn

Pfad - The Proxy pFad of © 2024 Garber Painting. All rights reserved.

Note: This service is not intended for secure transactions such as banking, social media, email, or purchasing. Use at your own risk. We assume no liability whatsoever for broken pages.


Alternative Proxies:

Alternative Proxy

pFad Proxy

pFad v3 Proxy

pFad v4 Proxy