Skip to content

Commit 55e0dd0

Browse files
ghbrownghbrown
committed
Extend is_hamiltonian to real types and add is_hamiltonian tests
1 parent e1f07e6 commit 55e0dd0

File tree

2 files changed

+174
-12
lines changed

2 files changed

+174
-12
lines changed

‎src/stdlib_linalg.fypp

Lines changed: 13 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -143,7 +143,7 @@ module stdlib_linalg
143143
!!
144144
!! Checks if a matrix (rank-2 array) is Hermitian
145145
!! ([Specification](../page/specs/stdlib_linalg.html#description_8))
146-
#:for k1, t1 in CMPLX_KINDS_TYPES
146+
#:for k1, t1 in RCI_KINDS_TYPES
147147
module procedure is_hermitian_${t1[0]}$${k1}$
148148
#:endfor
149149
end interface is_hermitian
@@ -292,6 +292,18 @@ contains
292292
#:endfor
293293

294294

295+
#:for k1, t1 in (REAL_KINDS_TYPES + INT_KINDS_TYPES)
296+
pure function is_hermitian_${t1[0]}$${k1}$(A) result(res)
297+
${t1}$, intent(in) :: A(:,:)
298+
logical :: res
299+
integer :: A_shape(2), n, i, j
300+
if (.not. is_square(A)) then
301+
res = .false.
302+
return !nonsquare matrices cannot be Hermitian
303+
end if
304+
res = is_symmetric(A) !real symmetric matrices are Hermitian
305+
end function is_hermitian_${t1[0]}$${k1}$
306+
#:endfor
295307
#:for k1, t1 in CMPLX_KINDS_TYPES
296308
pure function is_hermitian_${t1[0]}$${k1}$(A) result(res)
297309
${t1}$, intent(in) :: A(:,:)

‎src/tests/linalg/test_linalg.f90

Lines changed: 161 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,7 @@ program test_linalg
33
use stdlib_error, only: check
44
use stdlib_kinds, only: sp, dp, qp, int8, int16, int32, int64
55
use stdlib_linalg, only: diag, eye, trace, outer_product, is_square ,is_diagonal, &
6-
is_symmetric, is_skew_symmetric, is_triangular, is_hessenberg
6+
is_symmetric, is_skew_symmetric, is_hermitian, is_triangular, is_hessenberg
77

88
implicit none
99

@@ -140,18 +140,18 @@ program test_linalg
140140
!
141141
! is_hermitian
142142
!
143-
!call test_is_hermitian_rsp
144-
!call test_is_hermitian_rdp
145-
!call test_is_hermitian_rqp
143+
call test_is_hermitian_rsp
144+
call test_is_hermitian_rdp
145+
call test_is_hermitian_rqp
146146

147-
!call test_is_hermitian_csp
148-
!call test_is_hermitian_cdp
149-
!call test_is_hermitian_cqp
147+
call test_is_hermitian_csp
148+
call test_is_hermitian_cdp
149+
call test_is_hermitian_cqp
150150

151-
!call test_is_hermitian_int8
152-
!call test_is_hermitian_int16
153-
!call test_is_hermitian_int32
154-
!call test_is_hermitian_int64
151+
call test_is_hermitian_int8
152+
call test_is_hermitian_int16
153+
call test_is_hermitian_int32
154+
call test_is_hermitian_int64
155155

156156
!
157157
! is_triangular
@@ -1376,6 +1376,156 @@ subroutine test_is_skew_symmetric_int64
13761376
end subroutine test_is_skew_symmetric_int64
13771377

13781378

1379+
subroutine test_is_hermitian_rsp
1380+
real(sp) :: A_true(2,2), A_false_1(2,2), A_false_2(3,2)
1381+
write(*,*) "test_is_hermitian_rsp"
1382+
A_true = reshape([1.,2.,2.,4.],[2,2])
1383+
A_false_1 = reshape([1.,2.,3.,4.],[2,2])
1384+
A_false_2 = reshape([1.,2.,3.,2.,5.,6.],[3,2]) !nonsquare matrix
1385+
call check(is_hermitian(A_true), &
1386+
msg="is_hermitian(A_true) failed.",warn=warn)
1387+
call check((.not. is_hermitian(A_false_1)), &
1388+
msg="(.not. is_hermitian(A_false_1)) failed.",warn=warn)
1389+
call check((.not. is_hermitian(A_false_2)), &
1390+
msg="(.not. is_hermitian(A_false_2)) failed.",warn=warn)
1391+
end subroutine test_is_hermitian_rsp
1392+
1393+
subroutine test_is_hermitian_rdp
1394+
real(sp) :: A_true(2,2), A_false_1(2,2), A_false_2(3,2)
1395+
write(*,*) "test_is_hermitian_rdp"
1396+
A_true = reshape([1.,2.,2.,4.],[2,2])
1397+
A_false_1 = reshape([1.,2.,3.,4.],[2,2])
1398+
A_false_2 = reshape([1.,2.,3.,2.,5.,6.],[3,2]) !nonsquare matrix
1399+
call check(is_hermitian(A_true), &
1400+
msg="is_hermitian(A_true) failed.",warn=warn)
1401+
call check((.not. is_hermitian(A_false_1)), &
1402+
msg="(.not. is_hermitian(A_false_1)) failed.",warn=warn)
1403+
call check((.not. is_hermitian(A_false_2)), &
1404+
msg="(.not. is_hermitian(A_false_2)) failed.",warn=warn)
1405+
end subroutine test_is_hermitian_rdp
1406+
1407+
subroutine test_is_hermitian_rqp
1408+
real(sp) :: A_true(2,2), A_false_1(2,2), A_false_2(3,2)
1409+
write(*,*) "test_is_hermitian_rqp"
1410+
A_true = reshape([1.,2.,2.,4.],[2,2])
1411+
A_false_1 = reshape([1.,2.,3.,4.],[2,2])
1412+
A_false_2 = reshape([1.,2.,3.,2.,5.,6.],[3,2]) !nonsquare matrix
1413+
call check(is_hermitian(A_true), &
1414+
msg="is_hermitian(A_true) failed.",warn=warn)
1415+
call check((.not. is_hermitian(A_false_1)), &
1416+
msg="(.not. is_hermitian(A_false_1)) failed.",warn=warn)
1417+
call check((.not. is_hermitian(A_false_2)), &
1418+
msg="(.not. is_hermitian(A_false_2)) failed.",warn=warn)
1419+
end subroutine test_is_hermitian_rqp
1420+
1421+
subroutine test_is_hermitian_csp
1422+
complex(sp) :: A_true(2,2), A_false_1(2,2), A_false_2(3,2)
1423+
write(*,*) "test_is_hermitian_csp"
1424+
A_true = reshape([cmplx(1.,0.),cmplx(2.,-1.), &
1425+
cmplx(2.,1.),cmplx(4.,0.)],[2,2])
1426+
A_false_1 = reshape([cmplx(1.,0.),cmplx(2.,-1.), &
1427+
cmplx(3.,1.),cmplx(4.,0.)],[2,2])
1428+
A_false_2 = reshape([cmplx(1.,0.),cmplx(2.,-1.),cmplx(3.,-1.), &
1429+
cmplx(2.,1.),cmplx(5.,0.),cmplx(6.,-1.)],[3,2]) !nonsquare matrix
1430+
call check(is_hermitian(A_true), &
1431+
msg="is_hermitian(A_true) failed.",warn=warn)
1432+
call check((.not. is_hermitian(A_false_1)), &
1433+
msg="(.not. is_hermitian(A_false_1)) failed.",warn=warn)
1434+
call check((.not. is_hermitian(A_false_2)), &
1435+
msg="(.not. is_hermitian(A_false_2)) failed.",warn=warn)
1436+
end subroutine test_is_hermitian_csp
1437+
1438+
subroutine test_is_hermitian_cdp
1439+
complex(sp) :: A_true(2,2), A_false_1(2,2), A_false_2(3,2)
1440+
write(*,*) "test_is_hermitian_cdp"
1441+
A_true = reshape([cmplx(1.,0.),cmplx(2.,-1.), &
1442+
cmplx(2.,1.),cmplx(4.,0.)],[2,2])
1443+
A_false_1 = reshape([cmplx(1.,0.),cmplx(2.,-1.), &
1444+
cmplx(3.,1.),cmplx(4.,0.)],[2,2])
1445+
A_false_2 = reshape([cmplx(1.,0.),cmplx(2.,-1.),cmplx(3.,-1.), &
1446+
cmplx(2.,1.),cmplx(5.,0.),cmplx(6.,-1.)],[3,2]) !nonsquare matrix
1447+
call check(is_hermitian(A_true), &
1448+
msg="is_hermitian(A_true) failed.",warn=warn)
1449+
call check((.not. is_hermitian(A_false_1)), &
1450+
msg="(.not. is_hermitian(A_false_1)) failed.",warn=warn)
1451+
call check((.not. is_hermitian(A_false_2)), &
1452+
msg="(.not. is_hermitian(A_false_2)) failed.",warn=warn)
1453+
end subroutine test_is_hermitian_cdp
1454+
1455+
subroutine test_is_hermitian_cqp
1456+
complex(sp) :: A_true(2,2), A_false_1(2,2), A_false_2(3,2)
1457+
write(*,*) "test_is_hermitian_cqp"
1458+
A_true = reshape([cmplx(1.,0.),cmplx(2.,-1.), &
1459+
cmplx(2.,1.),cmplx(4.,0.)],[2,2])
1460+
A_false_1 = reshape([cmplx(1.,0.),cmplx(2.,-1.), &
1461+
cmplx(3.,1.),cmplx(4.,0.)],[2,2])
1462+
A_false_2 = reshape([cmplx(1.,0.),cmplx(2.,-1.),cmplx(3.,-1.), &
1463+
cmplx(2.,1.),cmplx(5.,0.),cmplx(6.,-1.)],[3,2]) !nonsquare matrix
1464+
call check(is_hermitian(A_true), &
1465+
msg="is_hermitian(A_true) failed.",warn=warn)
1466+
call check((.not. is_hermitian(A_false_1)), &
1467+
msg="(.not. is_hermitian(A_false_1)) failed.",warn=warn)
1468+
call check((.not. is_hermitian(A_false_2)), &
1469+
msg="(.not. is_hermitian(A_false_2)) failed.",warn=warn)
1470+
end subroutine test_is_hermitian_cqp
1471+
1472+
subroutine test_is_hermitian_int8
1473+
integer(int8) :: A_true(2,2), A_false_1(2,2), A_false_2(3,2)
1474+
write(*,*) "test_is_hermitian_int8"
1475+
A_true = reshape([1,2,2,4],[2,2])
1476+
A_false_1 = reshape([1,2,3,4],[2,2])
1477+
A_false_2 = reshape([1,2,3,2,5,6],[3,2]) !nonsquare matrix
1478+
call check(is_hermitian(A_true), &
1479+
msg="is_hermitian(A_true) failed.",warn=warn)
1480+
call check((.not. is_hermitian(A_false_1)), &
1481+
msg="(.not. is_hermitian(A_false_1)) failed.",warn=warn)
1482+
call check((.not. is_hermitian(A_false_2)), &
1483+
msg="(.not. is_hermitian(A_false_2)) failed.",warn=warn)
1484+
end subroutine test_is_hermitian_int8
1485+
1486+
subroutine test_is_hermitian_int16
1487+
integer(int16) :: A_true(2,2), A_false_1(2,2), A_false_2(3,2)
1488+
write(*,*) "test_is_hermitian_int16"
1489+
A_true = reshape([1,2,2,4],[2,2])
1490+
A_false_1 = reshape([1,2,3,4],[2,2])
1491+
A_false_2 = reshape([1,2,3,2,5,6],[3,2]) !nonsquare matrix
1492+
call check(is_hermitian(A_true), &
1493+
msg="is_hermitian(A_true) failed.",warn=warn)
1494+
call check((.not. is_hermitian(A_false_1)), &
1495+
msg="(.not. is_hermitian(A_false_1)) failed.",warn=warn)
1496+
call check((.not. is_hermitian(A_false_2)), &
1497+
msg="(.not. is_hermitian(A_false_2)) failed.",warn=warn)
1498+
end subroutine test_is_hermitian_int16
1499+
1500+
subroutine test_is_hermitian_int32
1501+
integer(int32) :: A_true(2,2), A_false_1(2,2), A_false_2(3,2)
1502+
write(*,*) "test_is_hermitian_int32"
1503+
A_true = reshape([1,2,2,4],[2,2])
1504+
A_false_1 = reshape([1,2,3,4],[2,2])
1505+
A_false_2 = reshape([1,2,3,2,5,6],[3,2]) !nonsquare matrix
1506+
call check(is_hermitian(A_true), &
1507+
msg="is_hermitian(A_true) failed.",warn=warn)
1508+
call check((.not. is_hermitian(A_false_1)), &
1509+
msg="(.not. is_hermitian(A_false_1)) failed.",warn=warn)
1510+
call check((.not. is_hermitian(A_false_2)), &
1511+
msg="(.not. is_hermitian(A_false_2)) failed.",warn=warn)
1512+
end subroutine test_is_hermitian_int32
1513+
1514+
subroutine test_is_hermitian_int64
1515+
integer(int64) :: A_true(2,2), A_false_1(2,2), A_false_2(3,2)
1516+
write(*,*) "test_is_hermitian_int64"
1517+
A_true = reshape([1,2,2,4],[2,2])
1518+
A_false_1 = reshape([1,2,3,4],[2,2])
1519+
A_false_2 = reshape([1,2,3,2,5,6],[3,2]) !nonsquare matrix
1520+
call check(is_hermitian(A_true), &
1521+
msg="is_hermitian(A_true) failed.",warn=warn)
1522+
call check((.not. is_hermitian(A_false_1)), &
1523+
msg="(.not. is_hermitian(A_false_1)) failed.",warn=warn)
1524+
call check((.not. is_hermitian(A_false_2)), &
1525+
msg="(.not. is_hermitian(A_false_2)) failed.",warn=warn)
1526+
end subroutine test_is_hermitian_int64
1527+
1528+
13791529
subroutine test_is_triangular_rsp
13801530
real(sp) :: A_true_s_u(2,2), A_false_s_u(2,2) !square matrices (upper triangular)
13811531
real(sp) :: A_true_sf_u(2,3), A_false_sf_u(2,3) !short and fat matrices

0 commit comments

Comments
 (0)