├── src ├── uncertainties_io.f90 ├── uncertainties_func.f90 ├── uncertainties.f90 └── uncertainties_arith.f90 ├── main ├── check1.f90 ├── check3.f90 └── check2.f90 ├── Makefile └── README.md /src/uncertainties_io.f90: -------------------------------------------------------------------------------- 1 | ! 2 | ! A MODULE 3 | ! 4 | ! "THE BEER-WARE LICENSE": 5 | ! Alberto Ramos wrote this file. As long as you retain this 6 | ! notice you can do whatever you want with this stuff. If we meet some 7 | ! day, and you think this stuff is worth it, you can buy me a beer in 8 | ! return. 9 | ! 10 | ! $ v1.0 201XXXXX $ 11 | ! 12 | 13 | submodule (uncertainties) uncertainties_io 14 | 15 | implicit none 16 | 17 | integer, allocatable :: ws_map(:,:), ws_ids(:) 18 | integer :: ns = -1 19 | 20 | 21 | contains 22 | 23 | 24 | end submodule uncertainties_io 25 | -------------------------------------------------------------------------------- /main/check1.f90: -------------------------------------------------------------------------------- 1 | 2 | ! THE BEER-WARE LICENSE: 3 | ! Alberto Ramos wrote this file. As long as you retain this 4 | ! notice you can do whatever you want with this stuff. If we meet some 5 | ! day, and you think this stuff is worth it, you can buy me a beer in 6 | ! return. 7 | ! 8 | ! $ v1.0 $ 9 | ! 10 | 11 | program check 12 | 13 | use uncertainties 14 | 15 | type (ureal) :: x, y, z, w1, w2 16 | 17 | x = (/3.0_DP,0.1_DP/) 18 | y = (/12.0_DP,0.1_DP/) 19 | z = (/2.0_DP,0.2_DP/) 20 | write(*,*)'x: ', x%x, sqrt(sum(x%del**2)) 21 | write(*,*)'y: ', y%x, sqrt(sum(y%del**2)) 22 | write(*,*)'z: ', z%x, sqrt(sum(z%del**2)) 23 | 24 | w1 = ((x+y)*((x-y)/z) + y/z) * z - x**2+y*y 25 | w2 = w1 - y 26 | write(*,*)'zero: ', w2%x, sqrt(sum(w2%del**2)) 27 | 28 | 29 | stop 30 | end program check 31 | -------------------------------------------------------------------------------- /main/check3.f90: -------------------------------------------------------------------------------- 1 | 2 | ! THE BEER-WARE LICENSE: 3 | ! Alberto Ramos wrote this file. As long as you retain this 4 | ! notice you can do whatever you want with this stuff. If we meet some 5 | ! day, and you think this stuff is worth it, you can buy me a beer in 6 | ! return. 7 | ! 8 | ! $ v1.0 $ 9 | ! 10 | 11 | program check 12 | 13 | use uncertainties 14 | 15 | type (ureal) :: x, y, z, w1, w2, w3 16 | 17 | x = (/3.0_DP,0.1_DP/) 18 | y = (/12.0_DP,0.1_DP/) 19 | z = (/2.0_DP,0.2_DP/) 20 | write(*,'(1A)', advance="NO")'x: ' 21 | call x%write() 22 | write(*,'(1A)', advance="NO")'y: ' 23 | call y%write() 24 | write(*,'(1A)', advance="NO")'z: ' 25 | call z%write() 26 | 27 | w1 = cosh(x+y) 28 | w2 = (cosh(x)*cosh(y) + sinh(x)*sinh(y)) 29 | w3 = w1 - w2 30 | write(*,'(1A)', advance="NO")'zero: ' 31 | call w3%write() 32 | 33 | w1 = tanh(x+z) 34 | w2 = (tanh(x)+tanh(z))/(1.0_DP + tanh(x)*tanh(z)) 35 | w3 = w1 - w2 36 | write(*,'(1A)', advance="NO")'zero: ' 37 | call w3%write() 38 | 39 | stop 40 | end program check 41 | -------------------------------------------------------------------------------- /main/check2.f90: -------------------------------------------------------------------------------- 1 | 2 | ! THE BEER-WARE LICENSE: 3 | ! Alberto Ramos wrote this file. As long as you retain this 4 | ! notice you can do whatever you want with this stuff. If we meet some 5 | ! day, and you think this stuff is worth it, you can buy me a beer in 6 | ! return. 7 | ! 8 | ! $ v1.0 $ 9 | ! 10 | 11 | program check 12 | 13 | use uncertainties 14 | 15 | type (ureal) :: x, y, z, w1, w2, w3 16 | 17 | x = (/3.0_DP,0.1_DP/) 18 | y = (/12.0_DP,0.1_DP/) 19 | z = (/2.0_DP,0.2_DP/) 20 | write(*,'(1A)', advance="NO")'x: ' 21 | call x%write() 22 | write(*,'(1A)', advance="NO")'y: ' 23 | call y%write() 24 | write(*,'(1A)', advance="NO")'z: ' 25 | call z%write() 26 | 27 | w1 = sin(x+y) 28 | w2 = (sin(x)*cos(y) + cos(x)*sin(y)) 29 | w1 = w1 - w2 30 | write(*,'(1A)', advance="NO")'zero: ' 31 | call w1%write() 32 | 33 | w2 = exp(x) 34 | write(*,'(1A)', advance="NO")'exp(x):' 35 | call w2%write() 36 | w3 = log(w2) - x 37 | write(*,'(1A)', advance="NO")'zero: ' 38 | call w3%write() 39 | 40 | stop 41 | end program check 42 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | #F90=mpif90 -warn all -std08 #-openmp 3 | F90=gfortran6 -std=f2008 -Wall -pedantic -march=native -funroll-loops -O0 -finline-limit=60 -fbacktrace -ffpe-trap=underflow,overflow,denormal -fbounds-check 4 | F90OPT= 5 | 6 | AFNLPATH=/home/alberto/code/fortran/afnl/ 7 | GAPATH=/home/alberto/code/fortran/libga/ 8 | AFNLNAME=f90 9 | GANAME=ga 10 | 11 | VPATH=src:main 12 | SRCDIR=$(VPATH) 13 | INC=include/ 14 | 15 | OBJ = uncertainties.o uncertainties_arith.o uncertainties_func.o 16 | 17 | all: $(OBJ) check1.x check2.x check3.x 18 | 19 | uncertainties.o: uncertainties.f90 20 | $(F90) -J $(INC) -c $^ -o $(INC)/$@ -I$(INC) 21 | 22 | uncertainties_arith.o: uncertainties_arith.f90 23 | $(F90) -J $(INC) -c $^ -o $(INC)/$@ -I$(INC) 24 | 25 | uncertainties_func.o: uncertainties_func.f90 26 | $(F90) -J $(INC) -c $^ -o $(INC)/$@ -I$(INC) 27 | 28 | check1.x: check1.f90 $(OBJ) 29 | $(F90) -J $(INC) $(addprefix $(INC),$(OBJ)) $< -o $@ -I$(INC) 30 | 31 | check2.x: check2.f90 $(OBJ) 32 | $(F90) -J $(INC) $(addprefix $(INC),$(OBJ)) $< -o $@ -I$(INC) 33 | 34 | check3.x: check3.f90 $(OBJ) 35 | $(F90) -J $(INC) $(addprefix $(INC),$(OBJ)) $< -o $@ -I$(INC) 36 | 37 | clean: 38 | rm $(INC)/*.o 39 | rm $(INC)/*.mod 40 | rm $(INC)/*.smod 41 | rm check1.x check2.x 42 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | # A MODULE for linear propagation of errors 3 | 4 | This module implements linear propagation of errors, including 5 | correlations of variables. 6 | 7 | ## USAGE 8 | 9 | * Variables with uncertainties are defined as type (ureal), and 10 | initialized by assigning them to a 2-component 1d array. 11 | 12 | ``` 13 | use uncertainties 14 | 15 | type (ureal) :: a 16 | 17 | a = (/1.0D0,0.1D0/) ! variable a has value 1.0 and error 0.1 18 | ``` 19 | 20 | * One can perform normal operations with variables 21 | 22 | ``` 23 | type (ureal) :: a, b, c 24 | 25 | a = (/1.0D0,0.1D0/) ! variable a has value 1.0 and error 0.1 26 | b = (/2.0D0,0.3D0/) ! variable b has value 2.0 and error 0.3 27 | 28 | c = a+b ! variable c has value 3.0 and error sqrt(0.3**2+0.1**2) 29 | ``` 30 | 31 | * Intrinsic functions work (currently supported are: sin, cos, tan, 32 | asin, acos, atan, sinh, cosh, tanh, sqrt, log, log10, exp) 33 | 34 | ``` 35 | type (ureal) :: a, b, c 36 | 37 | a = (/1.0D0,0.1D0/) ! variable a has value 1.0 and error 0.1 38 | b = (/2.0D0,0.3D0/) ! variable b has value 2.0 and error 0.3 39 | 40 | c = sin(a) + sqrt(b) 41 | ``` 42 | 43 | * All initialized variables are assumed uncorrelated. After, 44 | all correlations are taken into account automatically 45 | 46 | ``` 47 | type (ureal) :: a, b, c, d 48 | 49 | a = (/1.0D0,0.1D0/) ! variable a has value 1.0 and error 0.1 50 | b = (/2.0D0,0.3D0/) ! variable b has value 2.0 and error 0.3 51 | 52 | c = (a+b)**2 53 | 54 | d = c - (a**2 + b**2 +2*a*b) ! Variable d has value 0 and error 0 55 | ``` 56 | 57 | ## "THE BEER-WARE LICENSE": 58 | Alberto Ramos wrote this file. As long as you retain this 59 | notice you can do whatever you want with this stuff. If we meet some 60 | day, and you think this stuff is worth it, you can buy me a beer in 61 | return. 62 | 63 | 64 | -------------------------------------------------------------------------------- /src/uncertainties_func.f90: -------------------------------------------------------------------------------- 1 | ! 2 | ! A MODULE 3 | ! 4 | ! "THE BEER-WARE LICENSE": 5 | ! Alberto Ramos wrote this file. As long as you retain this 6 | ! notice you can do whatever you want with this stuff. If we meet some 7 | ! day, and you think this stuff is worth it, you can buy me a beer in 8 | ! return. 9 | ! 10 | ! $ v1.0 201XXXXX $ 11 | ! 12 | 13 | submodule (uncertainties) uncertainties_func 14 | 15 | implicit none 16 | 17 | real (kind=DP), parameter :: LGe10_DP = log(10.0_DP) 18 | integer, allocatable :: ws_map(:,:), ws_ids(:) 19 | integer :: ns = -1 20 | 21 | 22 | contains 23 | 24 | ! ******************************** 25 | ! * 26 | module elemental function usqrt(a) 27 | ! * 28 | ! ******************************** 29 | type (ureal), intent (in) :: a 30 | type (ureal) :: usqrt 31 | 32 | call usqrt%init(a%nid) 33 | usqrt%id = a%id 34 | 35 | usqrt%x = sqrt(a%x) 36 | usqrt%del = a%del/(2.0_DP*usqrt%x) 37 | 38 | return 39 | end function usqrt 40 | 41 | ! ******************************** 42 | ! * 43 | module elemental function ulog(a) 44 | ! * 45 | ! ******************************** 46 | type (ureal), intent (in) :: a 47 | type (ureal) :: ulog 48 | 49 | call ulog%init(a%nid) 50 | ulog%id = a%id 51 | 52 | ulog%x = log(a%x) 53 | ulog%del = a%del/a%x 54 | 55 | return 56 | end function ulog 57 | 58 | ! ******************************** 59 | ! * 60 | module elemental function ulog10(a) 61 | ! * 62 | ! ******************************** 63 | type (ureal), intent (in) :: a 64 | type (ureal) :: ulog10 65 | 66 | call ulog10%init(a%nid) 67 | ulog10%id = a%id 68 | 69 | ulog10%x = log(a%x) 70 | ulog10%del = a%del/a%x/LGe10_DP 71 | 72 | return 73 | end function ulog10 74 | 75 | ! ******************************** 76 | ! * 77 | module elemental function uexp(a) 78 | ! * 79 | ! ******************************** 80 | type (ureal), intent (in) :: a 81 | type (ureal) :: uexp 82 | 83 | call uexp%init(a%nid) 84 | uexp%id = a%id 85 | 86 | uexp%x = exp(a%x) 87 | uexp%del = exp(a%x)*a%del 88 | 89 | return 90 | end function uexp 91 | 92 | ! ******************************** 93 | ! * 94 | module elemental function usin(a) 95 | ! * 96 | ! ******************************** 97 | type (ureal), intent (in) :: a 98 | type (ureal) :: usin 99 | 100 | call usin%init(a%nid) 101 | usin%id = a%id 102 | 103 | usin%x = sin(a%x) 104 | usin%del = cos(a%x)*a%del 105 | 106 | return 107 | end function usin 108 | 109 | ! ******************************** 110 | ! * 111 | module elemental function ucos(a) 112 | ! * 113 | ! ******************************** 114 | type (ureal), intent (in) :: a 115 | type (ureal) :: ucos 116 | 117 | call ucos%init(a%nid) 118 | ucos%id = a%id 119 | 120 | ucos%x = cos(a%x) 121 | ucos%del = -sin(a%x)*a%del 122 | 123 | return 124 | end function ucos 125 | 126 | ! ******************************** 127 | ! * 128 | module elemental function utan(a) 129 | ! * 130 | ! ******************************** 131 | type (ureal), intent (in) :: a 132 | type (ureal) :: utan 133 | 134 | call utan%init(a%nid) 135 | utan%id = a%id 136 | 137 | utan%x = tan(a%x) 138 | utan%del = (1.0_DP + utan%x**2)*a%del 139 | 140 | return 141 | end function utan 142 | 143 | ! ******************************** 144 | ! * 145 | module elemental function uasin(a) 146 | ! * 147 | ! ******************************** 148 | type (ureal), intent (in) :: a 149 | type (ureal) :: uasin 150 | 151 | call uasin%init(a%nid) 152 | uasin%id = a%id 153 | 154 | uasin%x = asin(a%x) 155 | uasin%del = a%del/sqrt(1.0_DP - a%x**2) 156 | 157 | return 158 | end function uasin 159 | 160 | ! ******************************** 161 | ! * 162 | module elemental function uacos(a) 163 | ! * 164 | ! ******************************** 165 | type (ureal), intent (in) :: a 166 | type (ureal) :: uacos 167 | 168 | call uacos%init(a%nid) 169 | uacos%id = a%id 170 | 171 | uacos%x = acos(a%x) 172 | uacos%del = -a%del/sqrt(1.0_DP - a%x**2) 173 | 174 | return 175 | end function uacos 176 | 177 | ! ******************************** 178 | ! * 179 | module elemental function uatan(a) 180 | ! * 181 | ! ******************************** 182 | type (ureal), intent (in) :: a 183 | type (ureal) :: uatan 184 | 185 | call uatan%init(a%nid) 186 | uatan%id = a%id 187 | 188 | uatan%x = atan(a%x) 189 | uatan%del = a%del/(1.0_DP + uatan%x**2) 190 | 191 | return 192 | end function uatan 193 | 194 | ! ******************************** 195 | ! * 196 | module elemental function usinh(a) 197 | ! * 198 | ! ******************************** 199 | type (ureal), intent (in) :: a 200 | type (ureal) :: usinh 201 | 202 | call usinh%init(a%nid) 203 | usinh%id = a%id 204 | 205 | usinh%x = sinh(a%x) 206 | usinh%del = cosh(a%x)*a%del 207 | 208 | return 209 | end function usinh 210 | 211 | ! ******************************** 212 | ! * 213 | module elemental function ucosh(a) 214 | ! * 215 | ! ******************************** 216 | type (ureal), intent (in) :: a 217 | type (ureal) :: ucosh 218 | 219 | call ucosh%init(a%nid) 220 | ucosh%id = a%id 221 | 222 | ucosh%x = cosh(a%x) 223 | ucosh%del = sinh(a%x)*a%del 224 | 225 | return 226 | end function ucosh 227 | 228 | ! ******************************** 229 | ! * 230 | module elemental function utanh(a) 231 | ! * 232 | ! ******************************** 233 | type (ureal), intent (in) :: a 234 | type (ureal) :: utanh 235 | 236 | call utanh%init(a%nid) 237 | utanh%id = a%id 238 | 239 | utanh%x = tanh(a%x) 240 | utanh%del = (1.0_DP - utanh%x**2)*a%del 241 | 242 | return 243 | end function utanh 244 | 245 | end submodule uncertainties_func 246 | -------------------------------------------------------------------------------- /src/uncertainties.f90: -------------------------------------------------------------------------------- 1 | ! 2 | ! A MODULE for linear propagation of errors 3 | ! 4 | ! "THE BEER-WARE LICENSE": 5 | ! Alberto Ramos wrote this file. As long as you retain this 6 | ! notice you can do whatever you want with this stuff. If we meet some 7 | ! day, and you think this stuff is worth it, you can buy me a beer in 8 | ! return. 9 | ! 10 | ! $ v1.0 20170527 $ 11 | ! 12 | 13 | module uncertainties 14 | 15 | USE ISO_FORTRAN_ENV, Only : error_unit, output_unit, DP=>real64 16 | 17 | IMPLICIT NONE 18 | 19 | private 20 | 21 | public :: DP 22 | 23 | type :: ureal 24 | real (kind=DP) :: x 25 | real (kind=DP), allocatable :: del(:) 26 | integer, allocatable :: id(:) 27 | integer :: nid=-1 28 | contains 29 | procedure :: init => init_t 30 | procedure :: write => write_t 31 | end type ureal 32 | 33 | public :: ureal, uerror, uvalue 34 | 35 | interface assignment (=) 36 | module procedure equal_v, equal_t 37 | end interface assignment (=) 38 | 39 | interface operator (+) 40 | module procedure add_t, add_cr, add_cl 41 | end interface operator (+) 42 | interface operator (-) 43 | module procedure sub_t, sub_cr, sub_cl 44 | end interface operator (-) 45 | interface operator (*) 46 | module procedure mul_t, mul_cr, mul_cl 47 | end interface operator (*) 48 | interface operator (/) 49 | module procedure div_t, div_cr, div_cl 50 | end interface operator (/) 51 | interface operator (**) 52 | module procedure pow_t 53 | end interface operator (**) 54 | 55 | interface 56 | module subroutine covariance(mat,ud) 57 | type (ureal), intent (in) :: ud(:) 58 | real (kind=DP), intent (out) :: mat(size(ud),size(ud)) 59 | end subroutine covariance 60 | module function add_t(a,b) 61 | type (ureal), intent (in) :: a, b 62 | type (ureal) :: add_t 63 | end function add_t 64 | module function add_cr(a,r) 65 | type (ureal), intent (in) :: a 66 | real (kind=DP), intent (in) :: r 67 | type (ureal) :: add_cr 68 | end function add_cr 69 | module function add_cl(r,a) 70 | type (ureal), intent (in) :: a 71 | real (kind=DP), intent (in) :: r 72 | type (ureal) :: add_cl 73 | end function add_cl 74 | module function sub_t(a,b) 75 | type (ureal), intent (in) :: a, b 76 | type (ureal) :: sub_t 77 | end function sub_t 78 | module function sub_cr(a,r) 79 | type (ureal), intent (in) :: a 80 | real (kind=DP), intent (in) :: r 81 | type (ureal) :: sub_cr 82 | end function sub_cr 83 | module function sub_cl(r,a) 84 | type (ureal), intent (in) :: a 85 | real (kind=DP), intent (in) :: r 86 | type (ureal) :: sub_cl 87 | end function sub_cl 88 | module function mul_t(a,b) 89 | type (ureal), intent (in) :: a, b 90 | type (ureal) :: mul_t 91 | end function mul_t 92 | module function mul_cr(a,r) 93 | type (ureal), intent (in) :: a 94 | real (kind=DP), intent (in) :: r 95 | type (ureal) :: mul_cr 96 | end function mul_cr 97 | module function mul_cl(r,a) 98 | type (ureal), intent (in) :: a 99 | real (kind=DP), intent (in) :: r 100 | type (ureal) :: mul_cl 101 | end function mul_cl 102 | module function div_t(a,b) 103 | type (ureal), intent (in) :: a, b 104 | type (ureal) :: div_t 105 | end function div_t 106 | module function div_cr(a,r) 107 | type (ureal), intent (in) :: a 108 | real (kind=DP), intent (in) :: r 109 | type (ureal) :: div_cr 110 | end function div_cr 111 | module function div_cl(r,a) 112 | type (ureal), intent (in) :: a 113 | real (kind=DP), intent (in) :: r 114 | type (ureal) :: div_cl 115 | end function div_cl 116 | module function pow_t(a,n) 117 | type (ureal), intent (in) :: a 118 | integer, intent (in) :: n 119 | type (ureal) :: pow_t 120 | end function pow_t 121 | end interface 122 | 123 | integer, save :: id_count = 0 124 | 125 | public :: covariance 126 | public :: assignment(=), operator(+), operator(-), & 127 | operator(*), operator (/), operator (**) 128 | 129 | interface 130 | module elemental function usin(a) 131 | type (ureal), intent (in) :: a 132 | type (ureal) :: usin 133 | end function usin 134 | module elemental function ucos(a) 135 | type (ureal), intent (in) :: a 136 | type (ureal) :: ucos 137 | end function ucos 138 | module elemental function utan(a) 139 | type (ureal), intent (in) :: a 140 | type (ureal) :: utan 141 | end function utan 142 | module elemental function uasin(a) 143 | type (ureal), intent (in) :: a 144 | type (ureal) :: uasin 145 | end function uasin 146 | module elemental function uacos(a) 147 | type (ureal), intent (in) :: a 148 | type (ureal) :: uacos 149 | end function uacos 150 | module elemental function uatan(a) 151 | type (ureal), intent (in) :: a 152 | type (ureal) :: uatan 153 | end function uatan 154 | module elemental function usinh(a) 155 | type (ureal), intent (in) :: a 156 | type (ureal) :: usinh 157 | end function usinh 158 | module elemental function ucosh(a) 159 | type (ureal), intent (in) :: a 160 | type (ureal) :: ucosh 161 | end function ucosh 162 | module elemental function utanh(a) 163 | type (ureal), intent (in) :: a 164 | type (ureal) :: utanh 165 | end function utanh 166 | module elemental function usqrt(a) 167 | type (ureal), intent (in) :: a 168 | type (ureal) :: usqrt 169 | end function usqrt 170 | module elemental function ulog(a) 171 | type (ureal), intent (in) :: a 172 | type (ureal) :: ulog 173 | end function ulog 174 | module elemental function ulog10(a) 175 | type (ureal), intent (in) :: a 176 | type (ureal) :: ulog10 177 | end function ulog10 178 | module elemental function uexp(a) 179 | type (ureal), intent (in) :: a 180 | type (ureal) :: uexp 181 | end function uexp 182 | end interface 183 | 184 | interface sin 185 | module procedure usin 186 | end interface sin 187 | interface cos 188 | module procedure ucos 189 | end interface cos 190 | interface tan 191 | module procedure utan 192 | end interface tan 193 | 194 | interface asin 195 | module procedure uasin 196 | end interface asin 197 | interface acos 198 | module procedure uacos 199 | end interface acos 200 | interface atan 201 | module procedure uatan 202 | end interface atan 203 | 204 | interface sinh 205 | module procedure usinh 206 | end interface sinh 207 | interface cosh 208 | module procedure ucosh 209 | end interface cosh 210 | interface tanh 211 | module procedure utanh 212 | end interface tanh 213 | 214 | interface sqrt 215 | module procedure usqrt 216 | end interface sqrt 217 | interface log 218 | module procedure ulog 219 | end interface log 220 | interface log10 221 | module procedure ulog10 222 | end interface log10 223 | interface exp 224 | module procedure uexp 225 | end interface exp 226 | 227 | public :: sin, cos, tan, asin, acos, atan, sinh, cosh, tanh, & 228 | sqrt, log, log10, exp 229 | 230 | contains 231 | 232 | ! ******************************** 233 | ! * 234 | function uvalue(a) 235 | ! * 236 | ! ******************************** 237 | type (ureal), intent (in) :: a 238 | real (kind=DP) :: uvalue 239 | 240 | uvalue = a%x 241 | 242 | return 243 | end function uvalue 244 | 245 | ! ******************************** 246 | ! * 247 | function uerror(a) 248 | ! * 249 | ! ******************************** 250 | type (ureal), intent (in) :: a 251 | real (kind=DP) :: uerror 252 | 253 | uerror = sqrt(sum(a%del**2)) 254 | 255 | return 256 | end function uerror 257 | 258 | ! ******************************** 259 | ! * 260 | subroutine write_t(a,ifn) 261 | ! * 262 | ! ******************************** 263 | class (ureal), intent (in) :: a 264 | integer, intent (in), optional :: ifn 265 | 266 | integer :: ifl, nv, ne 267 | character (len=100) :: cv, ce 268 | character (len=10) :: cerr 269 | real (kind=DP) :: err 270 | 271 | ifl = output_unit 272 | if (present(ifn)) ifl = ifn 273 | 274 | err = sqrt(sum(a%del**2)) 275 | !!$ nv = int(log10(a%x)) 276 | !!$ ne = int(log10(err)) 277 | !!$ 278 | !!$ write(*,*)a%x, err 279 | !!$ write(cv,'(1F0.8)')a%x 280 | !!$ write(ce,'(1ES31.25)')err 281 | !!$ write(cerr,'(2A1,1A2,1A1)')'(',ce(1:1), ce(3:4),')' 282 | !!$ write(*,*)'aqui: ', trim(cerr) 283 | 284 | write(ifl,'(1F0.10,1X,1A,1X,1F0.6)')a%x, '+/-', err 285 | 286 | return 287 | end subroutine write_t 288 | 289 | 290 | 291 | 292 | ! ******************************** 293 | ! * 294 | elemental subroutine free_t(a) 295 | ! * 296 | ! ******************************** 297 | type (ureal), intent (inout) :: a 298 | 299 | a%nid = -1 300 | if (allocated(a%del)) deallocate(a%del) 301 | if (allocated(a%id)) deallocate(a%id) 302 | 303 | return 304 | end subroutine free_t 305 | 306 | ! ******************************** 307 | ! * 308 | elemental subroutine init_t(a,n) 309 | ! * 310 | ! ******************************** 311 | class (ureal), intent (inout) :: a 312 | integer, intent (in) :: n 313 | 314 | if (a%nid.ne.n) then 315 | call free_t(a) 316 | allocate(a%del(n),a%id(n)) 317 | a%nid = n 318 | end if 319 | a%x = 0.0_DP 320 | a%del = 0.0_DP 321 | 322 | return 323 | end subroutine init_t 324 | 325 | ! ******************************** 326 | ! * 327 | subroutine equal_v(a,v) 328 | ! * 329 | ! ******************************** 330 | real (kind=DP), intent (in) :: v(2) 331 | type (ureal), intent (out) :: a 332 | 333 | call init_t(a,1) 334 | a%x = v(1) 335 | a%del(1) = v(2) 336 | a%id(1) = id_count 337 | 338 | id_count = id_count + 1 339 | 340 | return 341 | end subroutine equal_v 342 | 343 | ! ******************************** 344 | ! * 345 | subroutine equal_t(a,b) 346 | ! * 347 | ! ******************************** 348 | type (ureal), intent (inout) :: a 349 | type (ureal), intent (in) :: b 350 | 351 | call init_t(a,b%nid) 352 | a%x = b%x 353 | a%del = b%del 354 | a%id = b%id 355 | 356 | return 357 | end subroutine equal_t 358 | 359 | ! ******************************** 360 | ! * 361 | Subroutine module_error(routine, msg) 362 | ! * 363 | ! ******************************** 364 | 365 | Character (len=*), Intent (in) :: routine, msg 366 | 367 | Write(error_unit,*)'In '//Trim(routine)// ' :' 368 | Write(error_unit,'(5X,1A)')Trim(msg) 369 | Write(error_unit,*) 370 | 371 | stop 372 | end subroutine module_error 373 | 374 | end Module uncertainties 375 | 376 | -------------------------------------------------------------------------------- /src/uncertainties_arith.f90: -------------------------------------------------------------------------------- 1 | ! 2 | ! A MODULE 3 | ! 4 | ! "THE BEER-WARE LICENSE": 5 | ! Alberto Ramos wrote this file. As long as you retain this 6 | ! notice you can do whatever you want with this stuff. If we meet some 7 | ! day, and you think this stuff is worth it, you can buy me a beer in 8 | ! return. 9 | ! 10 | ! $ v1.0 201XXXXX $ 11 | ! 12 | 13 | submodule (uncertainties) uncertainties_arith 14 | 15 | implicit none 16 | 17 | integer, allocatable :: ws_map(:,:), ws_ids(:) 18 | integer :: ns = -1 19 | 20 | contains 21 | 22 | ! ******************************** 23 | ! * 24 | module subroutine covariance(mat,ud) 25 | ! * 26 | ! ******************************** 27 | type (ureal), intent (in) :: ud(:) 28 | real (kind=DP), intent (out) :: mat(size(ud),size(ud)) 29 | integer :: nd, n1, n2, i, nid, idx1, idx2, ism 30 | 31 | ism = sum(ud(:)%nid) 32 | call init_ws(ism) 33 | 34 | nd = size(ud) 35 | mat = 0.0_DP 36 | do n1 = 1, nd 37 | do n2 = n1, nd 38 | call combine_ids(ws_map,ws_ids,nid,ud(n1),ud(n2)) 39 | do i = 1, nid 40 | idx1 = ws_map(i,1) 41 | idx2 = ws_map(i,2) 42 | if ( (idx1.ne.0).and.(idx2.ne.0) ) then 43 | mat(n1,n2) = mat(n1,n2) + ud(n1)%del(idx1)*ud(n2)%del(idx2) 44 | end if 45 | end do 46 | end do 47 | end do 48 | 49 | do n1 = 1, nd 50 | do n2 = n1, nd 51 | mat(n2,n1) = mat(n1,n2) 52 | end do 53 | end do 54 | 55 | return 56 | end subroutine covariance 57 | 58 | ! ******************************** 59 | ! * 60 | subroutine init_ws(n) 61 | ! * 62 | ! ******************************** 63 | integer, intent (in) :: n 64 | 65 | if (ns.ge.n) return 66 | if (allocated(ws_map)) deallocate(ws_map) 67 | if (allocated(ws_ids)) deallocate(ws_ids) 68 | 69 | ns = n 70 | allocate(ws_map(ns,2), ws_ids(ns)) 71 | 72 | return 73 | end subroutine init_ws 74 | 75 | ! ******************************** 76 | ! * 77 | module function add_cr(a,r) 78 | ! * 79 | ! ******************************** 80 | type (ureal), intent (in) :: a 81 | real (kind=DP), intent (in) :: r 82 | type (ureal) :: add_cr 83 | integer :: nid 84 | 85 | nid = a%nid 86 | call init_ws(a%nid) 87 | call add_cr%init(a%nid) 88 | add_cr%id(1:nid) = a%id(1:nid) 89 | 90 | add_cr%x = a%x + r 91 | add_cr%del = a%del 92 | 93 | return 94 | end function add_cr 95 | 96 | ! ******************************** 97 | ! * 98 | module function add_cl(r,a) 99 | ! * 100 | ! ******************************** 101 | type (ureal), intent (in) :: a 102 | real (kind=DP), intent (in) :: r 103 | type (ureal) :: add_cl 104 | integer :: nid 105 | 106 | nid = a%nid 107 | call init_ws(a%nid) 108 | call add_cl%init(a%nid) 109 | add_cl%id(1:nid) = a%id(1:nid) 110 | 111 | add_cl%x = a%x + r 112 | add_cl%del = a%del 113 | 114 | return 115 | end function add_cl 116 | 117 | ! ******************************** 118 | ! * 119 | module function add_t(a,b) 120 | ! * 121 | ! ******************************** 122 | type (ureal), intent (in) :: a, b 123 | type (ureal) :: add_t 124 | real (kind=DP) :: sa, sb 125 | integer :: i, nid 126 | 127 | call init_ws(a%nid+b%nid) 128 | call combine_ids(ws_map,ws_ids,nid,a,b) 129 | call add_t%init(nid) 130 | add_t%id(1:nid) = ws_ids(1:nid) 131 | 132 | add_t%x = a%x + b%x 133 | do i = 1, add_t%nid 134 | if (ws_map(i,1).ne.0) then 135 | sa = a%del(ws_map(i,1)) 136 | else 137 | sa = 0.0_DP 138 | end if 139 | if (ws_map(i,2).ne.0) then 140 | sb = b%del(ws_map(i,2)) 141 | else 142 | sb = 0.0_DP 143 | end if 144 | 145 | add_t%del(i) = sa + sb 146 | end do 147 | 148 | return 149 | end function add_t 150 | 151 | ! ******************************** 152 | ! * 153 | module function sub_cr(a,r) 154 | ! * 155 | ! ******************************** 156 | type (ureal), intent (in) :: a 157 | real (kind=DP), intent (in) :: r 158 | type (ureal) :: sub_cr 159 | integer :: nid 160 | 161 | nid = a%nid 162 | call init_ws(a%nid) 163 | call sub_cr%init(a%nid) 164 | sub_cr%id(1:nid) = a%id(1:nid) 165 | 166 | sub_cr%x = a%x - r 167 | sub_cr%del = a%del 168 | 169 | return 170 | end function sub_cr 171 | 172 | ! ******************************** 173 | ! * 174 | module function sub_cl(r,a) 175 | ! * 176 | ! ******************************** 177 | type (ureal), intent (in) :: a 178 | real (kind=DP), intent (in) :: r 179 | type (ureal) :: sub_cl 180 | integer :: nid 181 | 182 | nid = a%nid 183 | call init_ws(a%nid) 184 | call sub_cl%init(a%nid) 185 | sub_cl%id(1:nid) = a%id(1:nid) 186 | 187 | sub_cl%x = r - a%x 188 | sub_cl%del = -a%del 189 | 190 | return 191 | end function sub_cl 192 | 193 | ! ******************************** 194 | ! * 195 | module function sub_t(a,b) 196 | ! * 197 | ! ******************************** 198 | type (ureal), intent (in) :: a, b 199 | type (ureal) :: sub_t 200 | real (kind=DP) :: sa, sb 201 | integer :: i, nid 202 | 203 | call init_ws(a%nid+b%nid) 204 | call combine_ids(ws_map,ws_ids,nid,a,b) 205 | call sub_t%init(nid) 206 | sub_t%id(1:nid) = ws_ids(1:nid) 207 | 208 | sub_t%x = a%x - b%x 209 | do i = 1, sub_t%nid 210 | if (ws_map(i,1).ne.0) then 211 | sa = a%del(ws_map(i,1)) 212 | else 213 | sa = 0.0_DP 214 | end if 215 | if (ws_map(i,2).ne.0) then 216 | sb = b%del(ws_map(i,2)) 217 | else 218 | sb = 0.0_DP 219 | end if 220 | sub_t%del(i) = sa - sb 221 | end do 222 | 223 | return 224 | end function sub_t 225 | 226 | ! ******************************** 227 | ! * 228 | module function mul_t(a,b) 229 | ! * 230 | ! ******************************** 231 | type (ureal), intent (in) :: a, b 232 | type (ureal) :: mul_t 233 | real (kind=DP) :: sa, sb 234 | integer :: i, nid 235 | 236 | call init_ws(a%nid+b%nid) 237 | call combine_ids(ws_map,ws_ids,nid,a,b) 238 | call mul_t%init(nid) 239 | mul_t%id(1:nid) = ws_ids(1:nid) 240 | 241 | mul_t%x = a%x * b%x 242 | do i = 1, mul_t%nid 243 | if (ws_map(i,1).ne.0) then 244 | sa = a%del(ws_map(i,1)) 245 | else 246 | sa = 0.0_DP 247 | end if 248 | if (ws_map(i,2).ne.0) then 249 | sb = b%del(ws_map(i,2)) 250 | else 251 | sb = 0.0_DP 252 | end if 253 | mul_t%del(i) = sa*b%x + sb*a%x 254 | end do 255 | 256 | return 257 | end function mul_t 258 | 259 | ! ******************************** 260 | ! * 261 | module function mul_cl(r,a) 262 | ! * 263 | ! ******************************** 264 | type (ureal), intent (in) :: a 265 | real (kind=DP), intent (in) :: r 266 | type (ureal) :: mul_cl 267 | integer :: nid 268 | 269 | nid = a%nid 270 | call init_ws(a%nid) 271 | call mul_cl%init(a%nid) 272 | mul_cl%id(1:nid) = a%id(1:nid) 273 | 274 | mul_cl%x = r * a%x 275 | mul_cl%del = r*a%del 276 | 277 | return 278 | end function mul_cl 279 | 280 | ! ******************************** 281 | ! * 282 | module function mul_cr(a,r) 283 | ! * 284 | ! ******************************** 285 | type (ureal), intent (in) :: a 286 | real (kind=DP), intent (in) :: r 287 | type (ureal) :: mul_cr 288 | integer :: nid 289 | 290 | nid = a%nid 291 | call init_ws(a%nid) 292 | call mul_cr%init(a%nid) 293 | mul_cr%id(1:nid) = a%id(1:nid) 294 | 295 | mul_cr%x = r * a%x 296 | mul_cr%del = r*a%del 297 | 298 | return 299 | end function mul_cr 300 | 301 | ! ******************************** 302 | ! * 303 | module function div_t(a,b) 304 | ! * 305 | ! ******************************** 306 | type (ureal), intent (in) :: a, b 307 | type (ureal) :: div_t 308 | real (kind=DP) :: sa, sb 309 | integer :: i, nid 310 | 311 | call init_ws(a%nid+b%nid) 312 | call combine_ids(ws_map,ws_ids,nid,a,b) 313 | call div_t%init(nid) 314 | div_t%id(1:nid) = ws_ids(1:nid) 315 | 316 | div_t%x = a%x / b%x 317 | do i = 1, div_t%nid 318 | if (ws_map(i,1).ne.0) then 319 | sa = a%del(ws_map(i,1)) 320 | else 321 | sa = 0.0_DP 322 | end if 323 | if (ws_map(i,2).ne.0) then 324 | sb = b%del(ws_map(i,2)) 325 | else 326 | sb = 0.0_DP 327 | end if 328 | div_t%del(i) = sa/b%x - sb*a%x/b%x**2 329 | end do 330 | 331 | return 332 | end function div_t 333 | 334 | ! ******************************** 335 | ! * 336 | module function div_cl(r,a) 337 | ! * 338 | ! ******************************** 339 | type (ureal), intent (in) :: a 340 | real (kind=DP), intent (in) :: r 341 | type (ureal) :: div_cl 342 | integer :: nid 343 | 344 | nid = a%nid 345 | call init_ws(a%nid) 346 | call div_cl%init(a%nid) 347 | div_cl%id(1:nid) = a%id(1:nid) 348 | 349 | div_cl%x = r / a%x 350 | div_cl%del = -r/a%x**2 * a%del 351 | 352 | return 353 | end function div_cl 354 | 355 | ! ******************************** 356 | ! * 357 | module function div_cr(a,r) 358 | ! * 359 | ! ******************************** 360 | type (ureal), intent (in) :: a 361 | real (kind=DP), intent (in) :: r 362 | type (ureal) :: div_cr 363 | integer :: nid 364 | 365 | nid = a%nid 366 | call init_ws(a%nid) 367 | call div_cr%init(a%nid) 368 | div_cr%id(1:nid) = a%id(1:nid) 369 | 370 | div_cr%x = a%x / r 371 | div_cr%del = a%del / r 372 | 373 | return 374 | end function div_cr 375 | 376 | ! ******************************** 377 | ! * 378 | module function pow_t(a,n) 379 | ! * 380 | ! ******************************** 381 | type (ureal), intent (in) :: a 382 | integer, intent (in) :: n 383 | type (ureal) :: pow_t 384 | integer :: i, nid 385 | 386 | nid = a%nid 387 | call pow_t%init(nid) 388 | pow_t%id(1:nid) = a%id(1:nid) 389 | 390 | pow_t%x = a%x ** n 391 | do i = 1, pow_t%nid 392 | pow_t%del(i) = real(n,kind=DP)*a%x**(n-1) * a%del(i) 393 | end do 394 | 395 | return 396 | end function pow_t 397 | 398 | ! ******************************** 399 | ! * 400 | subroutine combine_ids(map,ids,nid,a,b) 401 | ! * 402 | ! ******************************** 403 | type (ureal), intent (in) :: a, b 404 | integer, intent (out) :: map(:,:), ids(:), nid 405 | integer :: i, j 406 | logical :: fnd 407 | 408 | 409 | map = 0 410 | nid = a%nid 411 | forall (i=1:nid) map(i,1) = i 412 | ids(1:nid) = a%id(:) 413 | do i = 1, b%nid 414 | 415 | fnd = .false. 416 | do j = 1, a%nid 417 | if (b%id(i).eq.a%id(j)) then 418 | map(j,2) = i 419 | fnd = .true. 420 | exit 421 | end if 422 | end do 423 | 424 | if (.not.fnd) then 425 | nid = nid + 1 426 | ids(nid) = b%id(i) 427 | map(nid,2) = i 428 | end if 429 | 430 | end do 431 | 432 | 433 | return 434 | end subroutine combine_ids 435 | 436 | end submodule uncertainties_arith 437 | --------------------------------------------------------------------------------