|  | 
|  | 1 | +program example_state2 | 
|  | 2 | + !! This example shows how to set a `type(linalg_state_type)` variable to process output conditions  | 
|  | 3 | + !! out of a simple division routine. The example is meant to highlight:  | 
|  | 4 | + !! 1) the different mechanisms that can be used to initialize the `linalg_state` variable providing  | 
|  | 5 | + !! strings, scalars, or arrays, on input to it;  | 
|  | 6 | + !! 2) `pure` setup of the error control | 
|  | 7 | + use stdlib_linalg_state, only: linalg_state_type, LINALG_VALUE_ERROR, LINALG_SUCCESS, & | 
|  | 8 | + linalg_error_handling | 
|  | 9 | + implicit none | 
|  | 10 | + integer :: info | 
|  | 11 | + type(linalg_state_type) :: err | 
|  | 12 | + real :: a_div_b | 
|  | 13 | + | 
|  | 14 | + ! OK | 
|  | 15 | + call very_simple_division(0.0,2.0,a_div_b,err) | 
|  | 16 | + print *, err%print() | 
|  | 17 | + | 
|  | 18 | + ! Division by zero | 
|  | 19 | + call very_simple_division(1.0,0.0,a_div_b,err) | 
|  | 20 | + print *, err%print()  | 
|  | 21 | + | 
|  | 22 | + ! Out of bounds | 
|  | 23 | + call very_simple_division(huge(0.0),0.001,a_div_b,err) | 
|  | 24 | + print *, err%print()  | 
|  | 25 | + | 
|  | 26 | + contains | 
|  | 27 | + | 
|  | 28 | + !> Simple division returning an integer flag (LAPACK style) | 
|  | 29 | + elemental subroutine very_simple_division(a,b,a_div_b,err) | 
|  | 30 | + real, intent(in) :: a,b | 
|  | 31 | + real, intent(out) :: a_div_b | 
|  | 32 | + type(linalg_state_type), optional, intent(out) :: err | 
|  | 33 | + | 
|  | 34 | + type(linalg_state_type) :: err0 | 
|  | 35 | + real, parameter :: MAXABS = huge(0.0) | 
|  | 36 | + character(*), parameter :: this = 'simple division' | 
|  | 37 | + | 
|  | 38 | + !> Check a | 
|  | 39 | + if (b==0.0) then  | 
|  | 40 | + ! Division by zero | 
|  | 41 | + err0 = linalg_state_type(this,LINALG_VALUE_ERROR,'Division by zero trying ',a,'/',b) | 
|  | 42 | + elseif (.not.abs(b)<MAXABS) then  | 
|  | 43 | + ! B is out of bounds | 
|  | 44 | + err0 = linalg_state_type(this,LINALG_VALUE_ERROR,'B is infinity in a/b: ',[a,b]) ! use an array | 
|  | 45 | + elseif (.not.abs(a)<MAXABS) then  | 
|  | 46 | + ! A is out of bounds | 
|  | 47 | + err0 = linalg_state_type(this,LINALG_VALUE_ERROR,'A is infinity in a/b: a=',a,' b=',b) | 
|  | 48 | + else | 
|  | 49 | + a_div_b = a/b | 
|  | 50 | + if (.not.abs(a_div_b)<MAXABS) then  | 
|  | 51 | + ! Result is out of bounds | 
|  | 52 | + err0 = linalg_state_type(this,LINALG_VALUE_ERROR,'A/B is infinity in a/b: a=',a,' b=',b) | 
|  | 53 | + else | 
|  | 54 | + err0%state = LINALG_SUCCESS | 
|  | 55 | + end if | 
|  | 56 | + end if | 
|  | 57 | + | 
|  | 58 | + ! Return error flag, or hard stop on failure | 
|  | 59 | + call linalg_error_handling(err0,err) | 
|  | 60 | + | 
|  | 61 | + end subroutine very_simple_division | 
|  | 62 | + | 
|  | 63 | + | 
|  | 64 | +end program example_state2 | 
0 commit comments