From 7ccdb497b756640dbcef576e9b147782ef34215b Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sat, 16 Mar 2024 09:25:04 +0100 Subject: [PATCH 01/27] add `linalg` state handler --- src/CMakeLists.txt | 2 + src/stdlib_linalg_constants.fypp | 18 ++ src/stdlib_linalg_state.fypp | 517 +++++++++++++++++++++++++++++++ 3 files changed, 537 insertions(+) create mode 100644 src/stdlib_linalg_constants.fypp create mode 100644 src/stdlib_linalg_state.fypp diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 89890f4a0..7393a6ac3 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -23,7 +23,9 @@ set(fppFiles stdlib_linalg_diag.fypp stdlib_linalg_outer_product.fypp stdlib_linalg_kronecker.fypp + stdlib_linalg_constants.fypp stdlib_linalg_cross_product.fypp + stdlib_linalg_state.fypp stdlib_optval.fypp stdlib_selection.fypp stdlib_sorting.fypp diff --git a/src/stdlib_linalg_constants.fypp b/src/stdlib_linalg_constants.fypp new file mode 100644 index 000000000..4524247ea --- /dev/null +++ b/src/stdlib_linalg_constants.fypp @@ -0,0 +1,18 @@ +#:include "common.fypp" +module stdlib_linalg_constants + use stdlib_kinds, only: sp, dp, qp, int32, int64, lk + use, intrinsic :: ieee_arithmetic, only: ieee_is_nan +!$ use omp_lib + implicit none(type,external) + public + + + ! Integer size support for ILP64 builds should be done here + integer, parameter :: ilp = int32 + private :: int32, int64 + + + + + +end module stdlib_linalg_constants diff --git a/src/stdlib_linalg_state.fypp b/src/stdlib_linalg_state.fypp new file mode 100644 index 000000000..43fed16c9 --- /dev/null +++ b/src/stdlib_linalg_state.fypp @@ -0,0 +1,517 @@ +module stdlib_linalg_state + use stdlib_linalg_constants,only:ilp,lk + use iso_fortran_env,only:real32,real64,real128,int8,int16,int32,int64,stderr => error_unit + implicit none(type,external) + private + + !> Public interfaces + public :: linalg_state + public :: linalg_error_handling + public :: operator(==),operator(/=) + public :: operator(<),operator(<=) + public :: operator(>),operator(>=) + + !> State return types + integer(ilp),parameter,public :: LINALG_SUCCESS = 0_ilp + integer(ilp),parameter,public :: LINALG_VALUE_ERROR = -1_ilp + integer(ilp),parameter,public :: LINALG_ERROR = -2_ilp + integer(ilp),parameter,public :: LINALG_INTERNAL_ERROR = -3_ilp + + !> Use fixed-size character storage for performance + integer(ilp),parameter :: MSG_LENGTH = 512_ilp + integer(ilp),parameter :: NAME_LENGTH = 32_ilp + + !> `linalg_state` defines a state return type for a + !> linear algebra routine. State contains a status flag, a comment, and a + !> procedure specifier that can be used to mark where the error happened + type,public :: linalg_state + + !> The current exit state + integer(ilp) :: state = LINALG_SUCCESS + + !> Message associated to the current state + character(len=MSG_LENGTH) :: message = repeat(' ',MSG_LENGTH) + + !> Location of the state change + character(len=NAME_LENGTH) :: where_at = repeat(' ',NAME_LENGTH) + + contains + + !> Cleanup + procedure :: destroy => state_destroy + + !> Print error message + procedure :: print => state_print + procedure :: print_msg => state_message + + !> State properties + procedure :: ok => state_is_ok + procedure :: error => state_is_error + + end type linalg_state + + !> Comparison operators + interface operator(==) + module procedure state_eq_flag + module procedure flag_eq_state + end interface + interface operator(/=) + module procedure state_neq_flag + module procedure flag_neq_state + end interface + interface operator(<) + module procedure state_lt_flag + module procedure flag_lt_state + end interface + interface operator(<=) + module procedure state_le_flag + module procedure flag_le_state + end interface + interface operator(>) + module procedure state_gt_flag + module procedure flag_gt_state + end interface + interface operator(>=) + module procedure state_ge_flag + module procedure flag_ge_state + end interface + + interface linalg_state + module procedure new_state + module procedure new_state_nowhere + end interface linalg_state + + contains + + !> Interface to print linalg state flags + pure function LINALG_MESSAGE(flag) result(msg) + integer(ilp),intent(in) :: flag + character(len=:),allocatable :: msg + + select case (flag) + case (LINALG_SUCCESS); msg = 'Success!' + case (LINALG_VALUE_ERROR); msg = 'Value Error' + case (LINALG_ERROR); msg = 'Algebra Error' + case (LINALG_INTERNAL_ERROR); msg = 'Internal Error' + case default; msg = 'ERROR/INVALID FLAG' + end select + + end function LINALG_MESSAGE + + !> Flow control: on output flag present, return it; otherwise, halt on error + pure subroutine linalg_error_handling(ierr,ierr_out) + type(linalg_state),intent(in) :: ierr + type(linalg_state),optional,intent(out) :: ierr_out + + character(len=:),allocatable :: err_msg + + if (present(ierr_out)) then + ! Return error flag + ierr_out = ierr + elseif (ierr%error()) then + err_msg = ierr%print() + error stop err_msg + end if + + end subroutine linalg_error_handling + + !> Formatted message + pure function state_message(this) result(msg) + class(linalg_state),intent(in) :: this + character(len=:),allocatable :: msg + + if (this%state == LINALG_SUCCESS) then + msg = 'Success!' + else + msg = LINALG_MESSAGE(this%state)//': '//trim(this%message) + end if + + end function state_message + + !> Produce a nice error string + pure function state_print(this) result(msg) + class(linalg_state),intent(in) :: this + character(len=:),allocatable :: msg + + if (len_trim(this%where_at) > 0) then + msg = '['//trim(this%where_at)//'] returned '//state_message(this) + elseif (this%error()) then + msg = 'Error encountered: '//state_message(this) + else + msg = state_message(this) + end if + + end function state_print + + !> Cleanup object + elemental subroutine state_destroy(this) + class(linalg_state),intent(inout) :: this + + this%state = LINALG_SUCCESS + this%message = repeat(' ',len(this%message)) + this%where_at = repeat(' ',len(this%where_at)) + + end subroutine state_destroy + + !> Check if the current state is successful + elemental logical(lk) function state_is_ok(this) + class(linalg_state),intent(in) :: this + state_is_ok = this%state == LINALG_SUCCESS + end function state_is_ok + + !> Check if the current state is an error state + elemental logical(lk) function state_is_error(this) + class(linalg_state),intent(in) :: this + state_is_error = this%state /= LINALG_SUCCESS + end function state_is_error + + !> Compare an error flag with an integer + elemental logical(lk) function state_eq_flag(err,flag) + type(linalg_state),intent(in) :: err + integer,intent(in) :: flag + state_eq_flag = err%state == flag + end function state_eq_flag + elemental logical(lk) function flag_eq_state(flag,err) + integer,intent(in) :: flag + type(linalg_state),intent(in) :: err + flag_eq_state = err%state == flag + end function flag_eq_state + elemental logical(lk) function state_neq_flag(err,flag) + type(linalg_state),intent(in) :: err + integer,intent(in) :: flag + state_neq_flag = .not. state_eq_flag(err,flag) + end function state_neq_flag + elemental logical(lk) function flag_neq_state(flag,err) + integer,intent(in) :: flag + type(linalg_state),intent(in) :: err + flag_neq_state = .not. state_eq_flag(err,flag) + end function flag_neq_state + elemental logical(lk) function state_lt_flag(err,flag) + type(linalg_state),intent(in) :: err + integer,intent(in) :: flag + state_lt_flag = err%state < flag + end function state_lt_flag + elemental logical(lk) function state_le_flag(err,flag) + type(linalg_state),intent(in) :: err + integer,intent(in) :: flag + state_le_flag = err%state <= flag + end function state_le_flag + elemental logical(lk) function flag_lt_state(flag,err) + integer,intent(in) :: flag + type(linalg_state),intent(in) :: err + flag_lt_state = err%state < flag + end function flag_lt_state + elemental logical(lk) function flag_le_state(flag,err) + integer,intent(in) :: flag + type(linalg_state),intent(in) :: err + flag_le_state = err%state <= flag + end function flag_le_state + elemental logical(lk) function state_gt_flag(err,flag) + type(linalg_state),intent(in) :: err + integer,intent(in) :: flag + state_gt_flag = err%state > flag + end function state_gt_flag + elemental logical(lk) function state_ge_flag(err,flag) + type(linalg_state),intent(in) :: err + integer,intent(in) :: flag + state_ge_flag = err%state >= flag + end function state_ge_flag + elemental logical(lk) function flag_gt_state(flag,err) + integer,intent(in) :: flag + type(linalg_state),intent(in) :: err + flag_gt_state = err%state > flag + end function flag_gt_state + elemental logical(lk) function flag_ge_state(flag,err) + integer,intent(in) :: flag + type(linalg_state),intent(in) :: err + flag_ge_state = err%state >= flag + end function flag_ge_state + + !> Error creation message, with location location + pure type(linalg_state) function new_state(where_at,flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + v1,v2,v3,v4,v5) + + !> Location + character(len=*),intent(in) :: where_at + + !> Input error flag + integer,intent(in) :: flag + + !> Optional scalar arguments + class(*),optional,intent(in) :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10 + + !> Optional vector arguments + class(*),optional,intent(in),dimension(:) :: v1,v2,v3,v4,v5 + + !> Create state with no message + new_state = new_state_nowhere(flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,v1,v2,v3,v4,v5) + + !> Add location + if (len_trim(where_at) > 0) new_state%where_at = adjustl(where_at) + + end function new_state + + !> Error creation message, from N input variables (numeric or strings) + pure type(linalg_state) function new_state_nowhere(flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + v1,v2,v3,v4,v5) result(new_state) + + !> Input error flag + integer,intent(in) :: flag + + !> Optional scalar arguments + class(*),optional,intent(in) :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10 + + !> Optional vector arguments + class(*),optional,intent(in),dimension(:) :: v1,v2,v3,v4,v5 + + ! Init object + call new_state%destroy() + + !> Set error flag + new_state%state = flag + + !> Set chain + new_state%message = "" + call append(new_state%message,a1) + call append(new_state%message,a2) + call append(new_state%message,a3) + call append(new_state%message,a4) + call append(new_state%message,a5) + call append(new_state%message,a6) + call append(new_state%message,a7) + call append(new_state%message,a8) + call append(new_state%message,a9) + call append(new_state%message,a10) + call appendv(new_state%message,v1) + call appendv(new_state%message,v2) + call appendv(new_state%message,v3) + call appendv(new_state%message,v4) + call appendv(new_state%message,v5) + + end function new_state_nowhere + + ! Append a generic value to the error flag + pure subroutine append(msg,a,prefix) + class(*),optional,intent(in) :: a + character(len=*),intent(inout) :: msg + character,optional,intent(in) :: prefix + + character(len=MSG_LENGTH) :: buffer,buffer2 + character(len=2) :: sep + integer :: ls + + if (.not. present(a)) return + + ! Do not add separator if this is the first instance + sep = ' ' + ls = merge(1,0,len_trim(msg) > 0) + + if (present(prefix)) then + ls = ls + 1 + sep(ls:ls) = prefix + end if + + select type (aa => a) + + type is (character(len=*)) + + msg = trim(msg)//sep(:ls)//aa + + type is (integer(int8)) + + write (buffer,'(i0)') aa + msg = trim(msg)//sep(:ls)//trim(adjustl(buffer)) + + type is (integer(int16)) + + write (buffer,'(i0)') aa + msg = trim(msg)//sep(:ls)//trim(adjustl(buffer)) + + type is (integer(int32)) + + write (buffer,'(i0)') aa + msg = trim(msg)//sep(:ls)//trim(adjustl(buffer)) + + type is (integer(int64)) + + write (buffer,'(i0)') aa + msg = trim(msg)//sep(:ls)//trim(adjustl(buffer)) + + type is (real(real32)) + + write (buffer,'(es15.8e2)') aa + msg = trim(msg)//sep(:ls)//trim(adjustl(buffer)) + + type is (real(real64)) + + write (buffer,'(es24.16e3)') aa + msg = trim(msg)//sep(:ls)//trim(adjustl(buffer)) + + type is (real(real128)) + + write (buffer,'(es44.35e4)') aa + msg = trim(msg)//sep(:ls)//trim(adjustl(buffer)) + + type is (complex(real32)) + + write (buffer,'(es15.8e2)') aa%re + write (buffer2,'(es15.8e2)') aa%im + msg = trim(msg)//sep(:ls)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' + + type is (complex(real64)) + + write (buffer,'(es24.16e3)') aa%re + write (buffer2,'(es24.16e3)') aa%im + msg = trim(msg)//sep(:ls)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' + + type is (complex(real128)) + + write (buffer,'(es44.35e4)') aa%re + write (buffer2,'(es44.35e4)') aa%im + msg = trim(msg)//sep(:ls)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' + + class default + + msg = trim(msg)//' ' + + end select + + end subroutine append + + ! Append a generic vector to the error flag + pure subroutine appendv(msg,a) + class(*),optional,intent(in) :: a(:) + character(len=*),intent(inout) :: msg + + integer :: j,ls + character(len=MSG_LENGTH) :: buffer,buffer2 + character(len=2) :: sep + + if (.not. present(a)) return + if (size(a) <= 0) return + + ! Default: separate elements with one space + sep = ' ' + ls = 1 + + ! Open bracket + msg = trim(msg)//' [' + + ! Do not call append(msg(aa(j))), it will crash gfortran + select type (aa => a) + + type is (character(len=*)) + + msg = trim(msg)//adjustl(aa(1)) + do j = 2,size(a) + msg = trim(msg)//sep(:ls)//adjustl(aa(j)) + end do + + type is (integer(int8)) + + write (buffer,'(i0)') aa(1) + msg = trim(msg)//adjustl(buffer) + do j = 2,size(a) + write (buffer,'(i0)') aa(j) + msg = trim(msg)//sep(:ls)//adjustl(buffer) + end do + + type is (integer(int16)) + + write (buffer,'(i0)') aa(1) + msg = trim(msg)//adjustl(buffer) + do j = 2,size(a) + write (buffer,'(i0)') aa(j) + msg = trim(msg)//sep(:ls)//adjustl(buffer) + end do + + type is (integer(int32)) + + write (buffer,'(i0)') aa(1) + msg = trim(msg)//adjustl(buffer) + do j = 2,size(a) + write (buffer,'(i0)') aa(j) + msg = trim(msg)//sep(:ls)//adjustl(buffer) + end do + + type is (integer(int64)) + + write (buffer,'(i0)') aa(1) + msg = trim(msg)//adjustl(buffer) + do j = 2,size(a) + write (buffer,'(i0)') aa(j) + msg = trim(msg)//sep(:ls)//adjustl(buffer) + end do + + type is (real(real32)) + + write (buffer,'(es15.8e2)') aa(1) + msg = trim(msg)//adjustl(buffer) + do j = 2,size(a) + write (buffer,'(es15.8e2)') aa(j) + msg = trim(msg)//sep(:ls)//adjustl(buffer) + end do + + type is (real(real64)) + + write (buffer,'(es24.16e3)') aa(1) + msg = trim(msg)//adjustl(buffer) + do j = 2,size(a) + write (buffer,'(es24.16e3)') aa(j) + msg = trim(msg)//sep(:ls)//adjustl(buffer) + end do + + type is (real(real128)) + + write (buffer,'(es44.35e4)') aa(1) + msg = trim(msg)//adjustl(buffer) + do j = 2,size(a) + write (buffer,'(es44.35e4)') aa(j) + msg = trim(msg)//sep(:ls)//adjustl(buffer) + end do + + type is (complex(real32)) + + write (buffer,'(es15.8e2)') aa(1)%re + write (buffer2,'(es15.8e2)') aa(1)%im + msg = trim(msg)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' + do j = 2,size(a) + write (buffer,'(es15.8e2)') aa(j)%re + write (buffer2,'(es15.8e2)') aa(j)%im + msg = trim(msg)//sep(:ls)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' + end do + + type is (complex(real64)) + + write (buffer,'(es24.16e3)') aa(1)%re + write (buffer2,'(es24.16e3)') aa(1)%im + msg = trim(msg)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' + do j = 2,size(a) + write (buffer,'(es24.16e3)') aa(j)%re + write (buffer2,'(es24.16e3)') aa(j)%im + msg = trim(msg)//sep(:ls)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' + end do + + type is (complex(real128)) + + write (buffer,'(es44.35e4)') aa(1)%re + write (buffer2,'(es44.35e4)') aa(1)%im + msg = trim(msg)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' + do j = 2,size(a) + write (buffer,'(es44.35e4)') aa(j)%re + write (buffer2,'(es44.35e4)') aa(j)%im + msg = trim(msg)//sep(:ls)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' + end do + + class default + + msg = trim(msg)//' ' + + end select + + ! Close bracket + msg = trim(msg)//']' + + end subroutine appendv + +end module stdlib_linalg_state From 6d6fb551e100a4e15c25fcc86bca3a7e1b1a17df Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sat, 16 Mar 2024 09:45:10 +0100 Subject: [PATCH 02/27] cleanup, `fypp`ize numeric types --- src/stdlib_linalg_state.fypp | 210 ++++++++++------------------------- 1 file changed, 61 insertions(+), 149 deletions(-) diff --git a/src/stdlib_linalg_state.fypp b/src/stdlib_linalg_state.fypp index 43fed16c9..c3ccf581f 100644 --- a/src/stdlib_linalg_state.fypp +++ b/src/stdlib_linalg_state.fypp @@ -1,6 +1,15 @@ +#:include "common.fypp" +#:set KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES + CMPLX_KINDS_TYPES module stdlib_linalg_state + !! Version: experimental + !! + !! Provides a state/error handling derived type for advanced error handling of + !! BLAS/LAPACK based linear algebra procedures + !! !! ([Specification](../page/specs/stdlib_linalg.html)) use stdlib_linalg_constants,only:ilp,lk - use iso_fortran_env,only:real32,real64,real128,int8,int16,int32,int64,stderr => error_unit + use stdlib_kinds + use stdlib_io + use iso_fortran_env,only: stderr => error_unit implicit none(type,external) private @@ -143,7 +152,7 @@ module stdlib_linalg_state end function state_print - !> Cleanup object + !> Cleanup the object elemental subroutine state_destroy(this) class(linalg_state),intent(inout) :: this @@ -165,62 +174,84 @@ module stdlib_linalg_state state_is_error = this%state /= LINALG_SUCCESS end function state_is_error - !> Compare an error flag with an integer + !> Compare an error state with an integer flag elemental logical(lk) function state_eq_flag(err,flag) type(linalg_state),intent(in) :: err integer,intent(in) :: flag state_eq_flag = err%state == flag end function state_eq_flag + + !> Compare an integer flag with the error state elemental logical(lk) function flag_eq_state(flag,err) integer,intent(in) :: flag type(linalg_state),intent(in) :: err flag_eq_state = err%state == flag end function flag_eq_state + + !> Compare the error state with an integer flag elemental logical(lk) function state_neq_flag(err,flag) type(linalg_state),intent(in) :: err integer,intent(in) :: flag state_neq_flag = .not. state_eq_flag(err,flag) end function state_neq_flag + + !> Compare an integer flag with the error state elemental logical(lk) function flag_neq_state(flag,err) integer,intent(in) :: flag type(linalg_state),intent(in) :: err flag_neq_state = .not. state_eq_flag(err,flag) end function flag_neq_state + + !> Compare the error state with an integer flag elemental logical(lk) function state_lt_flag(err,flag) type(linalg_state),intent(in) :: err integer,intent(in) :: flag state_lt_flag = err%state < flag end function state_lt_flag + + !> Compare the error state with an integer flag elemental logical(lk) function state_le_flag(err,flag) type(linalg_state),intent(in) :: err integer,intent(in) :: flag state_le_flag = err%state <= flag end function state_le_flag + + !> Compare an integer flag with the error state elemental logical(lk) function flag_lt_state(flag,err) integer,intent(in) :: flag type(linalg_state),intent(in) :: err flag_lt_state = err%state < flag end function flag_lt_state + + !> Compare an integer flag with the error state elemental logical(lk) function flag_le_state(flag,err) integer,intent(in) :: flag type(linalg_state),intent(in) :: err flag_le_state = err%state <= flag end function flag_le_state + + !> Compare the error state with an integer flag elemental logical(lk) function state_gt_flag(err,flag) type(linalg_state),intent(in) :: err integer,intent(in) :: flag state_gt_flag = err%state > flag end function state_gt_flag + + !> Compare the error state with an integer flag elemental logical(lk) function state_ge_flag(err,flag) type(linalg_state),intent(in) :: err integer,intent(in) :: flag state_ge_flag = err%state >= flag end function state_ge_flag + + !> Compare an integer flag with the error state elemental logical(lk) function flag_gt_state(flag,err) integer,intent(in) :: flag type(linalg_state),intent(in) :: err flag_gt_state = err%state > flag end function flag_gt_state + + !> Compare an integer flag with the error state elemental logical(lk) function flag_ge_state(flag,err) integer,intent(in) :: flag type(linalg_state),intent(in) :: err @@ -313,65 +344,24 @@ module stdlib_linalg_state select type (aa => a) + !> String type type is (character(len=*)) - msg = trim(msg)//sep(:ls)//aa - type is (integer(int8)) - - write (buffer,'(i0)') aa - msg = trim(msg)//sep(:ls)//trim(adjustl(buffer)) - - type is (integer(int16)) - - write (buffer,'(i0)') aa - msg = trim(msg)//sep(:ls)//trim(adjustl(buffer)) - - type is (integer(int32)) - + !> Numeric types +#:for k1, t1 in KINDS_TYPES + type is (${t1}$) + #:if 'real' in t1 + write (buffer,FMT_REAL_${k1}$) aa + #:elif 'complex' in t1 + write (buffer,FMT_COMPLEX_${k1}$) aa + #:else write (buffer,'(i0)') aa + #:endif msg = trim(msg)//sep(:ls)//trim(adjustl(buffer)) - type is (integer(int64)) - - write (buffer,'(i0)') aa - msg = trim(msg)//sep(:ls)//trim(adjustl(buffer)) - - type is (real(real32)) - - write (buffer,'(es15.8e2)') aa - msg = trim(msg)//sep(:ls)//trim(adjustl(buffer)) - - type is (real(real64)) - - write (buffer,'(es24.16e3)') aa - msg = trim(msg)//sep(:ls)//trim(adjustl(buffer)) - - type is (real(real128)) - - write (buffer,'(es44.35e4)') aa - msg = trim(msg)//sep(:ls)//trim(adjustl(buffer)) - - type is (complex(real32)) - - write (buffer,'(es15.8e2)') aa%re - write (buffer2,'(es15.8e2)') aa%im - msg = trim(msg)//sep(:ls)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' - - type is (complex(real64)) - - write (buffer,'(es24.16e3)') aa%re - write (buffer2,'(es24.16e3)') aa%im - msg = trim(msg)//sep(:ls)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' - - type is (complex(real128)) - - write (buffer,'(es44.35e4)') aa%re - write (buffer2,'(es44.35e4)') aa%im - msg = trim(msg)//sep(:ls)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' - +#:endfor class default - msg = trim(msg)//' ' end select @@ -384,7 +374,7 @@ module stdlib_linalg_state character(len=*),intent(inout) :: msg integer :: j,ls - character(len=MSG_LENGTH) :: buffer,buffer2 + character(len=MSG_LENGTH) :: buffer,buffer2,buffer_format character(len=2) :: sep if (.not. present(a)) return @@ -400,111 +390,33 @@ module stdlib_linalg_state ! Do not call append(msg(aa(j))), it will crash gfortran select type (aa => a) + !> Strings (cannot use string_type due to `sequence`) type is (character(len=*)) - msg = trim(msg)//adjustl(aa(1)) do j = 2,size(a) msg = trim(msg)//sep(:ls)//adjustl(aa(j)) end do - type is (integer(int8)) - - write (buffer,'(i0)') aa(1) - msg = trim(msg)//adjustl(buffer) - do j = 2,size(a) - write (buffer,'(i0)') aa(j) - msg = trim(msg)//sep(:ls)//adjustl(buffer) - end do - - type is (integer(int16)) - - write (buffer,'(i0)') aa(1) - msg = trim(msg)//adjustl(buffer) - do j = 2,size(a) - write (buffer,'(i0)') aa(j) - msg = trim(msg)//sep(:ls)//adjustl(buffer) - end do - - type is (integer(int32)) - - write (buffer,'(i0)') aa(1) - msg = trim(msg)//adjustl(buffer) - do j = 2,size(a) - write (buffer,'(i0)') aa(j) - msg = trim(msg)//sep(:ls)//adjustl(buffer) - end do - - type is (integer(int64)) - - write (buffer,'(i0)') aa(1) - msg = trim(msg)//adjustl(buffer) - do j = 2,size(a) - write (buffer,'(i0)') aa(j) - msg = trim(msg)//sep(:ls)//adjustl(buffer) - end do - - type is (real(real32)) - - write (buffer,'(es15.8e2)') aa(1) + !> Numeric types +#:for k1, t1 in KINDS_TYPES + type is (${t1}$) + #:if 'real' in t1 + buffer_format = FMT_REAL_${k1}$ + #:elif 'complex' in t1 + buffer_format = FMT_COMPLEX_${k1}$ + #:else + buffer_format = '(i0)' + #:endif + write (buffer,buffer_format) aa(1) msg = trim(msg)//adjustl(buffer) do j = 2,size(a) - write (buffer,'(es15.8e2)') aa(j) + write (buffer,buffer_format) aa(j) msg = trim(msg)//sep(:ls)//adjustl(buffer) end do + msg = trim(msg)//sep(:ls)//trim(adjustl(buffer)) - type is (real(real64)) - - write (buffer,'(es24.16e3)') aa(1) - msg = trim(msg)//adjustl(buffer) - do j = 2,size(a) - write (buffer,'(es24.16e3)') aa(j) - msg = trim(msg)//sep(:ls)//adjustl(buffer) - end do - - type is (real(real128)) - - write (buffer,'(es44.35e4)') aa(1) - msg = trim(msg)//adjustl(buffer) - do j = 2,size(a) - write (buffer,'(es44.35e4)') aa(j) - msg = trim(msg)//sep(:ls)//adjustl(buffer) - end do - - type is (complex(real32)) - - write (buffer,'(es15.8e2)') aa(1)%re - write (buffer2,'(es15.8e2)') aa(1)%im - msg = trim(msg)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' - do j = 2,size(a) - write (buffer,'(es15.8e2)') aa(j)%re - write (buffer2,'(es15.8e2)') aa(j)%im - msg = trim(msg)//sep(:ls)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' - end do - - type is (complex(real64)) - - write (buffer,'(es24.16e3)') aa(1)%re - write (buffer2,'(es24.16e3)') aa(1)%im - msg = trim(msg)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' - do j = 2,size(a) - write (buffer,'(es24.16e3)') aa(j)%re - write (buffer2,'(es24.16e3)') aa(j)%im - msg = trim(msg)//sep(:ls)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' - end do - - type is (complex(real128)) - - write (buffer,'(es44.35e4)') aa(1)%re - write (buffer2,'(es44.35e4)') aa(1)%im - msg = trim(msg)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' - do j = 2,size(a) - write (buffer,'(es44.35e4)') aa(j)%re - write (buffer2,'(es44.35e4)') aa(j)%im - msg = trim(msg)//sep(:ls)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' - end do - +#:endfor class default - msg = trim(msg)//' ' end select From e7398a0bb6c6a282ef4a25028edc8cf8a5feb08a Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sat, 16 Mar 2024 09:48:43 +0100 Subject: [PATCH 03/27] more cleanup --- src/stdlib_linalg_state.fypp | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/src/stdlib_linalg_state.fypp b/src/stdlib_linalg_state.fypp index c3ccf581f..84a6bb41e 100644 --- a/src/stdlib_linalg_state.fypp +++ b/src/stdlib_linalg_state.fypp @@ -4,7 +4,7 @@ module stdlib_linalg_state !! Version: experimental !! !! Provides a state/error handling derived type for advanced error handling of - !! BLAS/LAPACK based linear algebra procedures + !! BLAS/LAPACK based linear algebra procedures. All procedures are pure. !! !! ([Specification](../page/specs/stdlib_linalg.html)) use stdlib_linalg_constants,only:ilp,lk use stdlib_kinds @@ -13,9 +13,20 @@ module stdlib_linalg_state implicit none(type,external) private - !> Public interfaces + !> Version: experimental + !> + !> A fixed-storage state variable for error handling of linear algebra routines public :: linalg_state + + !> Version: experimental + !> + !> Error state handling: if the user requested the error state variable on + !> output, just return it to the user. Otherwise, halt the program on error. public :: linalg_error_handling + + !> Version: experimental + !> + !> Interfaces for comparison operators of error states with integer flags public :: operator(==),operator(/=) public :: operator(<),operator(<=) public :: operator(>),operator(>=) From 31cb5eb5e1d408ab52d811e188051379f5d25cae Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sat, 16 Mar 2024 11:15:15 +0100 Subject: [PATCH 04/27] `complex` format: add brackets i.e. `(0.0,1.0)` instead of `0.0 1.0` --- src/stdlib_linalg_state.fypp | 35 ++++++++++++++++++++++++----------- 1 file changed, 24 insertions(+), 11 deletions(-) diff --git a/src/stdlib_linalg_state.fypp b/src/stdlib_linalg_state.fypp index 84a6bb41e..0f43e791b 100644 --- a/src/stdlib_linalg_state.fypp +++ b/src/stdlib_linalg_state.fypp @@ -362,14 +362,18 @@ module stdlib_linalg_state !> Numeric types #:for k1, t1 in KINDS_TYPES type is (${t1}$) - #:if 'real' in t1 - write (buffer,FMT_REAL_${k1}$) aa - #:elif 'complex' in t1 - write (buffer,FMT_COMPLEX_${k1}$) aa + #:if 'complex' in t1 + write (buffer, FMT_REAL_${k1}$) aa%re + write (buffer2,FMT_REAL_${k1}$) aa%im + msg = trim(msg)//sep(:ls)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' #:else + #:if 'real' in t1 + write (buffer,FMT_REAL_${k1}$) aa + #:else write (buffer,'(i0)') aa - #:endif + #:endif msg = trim(msg)//sep(:ls)//trim(adjustl(buffer)) + #:endif #:endfor class default @@ -411,13 +415,22 @@ module stdlib_linalg_state !> Numeric types #:for k1, t1 in KINDS_TYPES type is (${t1}$) - #:if 'real' in t1 - buffer_format = FMT_REAL_${k1}$ - #:elif 'complex' in t1 - buffer_format = FMT_COMPLEX_${k1}$ + #:if 'complex' in t1 + write (buffer,FMT_REAL_${k1}$) aa(1)%re + write (buffer2,FMT_REAL_${k1}$) aa(1)%im + msg = trim(msg)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' + do j = 2,size(a) + write (buffer,FMT_REAL_${k1}$) aa(j)%re + write (buffer2,FMT_REAL_${k1}$) aa(j)%im + msg = trim(msg)//sep(:ls)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' + end do #:else + #:if 'real' in t1 + buffer_format = FMT_REAL_${k1}$ + #:else buffer_format = '(i0)' - #:endif + #:endif + write (buffer,buffer_format) aa(1) msg = trim(msg)//adjustl(buffer) do j = 2,size(a) @@ -425,7 +438,7 @@ module stdlib_linalg_state msg = trim(msg)//sep(:ls)//adjustl(buffer) end do msg = trim(msg)//sep(:ls)//trim(adjustl(buffer)) - + #:endif #:endfor class default msg = trim(msg)//' ' From 4ef4fb04bfb7af6f18a533f21abc40becf0af198 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sat, 16 Mar 2024 11:15:45 +0100 Subject: [PATCH 05/27] add `linalg_state` tests --- test/linalg/test_linalg.fypp | 79 +++++++++++++++++++++++++++++++++--- 1 file changed, 74 insertions(+), 5 deletions(-) diff --git a/test/linalg/test_linalg.fypp b/test/linalg/test_linalg.fypp index 6fdf7f17d..77e95422a 100644 --- a/test/linalg/test_linalg.fypp +++ b/test/linalg/test_linalg.fypp @@ -5,6 +5,7 @@ module test_linalg use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test use stdlib_kinds, only: sp, dp, xdp, qp, int8, int16, int32, int64 use stdlib_linalg, only: diag, eye, trace, outer_product, cross_product, kronecker_product + use stdlib_linalg_state implicit none @@ -49,9 +50,9 @@ contains new_unittest("trace_int16", test_trace_int16), & new_unittest("trace_int32", test_trace_int32), & new_unittest("trace_int64", test_trace_int64), & - #:for k1, t1 in RCI_KINDS_TYPES + #:for k1, t1 in RCI_KINDS_TYPES new_unittest("kronecker_product_${t1[0]}$${k1}$", test_kronecker_product_${t1[0]}$${k1}$), & - #:endfor + #:endfor new_unittest("outer_product_rsp", test_outer_product_rsp), & new_unittest("outer_product_rdp", test_outer_product_rdp), & new_unittest("outer_product_rqp", test_outer_product_rqp), & @@ -71,7 +72,8 @@ contains new_unittest("cross_product_int8", test_cross_product_int8), & new_unittest("cross_product_int16", test_cross_product_int16), & new_unittest("cross_product_int32", test_cross_product_int32), & - new_unittest("cross_product_int64", test_cross_product_int64) & + new_unittest("cross_product_int64", test_cross_product_int64), & + new_unittest("state_handling", test_state_handling) & ] end subroutine collect_linalg @@ -560,7 +562,7 @@ contains #:for k1, t1 in RCI_KINDS_TYPES - subroutine test_kronecker_product_${t1[0]}$${k1}$(error) + subroutine test_kronecker_product_${t1[0]}$${k1}$(error) !> Error handling type(error_type), allocatable, intent(out) :: error integer, parameter :: m1 = 1, n1 = 2, m2 = 2, n2 = 3 @@ -593,7 +595,7 @@ contains ! Expected: C = [1*B, 2*B] = [[1,2,3, 2,4,6], [2,4,6, 4, 8, 12]] end subroutine test_kronecker_product_${t1[0]}$${k1}$ - #:endfor + #:endfor subroutine test_outer_product_rsp(error) !> Error handling @@ -911,6 +913,73 @@ contains #:endif end subroutine test_cross_product_cqp + subroutine test_state_handling(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(linalg_state) :: state,state_out + + state = linalg_state(LINALG_SUCCESS,' 32-bit real: ',1.0_sp) + call check(error, & + state%message==' 32-bit real: 1.00000000E+00', & + "malformed state message with 32-bit reals.") + if (allocated(error)) return + + state = linalg_state(LINALG_SUCCESS,' 64-bit real: ',1.0_dp) + call check(error, & + state%message==' 64-bit real: 1.0000000000000000E+000', & + "malformed state message with 64-bit reals.") + if (allocated(error)) return + +#:if WITH_QP + state = linalg_state(LINALG_SUCCESS,' 128-bit real: ',1.0_qp) + call check(error, & + state%message==' 128-bit real: 1.00000000000000000000000000000000000E+0000', & + "malformed state message with 128-bit reals.") + if (allocated(error)) return +#:endif + + state = linalg_state(LINALG_SUCCESS,' 32-bit complex: ',(1.0_sp,1.0_sp)) + call check(error, & + state%message==' 32-bit complex: (1.00000000E+00,1.00000000E+00)', & + "malformed state message with 32-bit complex: "//trim(state%message)) + if (allocated(error)) return + + state = linalg_state(LINALG_SUCCESS,' 64-bit complex: ',(1.0_dp,1.0_dp)) + call check(error, & + state%message==' 64-bit complex: (1.0000000000000000E+000,1.0000000000000000E+000)', & + "malformed state message with 64-bit complex.") + if (allocated(error)) return + +#:if WITH_QP + state = linalg_state(LINALG_SUCCESS,'128-bit complex: ',(1.0_qp,1.0_qp)) + call check(error, state%message== & + '128-bit complex: (1.00000000000000000000000000000000000E+0000,1.00000000000000000000000000000000000E+0000)', & + "malformed state message with 128-bit complex.") + +#:endif + + state = linalg_state(LINALG_SUCCESS,' 32-bit array: ',v1=[(1.0_sp,0.0_sp),(0.0_sp,1.0_sp)]) + call check(error, state%message== & + ' 32-bit array: [(1.00000000E+00,0.00000000E+00) (0.00000000E+00,1.00000000E+00)]', & + "malformed state message with 32-bit real array.") + if (allocated(error)) return + + !> State flag with location + state = linalg_state('test_formats',LINALG_SUCCESS,' 32-bit real: ',1.0_sp) + call check(error, & + state%print()=='[test_formats] returned Success!', & + "malformed state message with 32-bit real and location.") + if (allocated(error)) return + + !> Test error handling procedure + call linalg_error_handling(state,state_out) + call check(error, state%print()==state_out%print(), & + "malformed state message on return from error handling procedure.") + + end subroutine test_state_handling + + pure recursive function catalan_number(n) result(value) integer, intent(in) :: n integer :: value From c5c568bb07d9b2ec48f0e2af63a2ce0545ed8b93 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sat, 16 Mar 2024 11:29:09 +0100 Subject: [PATCH 06/27] remove multiple `public` statement --- src/stdlib_linalg_state.fypp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/stdlib_linalg_state.fypp b/src/stdlib_linalg_state.fypp index 0f43e791b..cea4a9ea5 100644 --- a/src/stdlib_linalg_state.fypp +++ b/src/stdlib_linalg_state.fypp @@ -44,7 +44,7 @@ module stdlib_linalg_state !> `linalg_state` defines a state return type for a !> linear algebra routine. State contains a status flag, a comment, and a !> procedure specifier that can be used to mark where the error happened - type,public :: linalg_state + type :: linalg_state !> The current exit state integer(ilp) :: state = LINALG_SUCCESS From 88317d9ff27499cdc5c6d3bab79179ea5cf9f53d Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Mon, 25 Mar 2024 16:50:28 +0100 Subject: [PATCH 07/27] Update src/stdlib_linalg_constants.fypp Co-authored-by: Jeremie Vandenplas --- src/stdlib_linalg_constants.fypp | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/stdlib_linalg_constants.fypp b/src/stdlib_linalg_constants.fypp index 4524247ea..84d2364fe 100644 --- a/src/stdlib_linalg_constants.fypp +++ b/src/stdlib_linalg_constants.fypp @@ -11,8 +11,4 @@ module stdlib_linalg_constants integer, parameter :: ilp = int32 private :: int32, int64 - - - - end module stdlib_linalg_constants From 9eb977591559d4ccb8d39dafb2bcb588d2f8b94f Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Mon, 25 Mar 2024 16:51:12 +0100 Subject: [PATCH 08/27] Update src/stdlib_linalg_constants.fypp Co-authored-by: Jeremie Vandenplas --- src/stdlib_linalg_constants.fypp | 1 - 1 file changed, 1 deletion(-) diff --git a/src/stdlib_linalg_constants.fypp b/src/stdlib_linalg_constants.fypp index 84d2364fe..51d5879c8 100644 --- a/src/stdlib_linalg_constants.fypp +++ b/src/stdlib_linalg_constants.fypp @@ -1,7 +1,6 @@ #:include "common.fypp" module stdlib_linalg_constants use stdlib_kinds, only: sp, dp, qp, int32, int64, lk - use, intrinsic :: ieee_arithmetic, only: ieee_is_nan !$ use omp_lib implicit none(type,external) public From 9f74fd74827141e5ca177bde3e88bd3e5b2834d2 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Tue, 26 Mar 2024 10:14:16 +0100 Subject: [PATCH 09/27] address style changes address style changes --- src/stdlib_linalg_constants.fypp | 2 +- src/stdlib_linalg_state.fypp | 82 ++++++++++++++++---------------- test/linalg/test_linalg.fypp | 20 ++++---- 3 files changed, 52 insertions(+), 52 deletions(-) diff --git a/src/stdlib_linalg_constants.fypp b/src/stdlib_linalg_constants.fypp index 51d5879c8..c7d857c9e 100644 --- a/src/stdlib_linalg_constants.fypp +++ b/src/stdlib_linalg_constants.fypp @@ -1,7 +1,7 @@ #:include "common.fypp" module stdlib_linalg_constants use stdlib_kinds, only: sp, dp, qp, int32, int64, lk -!$ use omp_lib + !$ use omp_lib implicit none(type,external) public diff --git a/src/stdlib_linalg_state.fypp b/src/stdlib_linalg_state.fypp index cea4a9ea5..1e8f2378e 100644 --- a/src/stdlib_linalg_state.fypp +++ b/src/stdlib_linalg_state.fypp @@ -6,17 +6,17 @@ module stdlib_linalg_state !! Provides a state/error handling derived type for advanced error handling of !! BLAS/LAPACK based linear algebra procedures. All procedures are pure. !! !! ([Specification](../page/specs/stdlib_linalg.html)) - use stdlib_linalg_constants,only:ilp,lk - use stdlib_kinds - use stdlib_io - use iso_fortran_env,only: stderr => error_unit + use stdlib_linalg_constants,only: ilp,sp,dp,qp,lk + use stdlib_kinds, only: int8, int16, int32, int64 + use stdlib_io, only: FMT_REAL_SP, FMT_REAL_DP, FMT_REAL_QP, FMT_COMPLEX_SP, FMT_COMPLEX_DP, & + FMT_COMPLEX_QP implicit none(type,external) private !> Version: experimental !> !> A fixed-storage state variable for error handling of linear algebra routines - public :: linalg_state + public :: linalg_state_type !> Version: experimental !> @@ -32,19 +32,19 @@ module stdlib_linalg_state public :: operator(>),operator(>=) !> State return types - integer(ilp),parameter,public :: LINALG_SUCCESS = 0_ilp - integer(ilp),parameter,public :: LINALG_VALUE_ERROR = -1_ilp - integer(ilp),parameter,public :: LINALG_ERROR = -2_ilp + integer(ilp),parameter,public :: LINALG_SUCCESS = 0_ilp + integer(ilp),parameter,public :: LINALG_VALUE_ERROR = -1_ilp + integer(ilp),parameter,public :: LINALG_ERROR = -2_ilp integer(ilp),parameter,public :: LINALG_INTERNAL_ERROR = -3_ilp !> Use fixed-size character storage for performance integer(ilp),parameter :: MSG_LENGTH = 512_ilp integer(ilp),parameter :: NAME_LENGTH = 32_ilp - !> `linalg_state` defines a state return type for a + !> `linalg_state_type` defines a state return type for a !> linear algebra routine. State contains a status flag, a comment, and a !> procedure specifier that can be used to mark where the error happened - type :: linalg_state + type :: linalg_state_type !> The current exit state integer(ilp) :: state = LINALG_SUCCESS @@ -58,17 +58,17 @@ module stdlib_linalg_state contains !> Cleanup - procedure :: destroy => state_destroy + procedure :: destroy => state_destroy !> Print error message - procedure :: print => state_print + procedure :: print => state_print procedure :: print_msg => state_message !> State properties - procedure :: ok => state_is_ok - procedure :: error => state_is_error + procedure :: ok => state_is_ok + procedure :: error => state_is_error - end type linalg_state + end type linalg_state_type !> Comparison operators interface operator(==) @@ -96,15 +96,15 @@ module stdlib_linalg_state module procedure flag_ge_state end interface - interface linalg_state + interface linalg_state_type module procedure new_state module procedure new_state_nowhere - end interface linalg_state + end interface linalg_state_type contains !> Interface to print linalg state flags - pure function LINALG_MESSAGE(flag) result(msg) + pure function linalg_message(flag) result(msg) integer(ilp),intent(in) :: flag character(len=:),allocatable :: msg @@ -116,12 +116,12 @@ module stdlib_linalg_state case default; msg = 'ERROR/INVALID FLAG' end select - end function LINALG_MESSAGE + end function linalg_message !> Flow control: on output flag present, return it; otherwise, halt on error pure subroutine linalg_error_handling(ierr,ierr_out) - type(linalg_state),intent(in) :: ierr - type(linalg_state),optional,intent(out) :: ierr_out + type(linalg_state_type),intent(in) :: ierr + type(linalg_state_type),optional,intent(out) :: ierr_out character(len=:),allocatable :: err_msg @@ -137,20 +137,20 @@ module stdlib_linalg_state !> Formatted message pure function state_message(this) result(msg) - class(linalg_state),intent(in) :: this + class(linalg_state_type),intent(in) :: this character(len=:),allocatable :: msg if (this%state == LINALG_SUCCESS) then msg = 'Success!' else - msg = LINALG_MESSAGE(this%state)//': '//trim(this%message) + msg = linalg_message(this%state)//': '//trim(this%message) end if end function state_message !> Produce a nice error string pure function state_print(this) result(msg) - class(linalg_state),intent(in) :: this + class(linalg_state_type),intent(in) :: this character(len=:),allocatable :: msg if (len_trim(this%where_at) > 0) then @@ -165,7 +165,7 @@ module stdlib_linalg_state !> Cleanup the object elemental subroutine state_destroy(this) - class(linalg_state),intent(inout) :: this + class(linalg_state_type),intent(inout) :: this this%state = LINALG_SUCCESS this%message = repeat(' ',len(this%message)) @@ -175,19 +175,19 @@ module stdlib_linalg_state !> Check if the current state is successful elemental logical(lk) function state_is_ok(this) - class(linalg_state),intent(in) :: this + class(linalg_state_type),intent(in) :: this state_is_ok = this%state == LINALG_SUCCESS end function state_is_ok !> Check if the current state is an error state elemental logical(lk) function state_is_error(this) - class(linalg_state),intent(in) :: this + class(linalg_state_type),intent(in) :: this state_is_error = this%state /= LINALG_SUCCESS end function state_is_error !> Compare an error state with an integer flag elemental logical(lk) function state_eq_flag(err,flag) - type(linalg_state),intent(in) :: err + type(linalg_state_type),intent(in) :: err integer,intent(in) :: flag state_eq_flag = err%state == flag end function state_eq_flag @@ -195,13 +195,13 @@ module stdlib_linalg_state !> Compare an integer flag with the error state elemental logical(lk) function flag_eq_state(flag,err) integer,intent(in) :: flag - type(linalg_state),intent(in) :: err + type(linalg_state_type),intent(in) :: err flag_eq_state = err%state == flag end function flag_eq_state !> Compare the error state with an integer flag elemental logical(lk) function state_neq_flag(err,flag) - type(linalg_state),intent(in) :: err + type(linalg_state_type),intent(in) :: err integer,intent(in) :: flag state_neq_flag = .not. state_eq_flag(err,flag) end function state_neq_flag @@ -209,20 +209,20 @@ module stdlib_linalg_state !> Compare an integer flag with the error state elemental logical(lk) function flag_neq_state(flag,err) integer,intent(in) :: flag - type(linalg_state),intent(in) :: err + type(linalg_state_type),intent(in) :: err flag_neq_state = .not. state_eq_flag(err,flag) end function flag_neq_state !> Compare the error state with an integer flag elemental logical(lk) function state_lt_flag(err,flag) - type(linalg_state),intent(in) :: err + type(linalg_state_type),intent(in) :: err integer,intent(in) :: flag state_lt_flag = err%state < flag end function state_lt_flag !> Compare the error state with an integer flag elemental logical(lk) function state_le_flag(err,flag) - type(linalg_state),intent(in) :: err + type(linalg_state_type),intent(in) :: err integer,intent(in) :: flag state_le_flag = err%state <= flag end function state_le_flag @@ -230,27 +230,27 @@ module stdlib_linalg_state !> Compare an integer flag with the error state elemental logical(lk) function flag_lt_state(flag,err) integer,intent(in) :: flag - type(linalg_state),intent(in) :: err + type(linalg_state_type),intent(in) :: err flag_lt_state = err%state < flag end function flag_lt_state !> Compare an integer flag with the error state elemental logical(lk) function flag_le_state(flag,err) integer,intent(in) :: flag - type(linalg_state),intent(in) :: err + type(linalg_state_type),intent(in) :: err flag_le_state = err%state <= flag end function flag_le_state !> Compare the error state with an integer flag elemental logical(lk) function state_gt_flag(err,flag) - type(linalg_state),intent(in) :: err + type(linalg_state_type),intent(in) :: err integer,intent(in) :: flag state_gt_flag = err%state > flag end function state_gt_flag !> Compare the error state with an integer flag elemental logical(lk) function state_ge_flag(err,flag) - type(linalg_state),intent(in) :: err + type(linalg_state_type),intent(in) :: err integer,intent(in) :: flag state_ge_flag = err%state >= flag end function state_ge_flag @@ -258,19 +258,19 @@ module stdlib_linalg_state !> Compare an integer flag with the error state elemental logical(lk) function flag_gt_state(flag,err) integer,intent(in) :: flag - type(linalg_state),intent(in) :: err + type(linalg_state_type),intent(in) :: err flag_gt_state = err%state > flag end function flag_gt_state !> Compare an integer flag with the error state elemental logical(lk) function flag_ge_state(flag,err) integer,intent(in) :: flag - type(linalg_state),intent(in) :: err + type(linalg_state_type),intent(in) :: err flag_ge_state = err%state >= flag end function flag_ge_state !> Error creation message, with location location - pure type(linalg_state) function new_state(where_at,flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + pure type(linalg_state_type) function new_state(where_at,flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & v1,v2,v3,v4,v5) !> Location @@ -294,7 +294,7 @@ module stdlib_linalg_state end function new_state !> Error creation message, from N input variables (numeric or strings) - pure type(linalg_state) function new_state_nowhere(flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + pure type(linalg_state_type) function new_state_nowhere(flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & v1,v2,v3,v4,v5) result(new_state) !> Input error flag diff --git a/test/linalg/test_linalg.fypp b/test/linalg/test_linalg.fypp index 77e95422a..8c543bc74 100644 --- a/test/linalg/test_linalg.fypp +++ b/test/linalg/test_linalg.fypp @@ -5,7 +5,7 @@ module test_linalg use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test use stdlib_kinds, only: sp, dp, xdp, qp, int8, int16, int32, int64 use stdlib_linalg, only: diag, eye, trace, outer_product, cross_product, kronecker_product - use stdlib_linalg_state + use stdlib_linalg_state, only: linalg_state_type, LINALG_SUCCESS, linalg_error_handling implicit none @@ -917,56 +917,56 @@ contains !> Error handling type(error_type), allocatable, intent(out) :: error - type(linalg_state) :: state,state_out + type(linalg_state_type) :: state,state_out - state = linalg_state(LINALG_SUCCESS,' 32-bit real: ',1.0_sp) + state = linalg_state_type(LINALG_SUCCESS,' 32-bit real: ',1.0_sp) call check(error, & state%message==' 32-bit real: 1.00000000E+00', & "malformed state message with 32-bit reals.") if (allocated(error)) return - state = linalg_state(LINALG_SUCCESS,' 64-bit real: ',1.0_dp) + state = linalg_state_type(LINALG_SUCCESS,' 64-bit real: ',1.0_dp) call check(error, & state%message==' 64-bit real: 1.0000000000000000E+000', & "malformed state message with 64-bit reals.") if (allocated(error)) return #:if WITH_QP - state = linalg_state(LINALG_SUCCESS,' 128-bit real: ',1.0_qp) + state = linalg_state_type(LINALG_SUCCESS,' 128-bit real: ',1.0_qp) call check(error, & state%message==' 128-bit real: 1.00000000000000000000000000000000000E+0000', & "malformed state message with 128-bit reals.") if (allocated(error)) return #:endif - state = linalg_state(LINALG_SUCCESS,' 32-bit complex: ',(1.0_sp,1.0_sp)) + state = linalg_state_type(LINALG_SUCCESS,' 32-bit complex: ',(1.0_sp,1.0_sp)) call check(error, & state%message==' 32-bit complex: (1.00000000E+00,1.00000000E+00)', & "malformed state message with 32-bit complex: "//trim(state%message)) if (allocated(error)) return - state = linalg_state(LINALG_SUCCESS,' 64-bit complex: ',(1.0_dp,1.0_dp)) + state = linalg_state_type(LINALG_SUCCESS,' 64-bit complex: ',(1.0_dp,1.0_dp)) call check(error, & state%message==' 64-bit complex: (1.0000000000000000E+000,1.0000000000000000E+000)', & "malformed state message with 64-bit complex.") if (allocated(error)) return #:if WITH_QP - state = linalg_state(LINALG_SUCCESS,'128-bit complex: ',(1.0_qp,1.0_qp)) + state = linalg_state_type(LINALG_SUCCESS,'128-bit complex: ',(1.0_qp,1.0_qp)) call check(error, state%message== & '128-bit complex: (1.00000000000000000000000000000000000E+0000,1.00000000000000000000000000000000000E+0000)', & "malformed state message with 128-bit complex.") #:endif - state = linalg_state(LINALG_SUCCESS,' 32-bit array: ',v1=[(1.0_sp,0.0_sp),(0.0_sp,1.0_sp)]) + state = linalg_state_type(LINALG_SUCCESS,' 32-bit array: ',v1=[(1.0_sp,0.0_sp),(0.0_sp,1.0_sp)]) call check(error, state%message== & ' 32-bit array: [(1.00000000E+00,0.00000000E+00) (0.00000000E+00,1.00000000E+00)]', & "malformed state message with 32-bit real array.") if (allocated(error)) return !> State flag with location - state = linalg_state('test_formats',LINALG_SUCCESS,' 32-bit real: ',1.0_sp) + state = linalg_state_type('test_formats',LINALG_SUCCESS,' 32-bit real: ',1.0_sp) call check(error, & state%print()=='[test_formats] returned Success!', & "malformed state message with 32-bit real and location.") From 3762517ea14229e47b06c31aa0fd3d4e2d35ec8b Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Tue, 26 Mar 2024 11:21:10 +0100 Subject: [PATCH 10/27] documentation + example --- doc/specs/index.md | 1 + doc/specs/stdlib_linalg_state_type.md | 64 +++++++++++++++++++++++++++ example/linalg/example_state1.f90 | 18 ++++++++ 3 files changed, 83 insertions(+) create mode 100644 doc/specs/stdlib_linalg_state_type.md create mode 100644 example/linalg/example_state1.f90 diff --git a/doc/specs/index.md b/doc/specs/index.md index 1378fa8b8..b61b16042 100644 --- a/doc/specs/index.md +++ b/doc/specs/index.md @@ -22,6 +22,7 @@ This is an index/directory of the specifications (specs) for each new module/fea - [io](./stdlib_io.html) - Input/output helper & convenience - [kinds](./stdlib_kinds.html) - Kind parameters - [linalg](./stdlib_linalg.html) - Linear Algebra + - [linalg_state_type](./stdlib_linalg_state_type.html) - Linear Algebra state and error handling - [logger](./stdlib_logger.html) - Runtime logging system - [math](./stdlib_math.html) - General purpose mathematical functions - [optval](./stdlib_optval.html) - Fallback value for optional arguments diff --git a/doc/specs/stdlib_linalg_state_type.md b/doc/specs/stdlib_linalg_state_type.md new file mode 100644 index 000000000..54070fe4b --- /dev/null +++ b/doc/specs/stdlib_linalg_state_type.md @@ -0,0 +1,64 @@ +--- +title: linalg_state_type +--- + +# Linear Algebra -- State and Error Handling Module + +[TOC] + +## Introduction + +The `stdlib_linalg_state` module provides a derived type holding information on the +state of linear algebra operations, and procedures for expert control of linear algebra workflows. +All linear algebra procedures are engineered to support returning an optional `linalg_state_type` +variable to holds such information, as a form of expert API. If the user does not require state +information, but fatal errors are encountered during the execution of linear algebra routines, the +program will undergo a hard stop. +Instead, if the state argument is present, the program will never stop, but will return detailed error +information into the state handler. + +## Derived types provided + + +### The `linalg_state_type` derived type + +The `linalg_state_type` is defined as a derived type containing an integer error flag, and +fixed-size character strings to store an error message and the location of the error state change. +Fixed-size string storage was chosen to facilitate the compiler's memory allocation and ultimately +ensure maximum computational performance. + +A similarly named generic interface, `linalg_state_type`, is provided to allow the developer to +create diagnostic messages and raise error flags easily. The call starts with an error flag or +the location of the event, and is followed by an arbitrary list of `integer`, `real`, `complex` or +`character` variables. Numeric variables may be provided as either scalars or rank-1 (array) inputs. + +#### Type-bound procedures + +The following convenience type-bound procedures are provided: +- `print()` returns an allocatable character string containing state location, message, and error flag; +- `print_message()` returns an allocatable character string containing the state message; +- `ok()` returns a `logical` flag that is `.true.` in case of successful state (`flag==LINALG_SUCCESS`); +- `error()` returns a `logical` flag that is `.true.` in case of error state (`flag/=LINALG_SUCCESS`). + +#### Status + +Experimental + +#### Example + +```fortran +{!example/linalg/example_state1.f90!} +``` + +## Error flags provided + +The module provides the following state flags: +- `LINALG_SUCCESS`: Successful execution +- `LINALG_VALUE_ERROR`: Numerical errors (such as infinity, not-a-number, range bounds) are encountered. +- `LINALG_ERROR`: Linear Algebra errors are encountered, such as: non-converging iterations, impossible operations, etc. +- `LINALG_INTERNAL_ERROR`: Provided as a developer safeguard for internal errors that should never occur. + +## Comparison operators provided + +The module provides overloaded comparison operators for all comparisons of a `linalg_state_type` variable +with an integer error flag: `<`, `<=`, `==`, `>=`, `>`, `/=`. diff --git a/example/linalg/example_state1.f90 b/example/linalg/example_state1.f90 new file mode 100644 index 000000000..adc7e4121 --- /dev/null +++ b/example/linalg/example_state1.f90 @@ -0,0 +1,18 @@ +program example_state1 + use stdlib_linalg_state + implicit none + type(linalg_state_type) :: err + + ! Create a state flag + err = linalg_state_type(LINALG_VALUE_ERROR,'just an example with scalar ',& + 'integer=',1,'real=',2.0,'complex=',(3.0,1.0),'and array ',[1,2,3],'inputs') + + ! Print flag + print *, err%print() + + ! Check success + print *, 'Check error: ',err%error() + print *, 'Check flag : ',err /= LINALG_SUCCESS + + +end program example_state1 From cb9a7fcc6ca3751d1a43c928740b084cf05c78f8 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Tue, 26 Mar 2024 11:22:20 +0100 Subject: [PATCH 11/27] generalize interface (`rank`-agnostic) --- src/stdlib_linalg_state.fypp | 89 +++++++++++++++++++++++------------- test/linalg/test_linalg.fypp | 2 +- 2 files changed, 57 insertions(+), 34 deletions(-) diff --git a/src/stdlib_linalg_state.fypp b/src/stdlib_linalg_state.fypp index 1e8f2378e..47cf83ac5 100644 --- a/src/stdlib_linalg_state.fypp +++ b/src/stdlib_linalg_state.fypp @@ -271,7 +271,7 @@ module stdlib_linalg_state !> Error creation message, with location location pure type(linalg_state_type) function new_state(where_at,flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & - v1,v2,v3,v4,v5) + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20) !> Location character(len=*),intent(in) :: where_at @@ -279,14 +279,13 @@ module stdlib_linalg_state !> Input error flag integer,intent(in) :: flag - !> Optional scalar arguments - class(*),optional,intent(in) :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10 - - !> Optional vector arguments - class(*),optional,intent(in),dimension(:) :: v1,v2,v3,v4,v5 + !> Optional rank-agnostic arguments + class(*),optional,intent(in),dimension(..) :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20 !> Create state with no message - new_state = new_state_nowhere(flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,v1,v2,v3,v4,v5) + new_state = new_state_nowhere(flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20) !> Add location if (len_trim(where_at) > 0) new_state%where_at = adjustl(where_at) @@ -295,16 +294,15 @@ module stdlib_linalg_state !> Error creation message, from N input variables (numeric or strings) pure type(linalg_state_type) function new_state_nowhere(flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & - v1,v2,v3,v4,v5) result(new_state) + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20) & + result(new_state) !> Input error flag integer,intent(in) :: flag - !> Optional scalar arguments - class(*),optional,intent(in) :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10 - - !> Optional vector arguments - class(*),optional,intent(in),dimension(:) :: v1,v2,v3,v4,v5 + !> Optional rank-agnostic arguments + class(*),optional,intent(in),dimension(..) :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20 ! Init object call new_state%destroy() @@ -314,27 +312,55 @@ module stdlib_linalg_state !> Set chain new_state%message = "" - call append(new_state%message,a1) - call append(new_state%message,a2) - call append(new_state%message,a3) - call append(new_state%message,a4) - call append(new_state%message,a5) - call append(new_state%message,a6) - call append(new_state%message,a7) - call append(new_state%message,a8) - call append(new_state%message,a9) - call append(new_state%message,a10) - call appendv(new_state%message,v1) - call appendv(new_state%message,v2) - call appendv(new_state%message,v3) - call appendv(new_state%message,v4) - call appendv(new_state%message,v5) + call appendr(new_state%message,a1) + call appendr(new_state%message,a2) + call appendr(new_state%message,a3) + call appendr(new_state%message,a4) + call appendr(new_state%message,a5) + call appendr(new_state%message,a6) + call appendr(new_state%message,a7) + call appendr(new_state%message,a8) + call appendr(new_state%message,a9) + call appendr(new_state%message,a10) + call appendr(new_state%message,a11) + call appendr(new_state%message,a12) + call appendr(new_state%message,a13) + call appendr(new_state%message,a14) + call appendr(new_state%message,a15) + call appendr(new_state%message,a16) + call appendr(new_state%message,a17) + call appendr(new_state%message,a18) + call appendr(new_state%message,a19) + call appendr(new_state%message,a20) end function new_state_nowhere + ! Append a generic value to the error flag (rank-agnostic) + pure subroutine appendr(msg,a,prefix) + class(*),optional,intent(in) :: a(..) + character(len=*),intent(inout) :: msg + character,optional,intent(in) :: prefix + + character(len=MSG_LENGTH) :: buffer + + if (present(a)) then + select rank (v=>a) + rank (0) + call append (msg,v,prefix) + rank (1) + call appendv(msg,v) + rank default + write (buffer,'(i0)') rank(v) + msg = trim(msg)//' ' + + end select + endif + + end subroutine appendr + ! Append a generic value to the error flag pure subroutine append(msg,a,prefix) - class(*),optional,intent(in) :: a + class(*),intent(in) :: a character(len=*),intent(inout) :: msg character,optional,intent(in) :: prefix @@ -342,8 +368,6 @@ module stdlib_linalg_state character(len=2) :: sep integer :: ls - if (.not. present(a)) return - ! Do not add separator if this is the first instance sep = ' ' ls = merge(1,0,len_trim(msg) > 0) @@ -385,14 +409,13 @@ module stdlib_linalg_state ! Append a generic vector to the error flag pure subroutine appendv(msg,a) - class(*),optional,intent(in) :: a(:) + class(*),intent(in) :: a(:) character(len=*),intent(inout) :: msg integer :: j,ls character(len=MSG_LENGTH) :: buffer,buffer2,buffer_format character(len=2) :: sep - if (.not. present(a)) return if (size(a) <= 0) return ! Default: separate elements with one space diff --git a/test/linalg/test_linalg.fypp b/test/linalg/test_linalg.fypp index 8c543bc74..fcb9c6abb 100644 --- a/test/linalg/test_linalg.fypp +++ b/test/linalg/test_linalg.fypp @@ -959,7 +959,7 @@ contains #:endif - state = linalg_state_type(LINALG_SUCCESS,' 32-bit array: ',v1=[(1.0_sp,0.0_sp),(0.0_sp,1.0_sp)]) + state = linalg_state_type(LINALG_SUCCESS,' 32-bit array: ',[(1.0_sp,0.0_sp),(0.0_sp,1.0_sp)]) call check(error, state%message== & ' 32-bit array: [(1.00000000E+00,0.00000000E+00) (0.00000000E+00,1.00000000E+00)]', & "malformed state message with 32-bit real array.") From 0782e43a779030da56751018f1a40e96ff392344 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Tue, 26 Mar 2024 11:38:32 +0100 Subject: [PATCH 12/27] add `xdp` formats --- src/stdlib_linalg_state.fypp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/stdlib_linalg_state.fypp b/src/stdlib_linalg_state.fypp index 47cf83ac5..5591203ac 100644 --- a/src/stdlib_linalg_state.fypp +++ b/src/stdlib_linalg_state.fypp @@ -9,7 +9,7 @@ module stdlib_linalg_state use stdlib_linalg_constants,only: ilp,sp,dp,qp,lk use stdlib_kinds, only: int8, int16, int32, int64 use stdlib_io, only: FMT_REAL_SP, FMT_REAL_DP, FMT_REAL_QP, FMT_COMPLEX_SP, FMT_COMPLEX_DP, & - FMT_COMPLEX_QP + FMT_COMPLEX_QP, FMT_REAL_XDP, FMT_COMPLEX_XDP implicit none(type,external) private From b9e7e6704902caba3236c4d16e1e0f652c86e2f0 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Tue, 26 Mar 2024 11:40:29 +0100 Subject: [PATCH 13/27] intel compiler issue: remove buffer write --- src/stdlib_linalg_state.fypp | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/stdlib_linalg_state.fypp b/src/stdlib_linalg_state.fypp index 5591203ac..c9b568419 100644 --- a/src/stdlib_linalg_state.fypp +++ b/src/stdlib_linalg_state.fypp @@ -341,8 +341,6 @@ module stdlib_linalg_state character(len=*),intent(inout) :: msg character,optional,intent(in) :: prefix - character(len=MSG_LENGTH) :: buffer - if (present(a)) then select rank (v=>a) rank (0) @@ -350,7 +348,6 @@ module stdlib_linalg_state rank (1) call appendv(msg,v) rank default - write (buffer,'(i0)') rank(v) msg = trim(msg)//' ' end select From affd5d0a474c77974d84c962be0ac7e0a409da28 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Tue, 26 Mar 2024 11:45:37 +0100 Subject: [PATCH 14/27] add `xdp` symbol --- src/stdlib_linalg_state.fypp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/stdlib_linalg_state.fypp b/src/stdlib_linalg_state.fypp index c9b568419..63e5ef449 100644 --- a/src/stdlib_linalg_state.fypp +++ b/src/stdlib_linalg_state.fypp @@ -6,7 +6,7 @@ module stdlib_linalg_state !! Provides a state/error handling derived type for advanced error handling of !! BLAS/LAPACK based linear algebra procedures. All procedures are pure. !! !! ([Specification](../page/specs/stdlib_linalg.html)) - use stdlib_linalg_constants,only: ilp,sp,dp,qp,lk + use stdlib_linalg_constants,only: ilp,sp,dp,xdp,qp,lk use stdlib_kinds, only: int8, int16, int32, int64 use stdlib_io, only: FMT_REAL_SP, FMT_REAL_DP, FMT_REAL_QP, FMT_COMPLEX_SP, FMT_COMPLEX_DP, & FMT_COMPLEX_QP, FMT_REAL_XDP, FMT_COMPLEX_XDP From 322b37ef7a21904ae3feff692dcac663dff56df1 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Tue, 26 Mar 2024 12:30:53 +0100 Subject: [PATCH 15/27] move kinds to `stdlib_kinds` --- src/stdlib_linalg_state.fypp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/stdlib_linalg_state.fypp b/src/stdlib_linalg_state.fypp index 63e5ef449..46dc5c964 100644 --- a/src/stdlib_linalg_state.fypp +++ b/src/stdlib_linalg_state.fypp @@ -6,8 +6,8 @@ module stdlib_linalg_state !! Provides a state/error handling derived type for advanced error handling of !! BLAS/LAPACK based linear algebra procedures. All procedures are pure. !! !! ([Specification](../page/specs/stdlib_linalg.html)) - use stdlib_linalg_constants,only: ilp,sp,dp,xdp,qp,lk - use stdlib_kinds, only: int8, int16, int32, int64 + use stdlib_linalg_constants,only: ilp + use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp, lk use stdlib_io, only: FMT_REAL_SP, FMT_REAL_DP, FMT_REAL_QP, FMT_COMPLEX_SP, FMT_COMPLEX_DP, & FMT_COMPLEX_QP, FMT_REAL_XDP, FMT_COMPLEX_XDP implicit none(type,external) From 41bf3a3fe84d2f79e6b6bbe3fca8833a2130df3b Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Tue, 2 Apr 2024 11:09:12 +0200 Subject: [PATCH 16/27] remove duplicate `stdlib_linalg_constants.fypp` --- src/CMakeLists.txt | 1 - 1 file changed, 1 deletion(-) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 85f85bb67..165259db3 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -23,7 +23,6 @@ set(fppFiles stdlib_linalg_diag.fypp stdlib_linalg_outer_product.fypp stdlib_linalg_kronecker.fypp - stdlib_linalg_constants.fypp stdlib_linalg_cross_product.fypp stdlib_linalg_state.fypp stdlib_optval.fypp From a90f25a34a346cf09b148522637abf6c6cee25fe Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Tue, 2 Apr 2024 20:01:01 +0200 Subject: [PATCH 17/27] more explanation --- example/linalg/example_state1.f90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/example/linalg/example_state1.f90 b/example/linalg/example_state1.f90 index adc7e4121..ce6f8f44d 100644 --- a/example/linalg/example_state1.f90 +++ b/example/linalg/example_state1.f90 @@ -3,7 +3,8 @@ program example_state1 implicit none type(linalg_state_type) :: err - ! Create a state flag + ! To create a state flag, we enter a state flag, followed by any list of variables + ! that will be assembled into a formatted error message err = linalg_state_type(LINALG_VALUE_ERROR,'just an example with scalar ',& 'integer=',1,'real=',2.0,'complex=',(3.0,1.0),'and array ',[1,2,3],'inputs') From fb008b4f82bb002de166497dfcf4073751c52f6a Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Tue, 2 Apr 2024 20:02:10 +0200 Subject: [PATCH 18/27] Update example_state1.f90 --- example/linalg/example_state1.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/example/linalg/example_state1.f90 b/example/linalg/example_state1.f90 index ce6f8f44d..70c33fe58 100644 --- a/example/linalg/example_state1.f90 +++ b/example/linalg/example_state1.f90 @@ -3,8 +3,8 @@ program example_state1 implicit none type(linalg_state_type) :: err - ! To create a state flag, we enter a state flag, followed by any list of variables - ! that will be assembled into a formatted error message + ! To create a state variable, we enter its integer state flag, followed by a list of variables + ! that will be automatically assembled into a formatted error message. No need to provide string formats err = linalg_state_type(LINALG_VALUE_ERROR,'just an example with scalar ',& 'integer=',1,'real=',2.0,'complex=',(3.0,1.0),'and array ',[1,2,3],'inputs') From 00db3245d2167de27b30633751a806c30293d95b Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sat, 6 Apr 2024 12:30:49 +0200 Subject: [PATCH 19/27] add another state example --- example/linalg/CMakeLists.txt | 4 ++ example/linalg/example_state2.f90 | 63 +++++++++++++++++++++++++++++++ 2 files changed, 67 insertions(+) create mode 100644 example/linalg/example_state2.f90 diff --git a/example/linalg/CMakeLists.txt b/example/linalg/CMakeLists.txt index 3f31a5574..1a5875502 100644 --- a/example/linalg/CMakeLists.txt +++ b/example/linalg/CMakeLists.txt @@ -14,3 +14,7 @@ ADD_EXAMPLE(is_symmetric) ADD_EXAMPLE(is_triangular) ADD_EXAMPLE(outer_product) ADD_EXAMPLE(trace) +ADD_EXAMPLE(state1) +ADD_EXAMPLE(state2) +ADD_EXAMPLE(blas_gemv) +ADD_EXAMPLE(lapack_getrf) diff --git a/example/linalg/example_state2.f90 b/example/linalg/example_state2.f90 new file mode 100644 index 000000000..fedf891af --- /dev/null +++ b/example/linalg/example_state2.f90 @@ -0,0 +1,63 @@ +program example_state2 + !! This example shows how to set a `type(linalg_state)` variable to process output conditions + !! out of a simple division routine. The example is meant to highlight: + !! 1) the different mechanisms that can be used to initialize the `linalg_state` variable providing + !! strings, scalars, or arrays, on input to it; + !! 2) `pure` setup of the error control + use stdlib_linalg_state + implicit none + integer :: info + type(linalg_state_type) :: err + real :: a_div_b + + ! OK + call very_simple_division(0.0,2.0,a_div_b,err) + print *, err%print() + + ! Division by zero + call very_simple_division(1.0,0.0,a_div_b,err) + print *, err%print() + + ! Out of bounds + call very_simple_division(huge(0.0),0.001,a_div_b,err) + print *, err%print() + + contains + + !> Simple division returning an integer flag (LAPACK style) + elemental subroutine very_simple_division(a,b,a_div_b,err) + real, intent(in) :: a,b + real, intent(out) :: a_div_b + type(linalg_state_type), optional, intent(out) :: err + + type(linalg_state_type) :: err0 + real, parameter :: MAXABS = huge(0.0) + character(*), parameter :: this = 'simple division' + + !> Check a + if (b==0.0) then + ! Division by zero + err0 = linalg_state_type(this,LINALG_VALUE_ERROR,'Division by zero trying ',a,'/',b) + elseif (.not.abs(b)