├── LICENSE ├── README ├── parse.py ├── src ├── base_types.f90 ├── lib_algebra.f90 ├── lib_array.f90 ├── lib_cfitsio.f90 ├── lib_conf.f90 ├── lib_constants.f90 ├── lib_hdf5_110.f90 ├── lib_hdf5_18.f90 ├── lib_io.f90 ├── lib_messages.f90 ├── lib_random.f90 ├── lib_statistics.f90 ├── lib_version.f90 ├── posix_default.f90 ├── posix_nag.f90 ├── type_angle3d.f90 ├── type_pdf.f90 ├── type_pdf2d.f90 ├── type_stokes.f90 ├── type_var1d_pdf.f90 ├── type_var2d_pdf2d.f90 └── type_vector3d.f90 └── templates ├── lib_algebra_template.f90 ├── lib_array_template.f90 ├── lib_cfitsio_template.f90 ├── lib_conf_template.f90 ├── lib_hdf5_110_template.f90 ├── lib_hdf5_18_template.f90 ├── lib_io_template.f90 ├── lib_random_template.f90 ├── lib_statistics_template.f90 ├── type_angle3d_template.f90 ├── type_pdf2d_template.f90 ├── type_pdf_template.f90 ├── type_stokes_template.f90 ├── type_var1d_pdf_template.f90 ├── type_var2d_pdf2d_template.f90 └── type_vector3d_template.f90 /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2009-13, Thomas P. Robitaille 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright notice, this 9 | list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above copyright notice, 12 | this list of conditions and the following disclaimer in the documentation 13 | and/or other materials provided with the distribution. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 16 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 17 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 19 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 20 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 21 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 22 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 23 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 24 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | This is a collection of Fortran routines I have written over the years for use 2 | in more complex codes. The different files are as independent as possible from 3 | each other, but in some cases dependencies are unavoidable. 4 | 5 | A lot of routines are written so as to work with both single and double type 6 | precision. These are in the templates/ directory, and are coded using generic 7 | types. The files in templates are not valid Fortran, and will not compile. 8 | Running the parse.py script automatically generates the full source code from 9 | these templates, and places the results in src. 10 | 11 | base_types.f90 (no dependencies) 12 | Defines numeric types 13 | 14 | lib_algebra.f90 (no dependencies) 15 | Defines the following routines: 16 | - cube root 17 | - several quadratic solvers 18 | - Simpson's rule integrator 19 | - Gaussian elimination linear equations solver 20 | 21 | lib_array.f90 (no dependencies) 22 | Defines the following routines: 23 | - linspace: create an array of values equally spaced in linear space 24 | - logspace: create an array of values equally spaced in log space 25 | - index_array_1d: find the order array elements should be in to be sorted 26 | - sort: sort one or two arrays 27 | - integral: trapezium integration 28 | - integral_linlog: trapezium integration with linear-log interpolation 29 | - integral_loglin: trapezium integration with log-linear interpolation 30 | - integral_loglog: trapezium integration with log-log interpolation 31 | - cumulative_integral: cumulative version of integral 32 | - cumulative_integral_linlog: cumulative version of integral_linlog 33 | - cumulative_integral_loglin: cumulative version of integral_loglin 34 | - cumulative_integral_loglog: cumulative version of integral_loglog 35 | - locate: search for a value in a sorted array 36 | - interp1d: 1-D linear interpolation 37 | - interp2d: 2-D linear interpolation 38 | - interp1d_linlog: 1-D linear interpolation in linear-log space 39 | - interp1d_loglin: 1-D linear interpolation in log-linear space 40 | - interp1d_loglog: 1-D linear interpolation in log-log space 41 | - histogram1d: convert an array of values to a histogram 42 | - histogram2d: convert two arrays of values to a 2-D histogram 43 | - ipos: bin value for equally spaced bins 44 | - xval: find center of bin for equally spaced bins 45 | 46 | lib_cfitsio.f90 (requires the cfitsio library to be installed) 47 | Defines wrapper routines for the cfitsio library 48 | 49 | lib_conf.f90 (no dependencies) 50 | Defines routines to make it easy to read Apache-style configuration files 51 | 52 | lib_constants.f90 (no dependencies) 53 | Defines some physical constants in SI and CGS units 54 | 55 | lib_hdf5.f90 (requires the HDF5 library to be installed) 56 | Defines wrapper routines for the HDF5 library 57 | 58 | lib_io.f90 (requires the posix_*.f90 modules - see below) 59 | Defines various I/O operations (file deletion with confirmation, etc.) 60 | 61 | lib_messages.f90 62 | Defines warning/error routines 63 | 64 | lib_random.f90 65 | Defines routines to sample random numbers: 66 | - uniform random numbers between 0 and 1 67 | - uniform random numbers between two bounds 68 | - random number from exp(-x) PDF 69 | - random number from a normal distribution 70 | - random position on a sphere 71 | - random Poisson variables 72 | - random frequency from a Planck function 73 | 74 | posix_default.f90 and posix_nag.f90 75 | Define various low-level routines, such as checking for file/directory 76 | existence, and a routine to sleep a program for an amount of time defined in 77 | microseconds. If using the NAG f95 compiler, use posix_nag.f90, otherwise 78 | use posix_default.f90 79 | 80 | type_angle3d.f90 (requires lib_random.f90) 81 | Defines a derived type for 3D angles, and associated routines 82 | 83 | type_pdf.f90 (requires lib_array.f90 and lib_random.f90) 84 | Defines derived types for discrete and continuous PDFs, and associated 85 | routines (including for sampling the PDFs). 86 | 87 | type_stokes.f90 88 | Defines a derived type for Stokes vectors, and associated routines 89 | 90 | type_vector3d.f90 (requires lib_random.f90 and type_angle3d.f90) 91 | Defines a derived type for 3D vectors, and associated routines 92 | 93 | 94 | -------------------------------------------------------------------------------- /parse.py: -------------------------------------------------------------------------------- 1 | from __future__ import print_function 2 | 3 | import sys 4 | import glob 5 | import os 6 | from hashlib import md5 7 | 8 | 9 | def findnext(list, string): 10 | for i in range(len(list)): 11 | if(list[i].strip().find(string) == 0): 12 | return i 13 | raise Exception("String not found") 14 | 15 | 16 | def parse_fortran_template(input,output): 17 | 18 | # Find file checksum 19 | program = open(input, "rb") 20 | md5hash = md5(program.read()).hexdigest() 21 | program.close() 22 | 23 | # Read input file 24 | 25 | program = open(input, "r") 26 | lines = program.readlines() 27 | program.close() 28 | 29 | # Parse 30 | 31 | while True: 32 | 33 | try: 34 | istart = findnext(lines, "!!@FOR") 35 | iend = findnext(lines, "!!@END FOR") 36 | except: 37 | break 38 | 39 | print(" Block found from lines "+str(istart)+" to "+str(iend)) 40 | 41 | types = lines[istart].strip().rsplit() 42 | 43 | for type in types[1:]: 44 | 45 | (long, sep, short)=type.partition(":") 46 | 47 | for j in range(iend-1, istart, -1): 48 | if "@T" in lines[j] and not "intent" in lines[j]: 49 | long_new = long.replace("len=*", "len=1000") 50 | else: 51 | long_new = long 52 | new=lines[j].replace("@T", long_new) 53 | new=new.replace("", short) 54 | lines.insert(iend+1, new) 55 | 56 | for j in range(istart, iend+1): 57 | lines.pop(istart).strip() 58 | 59 | # Write output file 60 | 61 | output = open(output, "w") 62 | output.write("! MD5 of template: %s\n" % md5hash) 63 | output.writelines(lines) 64 | output.close() 65 | 66 | 67 | for program in glob.glob(os.path.join('templates/','*_template.f90')): 68 | print("Processing %s" % program) 69 | parse_fortran_template(program, program.replace('_template.f90','.f90').replace('templates','src')) 70 | -------------------------------------------------------------------------------- /src/base_types.f90: -------------------------------------------------------------------------------- 1 | ! ------------------------------------------------------------------------------ 2 | ! Copyright (c) 2009-13, Thomas P. Robitaille 3 | ! 4 | ! All rights reserved. 5 | ! 6 | ! Redistribution and use in source and binary forms, with or without 7 | ! modification, are permitted provided that the following conditions are met: 8 | ! 9 | ! * Redistributions of source code must retain the above copyright notice, this 10 | ! list of conditions and the following disclaimer. 11 | ! 12 | ! * Redistributions in binary form must reproduce the above copyright notice, 13 | ! this list of conditions and the following disclaimer in the documentation 14 | ! and/or other materials provided with the distribution. 15 | ! 16 | ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 17 | ! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 18 | ! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | ! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 20 | ! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 22 | ! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 23 | ! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 24 | ! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 25 | ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | ! ------------------------------------------------------------------------------ 27 | 28 | module base_types 29 | 30 | implicit none 31 | 32 | integer,parameter :: idp = selected_int_kind(13) 33 | integer,parameter :: sp = selected_real_kind(p=6,r=37) 34 | integer,parameter :: dp = selected_real_kind(p=15,r=307) 35 | 36 | end module base_types 37 | -------------------------------------------------------------------------------- /src/lib_algebra.f90: -------------------------------------------------------------------------------- 1 | ! MD5 of template: 9b6b4bb463e1543bdbfe618866a80346 2 | ! Algebra routines 3 | ! 4 | ! ------------------------------------------------------------------------------ 5 | ! Copyright (c) 2009-13, Thomas P. Robitaille 6 | ! 7 | ! All rights reserved. 8 | ! 9 | ! Redistribution and use in source and binary forms, with or without 10 | ! modification, are permitted provided that the following conditions are met: 11 | ! 12 | ! * Redistributions of source code must retain the above copyright notice, this 13 | ! list of conditions and the following disclaimer. 14 | ! 15 | ! * Redistributions in binary form must reproduce the above copyright notice, 16 | ! this list of conditions and the following disclaimer in the documentation 17 | ! and/or other materials provided with the distribution. 18 | ! 19 | ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 20 | ! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 21 | ! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | ! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 23 | ! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 25 | ! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | ! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 27 | ! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ! ------------------------------------------------------------------------------ 30 | 31 | module lib_algebra 32 | 33 | implicit none 34 | save 35 | 36 | private 37 | 38 | integer,parameter :: sp = selected_real_kind(p=6,r=37) 39 | integer,parameter :: dp = selected_real_kind(p=15,r=307) 40 | 41 | public :: cbrt 42 | interface cbrt 43 | module procedure cbrt_sp 44 | module procedure cbrt_dp 45 | end interface cbrt 46 | 47 | public :: quadratic 48 | interface quadratic 49 | module procedure quadratic_sp 50 | module procedure quadratic_dp 51 | end interface quadratic 52 | 53 | public :: quadratic_reduced 54 | interface quadratic_reduced 55 | module procedure quadratic_reduced_sp 56 | module procedure quadratic_reduced_dp 57 | end interface quadratic_reduced 58 | 59 | public :: quadratic_pascal 60 | interface quadratic_pascal 61 | module procedure quadratic_pascal_sp 62 | module procedure quadratic_pascal_dp 63 | end interface quadratic_pascal 64 | 65 | public :: quadratic_pascal_reduced 66 | interface quadratic_pascal_reduced 67 | module procedure quadratic_pascal_reduced_sp 68 | module procedure quadratic_pascal_reduced_dp 69 | end interface quadratic_pascal_reduced 70 | 71 | public :: lineq_gausselim 72 | interface lineq_gausselim 73 | module procedure lineq_gausselim_sp 74 | module procedure lineq_gausselim_dp 75 | end interface lineq_gausselim 76 | 77 | contains 78 | 79 | 80 | real(dp) function cbrt_dp(x) 81 | implicit none 82 | real(dp) :: x 83 | real(dp),parameter :: alpha = 1._dp / 3._dp 84 | if(x >= 0.) then 85 | cbrt_dp = x**alpha 86 | else 87 | cbrt_dp = - (abs(x))**alpha 88 | end if 89 | end function cbrt_dp 90 | 91 | subroutine quadratic_reduced_dp(b,c,x1,x2) 92 | implicit none 93 | real(dp),intent(in) :: b,c 94 | real(dp),intent(out) :: x1,x2 95 | real(dp) :: delta 96 | delta = b*b - 4._dp*c 97 | if(delta > 0) then 98 | delta = sqrt(delta) 99 | x1 = ( - b - delta ) * 0.5_dp 100 | x2 = ( - b + delta ) * 0.5_dp 101 | else 102 | x1 = huge(x1) 103 | x2 = huge(x2) 104 | end if 105 | end subroutine quadratic_reduced_dp 106 | 107 | subroutine quadratic_dp(a,b,c,x1,x2) 108 | implicit none 109 | real(dp),intent(in) :: a,b,c 110 | real(dp),intent(out) :: x1,x2 111 | real(dp) :: delta,factor 112 | delta = b*b - 4._dp*a*c 113 | if(delta > 0) then 114 | delta = sqrt(delta) 115 | factor = 0.5_dp / a 116 | x1 = ( - b - delta ) * factor 117 | x2 = ( - b + delta ) * factor 118 | else 119 | x1 = huge(x1) 120 | x2 = huge(x2) 121 | end if 122 | end subroutine quadratic_dp 123 | 124 | subroutine quadratic_pascal_dp(a,b,c,x1,x2) 125 | implicit none 126 | real(dp),intent(in) :: a,b,c 127 | real(dp),intent(out) :: x1,x2 128 | real(dp) :: q,delta 129 | delta = b*b - 4._dp*a*c 130 | if(delta > 0) then 131 | delta = sqrt(delta) 132 | delta = sign(delta,b) 133 | q = -0.5_dp * ( b + delta ) 134 | x1 = q / a 135 | x2 = c / q 136 | else if(delta < 0) then 137 | x1 = -huge(x1) 138 | x2 = -huge(x2) 139 | else 140 | x1 = - 2.0_dp * c / b 141 | x2 = -huge(x2) 142 | end if 143 | end subroutine quadratic_pascal_dp 144 | 145 | subroutine quadratic_pascal_reduced_dp(b,c,x1,x2) 146 | implicit none 147 | real(dp),intent(in) :: b,c 148 | real(dp),intent(out) :: x1,x2 149 | real(dp) :: q,delta 150 | delta = b*b - 4._dp*c 151 | if(delta > 0) then 152 | delta = sqrt(delta) 153 | delta = sign(delta,b) 154 | q = -0.5_dp * ( b + delta ) 155 | x1 = q 156 | x2 = c / q 157 | else if(delta < 0) then 158 | x1 = -huge(x1) 159 | x2 = -huge(x2) 160 | else 161 | x1 = - 2.0_dp * c / b 162 | x2 = -huge(x2) 163 | end if 164 | end subroutine quadratic_pascal_reduced_dp 165 | 166 | subroutine lineq_gausselim_dp(a,b) 167 | 168 | implicit none 169 | real(dp),intent(inout) :: a(:,:),b(:) 170 | real(dp) :: frac 171 | integer :: i,j 172 | integer :: n 173 | 174 | n = size(a,1) 175 | 176 | do i=1,n-1 177 | if(a(i,i)==0) stop "Zero pivot value" 178 | do j=i+1,n 179 | if(a(i,j).ne.0.) then 180 | frac = a(i,j)/a(i,i) 181 | b(j) = b(j) - frac * b(i) 182 | a(i:,j) = a(i:,j) - frac * a(i:,i) 183 | end if 184 | end do 185 | end do 186 | 187 | do i=n,2,-1 188 | do j=i-1,1,-1 189 | if(a(i,j).ne.0.) then 190 | frac = a(i,j)/a(i,i) 191 | b(j) = b(j) - frac * b(i) 192 | a(i:,j) = a(i:,j) - frac * a(i:,i) 193 | end if 194 | end do 195 | end do 196 | 197 | do i=1,n 198 | b(i) = b(i) / a(i,i) 199 | end do 200 | 201 | end subroutine lineq_gausselim_dp 202 | 203 | 204 | real(sp) function cbrt_sp(x) 205 | implicit none 206 | real(sp) :: x 207 | real(sp),parameter :: alpha = 1._sp / 3._sp 208 | if(x >= 0.) then 209 | cbrt_sp = x**alpha 210 | else 211 | cbrt_sp = - (abs(x))**alpha 212 | end if 213 | end function cbrt_sp 214 | 215 | subroutine quadratic_reduced_sp(b,c,x1,x2) 216 | implicit none 217 | real(sp),intent(in) :: b,c 218 | real(sp),intent(out) :: x1,x2 219 | real(sp) :: delta 220 | delta = b*b - 4._sp*c 221 | if(delta > 0) then 222 | delta = sqrt(delta) 223 | x1 = ( - b - delta ) * 0.5_sp 224 | x2 = ( - b + delta ) * 0.5_sp 225 | else 226 | x1 = huge(x1) 227 | x2 = huge(x2) 228 | end if 229 | end subroutine quadratic_reduced_sp 230 | 231 | subroutine quadratic_sp(a,b,c,x1,x2) 232 | implicit none 233 | real(sp),intent(in) :: a,b,c 234 | real(sp),intent(out) :: x1,x2 235 | real(sp) :: delta,factor 236 | delta = b*b - 4._sp*a*c 237 | if(delta > 0) then 238 | delta = sqrt(delta) 239 | factor = 0.5_sp / a 240 | x1 = ( - b - delta ) * factor 241 | x2 = ( - b + delta ) * factor 242 | else 243 | x1 = huge(x1) 244 | x2 = huge(x2) 245 | end if 246 | end subroutine quadratic_sp 247 | 248 | subroutine quadratic_pascal_sp(a,b,c,x1,x2) 249 | implicit none 250 | real(sp),intent(in) :: a,b,c 251 | real(sp),intent(out) :: x1,x2 252 | real(sp) :: q,delta 253 | delta = b*b - 4._sp*a*c 254 | if(delta > 0) then 255 | delta = sqrt(delta) 256 | delta = sign(delta,b) 257 | q = -0.5_sp * ( b + delta ) 258 | x1 = q / a 259 | x2 = c / q 260 | else if(delta < 0) then 261 | x1 = -huge(x1) 262 | x2 = -huge(x2) 263 | else 264 | x1 = - 2.0_sp * c / b 265 | x2 = -huge(x2) 266 | end if 267 | end subroutine quadratic_pascal_sp 268 | 269 | subroutine quadratic_pascal_reduced_sp(b,c,x1,x2) 270 | implicit none 271 | real(sp),intent(in) :: b,c 272 | real(sp),intent(out) :: x1,x2 273 | real(sp) :: q,delta 274 | delta = b*b - 4._sp*c 275 | if(delta > 0) then 276 | delta = sqrt(delta) 277 | delta = sign(delta,b) 278 | q = -0.5_sp * ( b + delta ) 279 | x1 = q 280 | x2 = c / q 281 | else if(delta < 0) then 282 | x1 = -huge(x1) 283 | x2 = -huge(x2) 284 | else 285 | x1 = - 2.0_sp * c / b 286 | x2 = -huge(x2) 287 | end if 288 | end subroutine quadratic_pascal_reduced_sp 289 | 290 | subroutine lineq_gausselim_sp(a,b) 291 | 292 | implicit none 293 | real(sp),intent(inout) :: a(:,:),b(:) 294 | real(sp) :: frac 295 | integer :: i,j 296 | integer :: n 297 | 298 | n = size(a,1) 299 | 300 | do i=1,n-1 301 | if(a(i,i)==0) stop "Zero pivot value" 302 | do j=i+1,n 303 | if(a(i,j).ne.0.) then 304 | frac = a(i,j)/a(i,i) 305 | b(j) = b(j) - frac * b(i) 306 | a(i:,j) = a(i:,j) - frac * a(i:,i) 307 | end if 308 | end do 309 | end do 310 | 311 | do i=n,2,-1 312 | do j=i-1,1,-1 313 | if(a(i,j).ne.0.) then 314 | frac = a(i,j)/a(i,i) 315 | b(j) = b(j) - frac * b(i) 316 | a(i:,j) = a(i:,j) - frac * a(i:,i) 317 | end if 318 | end do 319 | end do 320 | 321 | do i=1,n 322 | b(i) = b(i) / a(i,i) 323 | end do 324 | 325 | end subroutine lineq_gausselim_sp 326 | 327 | 328 | end module lib_algebra 329 | -------------------------------------------------------------------------------- /src/lib_conf.f90: -------------------------------------------------------------------------------- 1 | ! MD5 of template: 8ca8420e02fee968b6f8d829e4f8b5c7 2 | ! Array related routines (Integration, Interpolation, etc.) 3 | ! 4 | ! ------------------------------------------------------------------------------ 5 | ! Copyright (c) 2009-13, Thomas P. Robitaille 6 | ! 7 | ! All rights reserved. 8 | ! 9 | ! Redistribution and use in source and binary forms, with or without 10 | ! modification, are permitted provided that the following conditions are met: 11 | ! 12 | ! * Redistributions of source code must retain the above copyright notice, this 13 | ! list of conditions and the following disclaimer. 14 | ! 15 | ! * Redistributions in binary form must reproduce the above copyright notice, 16 | ! this list of conditions and the following disclaimer in the documentation 17 | ! and/or other materials provided with the distribution. 18 | ! 19 | ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 20 | ! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 21 | ! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | ! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 23 | ! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 25 | ! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | ! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 27 | ! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ! ------------------------------------------------------------------------------ 30 | ! 31 | ! This module contains subroutines to make it easy to read in 32 | ! configuration files. The expected format of a .conf file is 33 | ! an ASCII file with lines containing lines such as: 34 | ! 35 | ! parameter = value 36 | ! 37 | ! Note that character variables should be enclosed in inverted commas 38 | ! especially when giving paths to files. Commented lines (starting with 39 | ! a #) and blank lines are allowed. Comments directly following a 40 | ! parameter statement on the same line are NOT allowed: 41 | ! 42 | ! parameter = value # this is an INVALID comment 43 | ! 44 | ! The subroutines are: 45 | ! 46 | ! load_config_file(filename) - load a config file into RAM, ignoring 47 | ! comments and blank lines 48 | ! 49 | ! read_config(parameter,value) - read in the value for 'parameter' 50 | ! 51 | ! read_config is in fact an interface to four different subroutines 52 | ! depending on the type of the 'value' variable. This variable can 53 | ! be real(sp), real(dp), integer, or character(len=*) 54 | 55 | module lib_conf 56 | 57 | implicit none 58 | save 59 | 60 | private 61 | public :: load_config_file 62 | 63 | integer,parameter :: idp = selected_int_kind(13) 64 | integer,parameter :: sp = selected_real_kind(p=6,r=37) 65 | integer,parameter :: dp = selected_real_kind(p=15,r=307) 66 | 67 | integer,parameter :: config_file_len=1000 68 | integer,parameter :: config_line_len=100 69 | character(len=6),parameter :: config_line_fmt='(A100)' 70 | 71 | integer,private :: n_lines 72 | ! number of lines is the currently loaded config file 73 | 74 | character(len=config_line_len),dimension(config_file_len),private :: line 75 | ! the lines of the config file 76 | 77 | public :: read_config 78 | interface read_config 79 | module procedure config_real8,config_real4,config_char,config_int4,config_int8,config_logical 80 | end interface read_config 81 | 82 | interface read_from_string 83 | module procedure read_int4_from_string 84 | module procedure read_int8_from_string 85 | module procedure read_real4_from_string 86 | module procedure read_real8_from_string 87 | module procedure read_char_from_string 88 | module procedure read_logical_from_string 89 | end interface read_from_string 90 | 91 | contains 92 | 93 | subroutine read_int4_from_string(string,value) 94 | implicit none 95 | character(len=*),intent(in) :: string 96 | integer,intent(out) :: value 97 | read(string,*) value 98 | end subroutine read_int4_from_string 99 | 100 | subroutine read_int8_from_string(string,value) 101 | implicit none 102 | character(len=*),intent(in) :: string 103 | integer(idp),intent(out) :: value 104 | read(string,*) value 105 | end subroutine read_int8_from_string 106 | 107 | subroutine read_real4_from_string(string,value) 108 | implicit none 109 | character(len=*),intent(in) :: string 110 | real(sp),intent(out) :: value 111 | read(string,*) value 112 | end subroutine read_real4_from_string 113 | 114 | subroutine read_real8_from_string(string,value) 115 | implicit none 116 | character(len=*),intent(in) :: string 117 | real(dp),intent(out) :: value 118 | read(string,*) value 119 | end subroutine read_real8_from_string 120 | 121 | subroutine read_char_from_string(string,value) 122 | implicit none 123 | character(len=*),intent(in) :: string 124 | character(len=*),intent(out) :: value 125 | value = trim(adjustl(string)) 126 | end subroutine read_char_from_string 127 | 128 | subroutine read_logical_from_string(string,value) 129 | implicit none 130 | character(len=*),intent(in) :: string 131 | logical,intent(out) :: value 132 | select case(trim(adjustl(string))) 133 | case('Y','y','yes','YES','Yes','true',"'YES'") 134 | value=.true. 135 | case('N','n','no','NO','No','false',"'NO'") 136 | value=.false. 137 | case default 138 | print *,"unknown logical"//trim(string) 139 | end select 140 | end subroutine read_logical_from_string 141 | 142 | subroutine load_config_file(filename) 143 | 144 | implicit none 145 | 146 | ! --- Input --- ! 147 | 148 | character(len=*),intent(in) :: filename 149 | ! the name of the .conf file to read in 150 | 151 | ! --- Local variables --- ! 152 | 153 | character(len=config_line_len) :: line_temp 154 | 155 | integer :: ioerr 156 | ! used for I/O errors 157 | 158 | open(unit=80, file=filename, status='old') 159 | 160 | n_lines = 0 161 | line = '' 162 | 163 | do 164 | 165 | ! --- Read in the next line --- ! 166 | 167 | read(80,config_line_fmt,iostat=ioerr) line_temp 168 | if(ioerr.ne.0) exit 169 | 170 | ! --- Remove preceding whitespace --- ! 171 | 172 | line_temp = adjustl(line_temp) 173 | 174 | ! --- Ignore lines with nothing and lines with comments --- ! 175 | 176 | if(line_temp(1:1).ne.'#'.and.trim(line_temp).ne.'') then 177 | 178 | n_lines = n_lines + 1 179 | line(n_lines) = line_temp 180 | 181 | end if 182 | 183 | end do 184 | 185 | close(unit=80) 186 | 187 | end subroutine load_config_file 188 | 189 | 190 | subroutine config_logical(par_name,value,element) 191 | 192 | implicit none 193 | 194 | ! --- Input --- ! 195 | 196 | character(len=*),intent(in) :: par_name 197 | ! parameter to search for 198 | 199 | integer,optional,intent(in) :: element 200 | ! array element (if needed) 201 | 202 | ! --- Output --- ! 203 | 204 | logical,intent(out) :: value 205 | ! the value that was read in 206 | 207 | character(len=100) :: c_element,par_name_new,name_check 208 | ! temporary parameter name (e.g. with array index) 209 | 210 | integer :: i,pos 211 | ! loop and position variables 212 | 213 | logical :: found 214 | ! whether the parameter was found 215 | 216 | found = .false. 217 | 218 | if(present(element)) then 219 | write(c_element,'(I0)') element 220 | par_name_new = trim(par_name)//'('//trim(c_element)//')' 221 | else 222 | par_name_new = par_name 223 | end if 224 | 225 | do i=1,n_lines 226 | 227 | if(index(line(i),trim(par_name_new)).gt.0) then 228 | 229 | pos = index(line(i),'=') 230 | name_check = adjustl(line(i)(1:pos-1)) 231 | if(trim(name_check) == trim(par_name_new)) then 232 | call read_from_string(line(i)(pos+1:),value) 233 | found = .true. 234 | exit 235 | end if 236 | 237 | end if 238 | 239 | end do 240 | 241 | if(.not.found) then 242 | print *, "Parameter not found : "//trim(par_name_new) 243 | stop 244 | end if 245 | 246 | end subroutine config_logical 247 | 248 | 249 | subroutine config_real8(par_name,value,element) 250 | 251 | implicit none 252 | 253 | ! --- Input --- ! 254 | 255 | character(len=*),intent(in) :: par_name 256 | ! parameter to search for 257 | 258 | integer,optional,intent(in) :: element 259 | ! array element (if needed) 260 | 261 | ! --- Output --- ! 262 | 263 | real(dp),intent(out) :: value 264 | ! the value that was read in 265 | 266 | character(len=100) :: c_element,par_name_new,name_check 267 | ! temporary parameter name (e.g. with array index) 268 | 269 | integer :: i,pos 270 | ! loop and position variables 271 | 272 | logical :: found 273 | ! whether the parameter was found 274 | 275 | found = .false. 276 | 277 | if(present(element)) then 278 | write(c_element,'(I0)') element 279 | par_name_new = trim(par_name)//'('//trim(c_element)//')' 280 | else 281 | par_name_new = par_name 282 | end if 283 | 284 | do i=1,n_lines 285 | 286 | if(index(line(i),trim(par_name_new)).gt.0) then 287 | 288 | pos = index(line(i),'=') 289 | name_check = adjustl(line(i)(1:pos-1)) 290 | if(trim(name_check) == trim(par_name_new)) then 291 | call read_from_string(line(i)(pos+1:),value) 292 | found = .true. 293 | exit 294 | end if 295 | 296 | end if 297 | 298 | end do 299 | 300 | if(.not.found) then 301 | print *, "Parameter not found : "//trim(par_name_new) 302 | stop 303 | end if 304 | 305 | end subroutine config_real8 306 | 307 | 308 | subroutine config_real4(par_name,value,element) 309 | 310 | implicit none 311 | 312 | ! --- Input --- ! 313 | 314 | character(len=*),intent(in) :: par_name 315 | ! parameter to search for 316 | 317 | integer,optional,intent(in) :: element 318 | ! array element (if needed) 319 | 320 | ! --- Output --- ! 321 | 322 | real(sp),intent(out) :: value 323 | ! the value that was read in 324 | 325 | character(len=100) :: c_element,par_name_new,name_check 326 | ! temporary parameter name (e.g. with array index) 327 | 328 | integer :: i,pos 329 | ! loop and position variables 330 | 331 | logical :: found 332 | ! whether the parameter was found 333 | 334 | found = .false. 335 | 336 | if(present(element)) then 337 | write(c_element,'(I0)') element 338 | par_name_new = trim(par_name)//'('//trim(c_element)//')' 339 | else 340 | par_name_new = par_name 341 | end if 342 | 343 | do i=1,n_lines 344 | 345 | if(index(line(i),trim(par_name_new)).gt.0) then 346 | 347 | pos = index(line(i),'=') 348 | name_check = adjustl(line(i)(1:pos-1)) 349 | if(trim(name_check) == trim(par_name_new)) then 350 | call read_from_string(line(i)(pos+1:),value) 351 | found = .true. 352 | exit 353 | end if 354 | 355 | end if 356 | 357 | end do 358 | 359 | if(.not.found) then 360 | print *, "Parameter not found : "//trim(par_name_new) 361 | stop 362 | end if 363 | 364 | end subroutine config_real4 365 | 366 | 367 | subroutine config_char(par_name,value,element) 368 | 369 | implicit none 370 | 371 | ! --- Input --- ! 372 | 373 | character(len=*),intent(in) :: par_name 374 | ! parameter to search for 375 | 376 | integer,optional,intent(in) :: element 377 | ! array element (if needed) 378 | 379 | ! --- Output --- ! 380 | 381 | character(len=*),intent(out) :: value 382 | ! the value that was read in 383 | 384 | character(len=100) :: c_element,par_name_new,name_check 385 | ! temporary parameter name (e.g. with array index) 386 | 387 | integer :: i,pos 388 | ! loop and position variables 389 | 390 | logical :: found 391 | ! whether the parameter was found 392 | 393 | found = .false. 394 | 395 | if(present(element)) then 396 | write(c_element,'(I0)') element 397 | par_name_new = trim(par_name)//'('//trim(c_element)//')' 398 | else 399 | par_name_new = par_name 400 | end if 401 | 402 | do i=1,n_lines 403 | 404 | if(index(line(i),trim(par_name_new)).gt.0) then 405 | 406 | pos = index(line(i),'=') 407 | name_check = adjustl(line(i)(1:pos-1)) 408 | if(trim(name_check) == trim(par_name_new)) then 409 | call read_from_string(line(i)(pos+1:),value) 410 | found = .true. 411 | exit 412 | end if 413 | 414 | end if 415 | 416 | end do 417 | 418 | if(.not.found) then 419 | print *, "Parameter not found : "//trim(par_name_new) 420 | stop 421 | end if 422 | 423 | end subroutine config_char 424 | 425 | 426 | subroutine config_int8(par_name,value,element) 427 | 428 | implicit none 429 | 430 | ! --- Input --- ! 431 | 432 | character(len=*),intent(in) :: par_name 433 | ! parameter to search for 434 | 435 | integer,optional,intent(in) :: element 436 | ! array element (if needed) 437 | 438 | ! --- Output --- ! 439 | 440 | integer(idp),intent(out) :: value 441 | ! the value that was read in 442 | 443 | character(len=100) :: c_element,par_name_new,name_check 444 | ! temporary parameter name (e.g. with array index) 445 | 446 | integer :: i,pos 447 | ! loop and position variables 448 | 449 | logical :: found 450 | ! whether the parameter was found 451 | 452 | found = .false. 453 | 454 | if(present(element)) then 455 | write(c_element,'(I0)') element 456 | par_name_new = trim(par_name)//'('//trim(c_element)//')' 457 | else 458 | par_name_new = par_name 459 | end if 460 | 461 | do i=1,n_lines 462 | 463 | if(index(line(i),trim(par_name_new)).gt.0) then 464 | 465 | pos = index(line(i),'=') 466 | name_check = adjustl(line(i)(1:pos-1)) 467 | if(trim(name_check) == trim(par_name_new)) then 468 | call read_from_string(line(i)(pos+1:),value) 469 | found = .true. 470 | exit 471 | end if 472 | 473 | end if 474 | 475 | end do 476 | 477 | if(.not.found) then 478 | print *, "Parameter not found : "//trim(par_name_new) 479 | stop 480 | end if 481 | 482 | end subroutine config_int8 483 | 484 | 485 | subroutine config_int4(par_name,value,element) 486 | 487 | implicit none 488 | 489 | ! --- Input --- ! 490 | 491 | character(len=*),intent(in) :: par_name 492 | ! parameter to search for 493 | 494 | integer,optional,intent(in) :: element 495 | ! array element (if needed) 496 | 497 | ! --- Output --- ! 498 | 499 | integer,intent(out) :: value 500 | ! the value that was read in 501 | 502 | character(len=100) :: c_element,par_name_new,name_check 503 | ! temporary parameter name (e.g. with array index) 504 | 505 | integer :: i,pos 506 | ! loop and position variables 507 | 508 | logical :: found 509 | ! whether the parameter was found 510 | 511 | found = .false. 512 | 513 | if(present(element)) then 514 | write(c_element,'(I0)') element 515 | par_name_new = trim(par_name)//'('//trim(c_element)//')' 516 | else 517 | par_name_new = par_name 518 | end if 519 | 520 | do i=1,n_lines 521 | 522 | if(index(line(i),trim(par_name_new)).gt.0) then 523 | 524 | pos = index(line(i),'=') 525 | name_check = adjustl(line(i)(1:pos-1)) 526 | if(trim(name_check) == trim(par_name_new)) then 527 | call read_from_string(line(i)(pos+1:),value) 528 | found = .true. 529 | exit 530 | end if 531 | 532 | end if 533 | 534 | end do 535 | 536 | if(.not.found) then 537 | print *, "Parameter not found : "//trim(par_name_new) 538 | stop 539 | end if 540 | 541 | end subroutine config_int4 542 | 543 | 544 | end module lib_conf 545 | -------------------------------------------------------------------------------- /src/lib_constants.f90: -------------------------------------------------------------------------------- 1 | ! ------------------------------------------------------------------------------ 2 | ! Copyright (c) 2009-13, Thomas P. Robitaille 3 | ! 4 | ! All rights reserved. 5 | ! 6 | ! Redistribution and use in source and binary forms, with or without 7 | ! modification, are permitted provided that the following conditions are met: 8 | ! 9 | ! * Redistributions of source code must retain the above copyright notice, this 10 | ! list of conditions and the following disclaimer. 11 | ! 12 | ! * Redistributions in binary form must reproduce the above copyright notice, 13 | ! this list of conditions and the following disclaimer in the documentation 14 | ! and/or other materials provided with the distribution. 15 | ! 16 | ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 17 | ! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 18 | ! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | ! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 20 | ! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 22 | ! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 23 | ! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 24 | ! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 25 | ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | ! ------------------------------------------------------------------------------ 27 | 28 | module lib_constants 29 | 30 | implicit none 31 | save 32 | 33 | integer,parameter,private :: sp = selected_real_kind(p=6,r=37) 34 | integer,parameter,private :: dp = selected_real_kind(p=15,r=307) 35 | 36 | real(sp),parameter :: zero_sp = 0._sp 37 | real(dp),parameter :: zero_dp = 0._dp 38 | 39 | real(dp),parameter :: zero = 0._dp 40 | real(dp),parameter :: half = 0.5_dp 41 | real(dp),parameter :: one = 1._dp 42 | real(dp),parameter :: two = 2._dp 43 | 44 | ! Physical constants 45 | 46 | real(dp),parameter :: G_cgs = 6.67300d-08 47 | real(dp),parameter :: G_si = 6.67300d-11 48 | 49 | ! N = kg.m/s^2 = [G]*kg^2/m**2 50 | ! [G] = m^3/s^2/kg 51 | 52 | real(dp),parameter :: k_cgs = 1.380650424d-16 ! erg/K 53 | real(dp),parameter :: k_si = 1.380650424d-23 ! J/K 54 | 55 | real(dp),parameter :: h_cgs = 6.6260689633d-27 ! ergs.s 56 | real(dp),parameter :: h_si = 6.6260689633e-34_dp ! J.s 57 | 58 | real(dp),parameter :: c_si = 2.99792458e08_dp ! m / s 59 | real(dp),parameter :: c_cgs = 2.99792458e10_dp ! cm / s 60 | ! speed of light 61 | 62 | real(dp),parameter :: kpc_si = 3.08568025e19_dp ! m 63 | real(dp),parameter :: kpc_cgs = 3.08568025e21_dp ! cm 64 | ! kiloparsec 65 | 66 | real(dp),parameter :: pi = 3.14159265358979323846_dp 67 | real(sp),parameter :: pi_sp = 3.14159265358979323846_sp 68 | real(dp),parameter :: pi_dp = 3.14159265358979323846_dp 69 | 70 | real(dp),parameter :: twopi = pi + pi 71 | real(sp),parameter :: twopi_sp = pi_sp + pi_sp 72 | real(dp),parameter :: twopi_dp = pi_dp + pi_dp 73 | 74 | real(dp),parameter :: deg2rad = pi / 180._dp 75 | real(dp),parameter :: rad2deg = 180._dp / pi 76 | real(sp),parameter :: deg2rad_sp = pi_sp / 180._sp 77 | real(sp),parameter :: rad2deg_sp = 180._sp / pi_sp 78 | real(dp),parameter :: deg2rad_dp = pi_dp / 180._dp 79 | real(dp),parameter :: rad2deg_dp = 180._dp / pi_dp 80 | 81 | real(dp),parameter :: lsun_cgs = 3.846e33_dp ! erg/s 82 | 83 | real(dp),parameter :: rsun_cgs = 6.95508e10_dp ! cm 84 | 85 | real(dp),parameter :: au_cgs = 1.49598e13_dp ! cm 86 | 87 | real(dp),parameter :: year_cgs = 3600._dp * 24._dp * 365.25_dp 88 | 89 | real(dp),parameter :: msun_cgs = 1.989e33_dp ! g 90 | ! Conversions 91 | 92 | real(dp),parameter :: ergs2mJy = 1.e26_dp 93 | real(dp),parameter :: microns2cm = 1.e-4_dp 94 | real(dp),parameter :: microns2m = 1.e-6_dp 95 | 96 | real(dp),parameter :: stef_boltz = 5.670400e-5_dp 97 | 98 | contains 99 | 100 | real(sp) function infinity_sp() 101 | implicit none 102 | real(sp) :: x 103 | x = huge(1._sp) 104 | infinity_sp = x + x 105 | end function infinity_sp 106 | 107 | real(dp) function infinity_dp() 108 | implicit none 109 | real(dp) :: x 110 | x = huge(1._dp) 111 | infinity_dp = x + x 112 | end function infinity_dp 113 | 114 | end module lib_constants 115 | -------------------------------------------------------------------------------- /src/lib_messages.f90: -------------------------------------------------------------------------------- 1 | ! ------------------------------------------------------------------------------ 2 | ! Copyright (c) 2009-13, Thomas P. Robitaille 3 | ! 4 | ! All rights reserved. 5 | ! 6 | ! Redistribution and use in source and binary forms, with or without 7 | ! modification, are permitted provided that the following conditions are met: 8 | ! 9 | ! * Redistributions of source code must retain the above copyright notice, this 10 | ! list of conditions and the following disclaimer. 11 | ! 12 | ! * Redistributions in binary form must reproduce the above copyright notice, 13 | ! this list of conditions and the following disclaimer in the documentation 14 | ! and/or other materials provided with the distribution. 15 | ! 16 | ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 17 | ! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 18 | ! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | ! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 20 | ! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 22 | ! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 23 | ! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 24 | ! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 25 | ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | ! ------------------------------------------------------------------------------ 27 | 28 | module lib_messages 29 | 30 | implicit none 31 | save 32 | 33 | private 34 | public :: message_section 35 | public :: error 36 | public :: warning, warn 37 | public :: delimit 38 | public :: message 39 | public :: set_verbose_level 40 | public :: now 41 | 42 | integer,parameter :: sp = selected_real_kind(p=6,r=37) 43 | integer,parameter :: dp = selected_real_kind(p=15,r=307) 44 | 45 | integer :: verbose_level = 0 46 | 47 | public :: message_number 48 | interface message_number 49 | module procedure message_number_dp,message_number_int 50 | end interface message_number 51 | 52 | contains 53 | 54 | subroutine set_verbose_level(level) 55 | implicit none 56 | integer,intent(in) :: level 57 | verbose_level = level 58 | end subroutine set_verbose_level 59 | 60 | subroutine message(level,text) 61 | implicit none 62 | integer,intent(in) :: level 63 | character(len=*),intent(in) :: text 64 | character(len=10) :: fmt 65 | write(fmt,'("(",I0,"A)")') len(text) 66 | if(level <= verbose_level) write(*,fmt) text 67 | end subroutine message 68 | 69 | subroutine message_number_dp(level,text,number,format,units) 70 | implicit none 71 | integer,intent(in) :: level 72 | character(len=*),intent(in) :: text 73 | real(dp),intent(in) :: number 74 | character(len=*),intent(in) :: format,units 75 | character(len=20) :: char_number 76 | write(char_number,format) number 77 | if(level <= verbose_level) write(*,*) trim(text)//' '//trim(adjustl(char_number))//' '//trim(units) 78 | end subroutine message_number_dp 79 | 80 | subroutine message_number_int(level,text,number,format,units) 81 | implicit none 82 | integer,intent(in) :: level 83 | character(len=*),intent(in) :: text 84 | integer,intent(in) :: number 85 | character(len=*),intent(in) :: format,units 86 | character(len=20) :: char_number 87 | write(char_number,format) number 88 | if(level <= verbose_level) write(*,*) trim(text)//' '//trim(adjustl(char_number))//' '//trim(units) 89 | end subroutine message_number_int 90 | 91 | subroutine message_section(text) 92 | implicit none 93 | character(len=*),intent(in) :: text 94 | write(*,*) 95 | call delimit 96 | write(*,*) ' => '//trim(text) 97 | call delimit 98 | write(*,*) 99 | end subroutine message_section 100 | 101 | subroutine warning(location,text) 102 | implicit none 103 | character(len=*),intent(in) :: location,text 104 | call delimit 105 | write(*,*) "WARNING : ",trim(text) 106 | write(*,*) "WHERE : ",trim(location) 107 | call delimit 108 | end subroutine warning 109 | 110 | subroutine warn(location, text) 111 | implicit none 112 | character(len=*),intent(in) :: location,text 113 | write(*,'(" WARNING: ",A," [",A,"]")') text,location 114 | end subroutine warn 115 | 116 | character(len=30) function now() 117 | implicit none 118 | character(len=8) :: date 119 | character(len=10) :: time 120 | integer :: m 121 | call date_and_time(date,time) 122 | read(date(5:6),*) m 123 | now = date(7:8)//" "//trim(month(m))//" "//trim(date(1:4))//" at "//time(1:2)//":"//time(3:4)//":"//time(5:6) 124 | end function now 125 | 126 | subroutine error(location,text) 127 | 128 | implicit none 129 | 130 | character(len=*),intent(in) :: location,text 131 | 132 | character(len=8) :: date 133 | character(len=10) :: time 134 | 135 | integer :: m, imin, imax, j 136 | integer, parameter :: width = 61 137 | 138 | call date_and_time(date,time) 139 | read(date(5:6),*) m 140 | 141 | write(0,*) repeat('-',72) 142 | 143 | ! The following deals with the wrapping of the text, since it allows more 144 | ! verbose errors without messing up the formatting 145 | imin = 1 146 | do 147 | if(imin + width > len(text)) then 148 | ! End of message has been reached 149 | imax = len(text) 150 | else 151 | ! Look for spaces 152 | do j = width, 1, -1 153 | imax = imin + j 154 | if(text(imax:imax) == ' ') exit 155 | end do 156 | ! No spaces found, just force cut 157 | if(j == 0) imax = imin + width 158 | end if 159 | if(imin == 1) then 160 | write(0,*) "ERROR : ",text(imin:imax) 161 | else 162 | write(0,*) " ",text(imin:imax) 163 | end if 164 | if(imax == len(text)) exit 165 | imin = imax + 1 166 | end do 167 | 168 | write(0,*) "WHERE : ",trim(location) 169 | write(0,*) repeat('-',72) 170 | 171 | write(0,*) 172 | write(0,*) " *** Execution aborted on "& 173 | &//date(7:8)//" "//trim(month(m))//" "//trim(date(1:4))//" at "& 174 | &//time(1:2)//":"//time(3:4)//":"//time(5:6)//" ***" 175 | write(0,*) 176 | 177 | stop 178 | 179 | end subroutine error 180 | 181 | character(len=20) function month(i) 182 | implicit none 183 | integer,intent(in) :: i 184 | if(i==1) month="January" 185 | if(i==2) month="February" 186 | if(i==3) month="March" 187 | if(i==4) month="April" 188 | if(i==5) month="May" 189 | if(i==6) month="June" 190 | if(i==7) month="July" 191 | if(i==8) month="August" 192 | if(i==9) month="September" 193 | if(i==10) month="October" 194 | if(i==11) month="November" 195 | if(i==12) month="December" 196 | end function month 197 | 198 | subroutine delimit 199 | implicit none 200 | write(*,*) repeat('-',72) 201 | end subroutine delimit 202 | 203 | end module lib_messages 204 | -------------------------------------------------------------------------------- /src/lib_random.f90: -------------------------------------------------------------------------------- 1 | ! MD5 of template: 4e4c1de0723f7f9d694a1ee666961c00 2 | ! Random number generation related routines 3 | ! 4 | ! ------------------------------------------------------------------------------ 5 | ! Copyright (c) 2009-13, Thomas P. Robitaille 6 | ! 7 | ! All rights reserved. 8 | ! 9 | ! Redistribution and use in source and binary forms, with or without 10 | ! modification, are permitted provided that the following conditions are met: 11 | ! 12 | ! * Redistributions of source code must retain the above copyright notice, this 13 | ! list of conditions and the following disclaimer. 14 | ! 15 | ! * Redistributions in binary form must reproduce the above copyright notice, 16 | ! this list of conditions and the following disclaimer in the documentation 17 | ! and/or other materials provided with the distribution. 18 | ! 19 | ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 20 | ! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 21 | ! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | ! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 23 | ! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 25 | ! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | ! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 27 | ! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ! ------------------------------------------------------------------------------ 30 | 31 | module lib_random 32 | 33 | implicit none 34 | save 35 | 36 | private 37 | 38 | integer,parameter :: sp = selected_real_kind(p=6,r=37) 39 | integer,parameter :: dp = selected_real_kind(p=15,r=307) 40 | 41 | integer :: idum = -1204132124 42 | real(dp) :: u(97) 43 | !$OMP THREADPRIVATE(idum, u) 44 | 45 | real(dp),parameter :: pi = 3.14159265358979323846_dp 46 | real(sp),parameter :: pi_sp = 3.14159265358979323846_sp 47 | real(dp),parameter :: pi_dp = 3.14159265358979323846_dp 48 | 49 | real(dp),parameter :: twopi = 2._dp * pi 50 | real(sp),parameter :: twopi_sp = pi_sp + pi_sp 51 | real(dp),parameter :: twopi_dp = pi_dp + pi_dp 52 | 53 | public :: set_seed 54 | public :: set_seed_64 55 | 56 | public :: random 57 | interface random 58 | module procedure random_sp 59 | module procedure random_dp 60 | end interface random 61 | 62 | public :: random_exp 63 | interface random_exp 64 | module procedure random_exp_sp 65 | module procedure random_exp_dp 66 | end interface random_exp 67 | 68 | public :: random_uni 69 | interface random_uni 70 | module procedure random_uni_sp 71 | module procedure random_uni_dp 72 | end interface random_uni 73 | 74 | public :: random_gau 75 | interface random_gau 76 | module procedure random_gau_sp 77 | module procedure random_gau_dp 78 | end interface random_gau 79 | 80 | public :: random_sphere 81 | interface random_sphere 82 | module procedure random_sphere_sp 83 | module procedure random_sphere_dp 84 | end interface random_sphere 85 | 86 | public :: random_poisson 87 | interface random_poisson 88 | module procedure random_poisson_sp 89 | module procedure random_poisson_dp 90 | end interface random_poisson 91 | 92 | public :: random_planck_frequency 93 | interface random_planck_frequency 94 | module procedure random_planck_frequency_sp 95 | module procedure random_planck_frequency_dp 96 | end interface random_planck_frequency 97 | 98 | contains 99 | 100 | subroutine set_seed(seed) 101 | ! Note: this should be called with a different seed in each thread or 102 | ! process. 103 | implicit none 104 | integer,intent(in) :: seed 105 | idum = -abs(seed) 106 | call set_seed_64(abs(seed), 987654321) 107 | end subroutine set_seed 108 | 109 | subroutine set_seed_64(seed1,seed2) 110 | implicit none 111 | integer,intent(in) :: seed1,seed2 112 | integer i,j,x,y 113 | real(dp) :: s,t 114 | x=seed1 115 | y=seed2 116 | do i=1,97 117 | s=0._dp 118 | t=0.5_dp 119 | do j=1,53 120 | x=mod(6969*x,65543) 121 | y=mod(8888*x,65579) 122 | if (iand(ieor(x,y),32).gt.0) s=s+t 123 | t=0.5_dp*t 124 | end do 125 | u(i)=s 126 | end do 127 | end subroutine set_seed_64 128 | 129 | subroutine random_string(string) 130 | implicit none 131 | character(len=*),intent(out) :: string 132 | integer :: i,j 133 | real(dp) :: xi 134 | do i=1,len(string) 135 | call random(xi) 136 | j = int(xi*26._dp) 137 | call random(xi) 138 | if(xi < 0.5) then 139 | j = j + 65 140 | else 141 | j = j + 97 142 | end if 143 | string(i:i) = char(j) 144 | end do 145 | end subroutine random_string 146 | 147 | subroutine random_sp(xi) 148 | ! Random number between 0 and 1 149 | ! Inspired by Numerical Recipes 150 | implicit none 151 | real(sp),intent(out) :: xi 152 | real(sp),save :: am 153 | !$OMP THREADPRIVATE(am) 154 | integer, parameter :: ia=16807,im=2147483647,iq=127773,ir=2836 155 | integer, save :: ix=-1,iy=-1,k 156 | !$OMP THREADPRIVATE(ix, iy, k) 157 | if (idum <= 0 .or. iy < 0) then 158 | am=nearest(1.0_sp,-1.0_sp)/im 159 | iy=ior(ieor(888889999,abs(idum)),1) 160 | ix=ieor(777755555,abs(idum)) 161 | idum=abs(idum)+1 162 | end if 163 | ix=ieor(ix,ishft(ix,13)) 164 | ix=ieor(ix,ishft(ix,-17)) 165 | ix=ieor(ix,ishft(ix,5)) 166 | k=iy/iq 167 | iy=ia*(iy-k*iq)-ir*k 168 | if (iy < 0) iy=iy+im 169 | xi=am*ior(iand(im,ieor(ix,iy)),1) 170 | end subroutine random_sp 171 | 172 | subroutine random_dp(xi) 173 | ! Random number between 0 and 1 174 | ! Based on "The 64-bit universal RNG", Marsaglia & Tsang (2004) 175 | implicit none 176 | real(dp),intent(out) :: xi 177 | integer,save :: i=97 178 | integer,save :: j=33 179 | real(dp),save :: c=0 180 | !$OMP THREADPRIVATE(i, j, c) 181 | real(dp) :: x 182 | real(dp), parameter :: r=9007199254740881._dp/9007199254740992._dp 183 | real(dp), parameter :: d=362436069876._dp/9007199254740992._dp 184 | x=u(i)-u(j) 185 | if (x.lt.0.0) x=x+1.0_dp 186 | u(i)=x 187 | i=i-1 188 | if (i.eq.0) i=97 189 | j=j-1 190 | if (j.eq.0) j=97 191 | c=c-d 192 | if (c.lt.0.0) c=c+r 193 | x=x-c 194 | xi=x 195 | if (x.lt.0.) xi=x+1._dp 196 | return 197 | end subroutine random_dp 198 | 199 | 200 | subroutine random_uni_dp(xi,a,b) 201 | ! Uniform random number between a and b 202 | implicit none 203 | real(dp),intent(in) :: a,b 204 | real(dp),intent(out) :: xi 205 | call random(xi) 206 | xi = a + (b-a) * xi 207 | end subroutine random_uni_dp 208 | 209 | subroutine random_gau_dp(xi,c,w) 210 | ! Gaussian random number with center c and 1-sigma w 211 | implicit none 212 | real(dp),intent(in) :: c,w 213 | real(dp),intent(out) :: xi 214 | real(dp) :: r,g1,g2,x,y,t 215 | do 216 | call random_uni(x,-1._dp,+1._dp) 217 | call random_uni(y,-1._dp,+1._dp) 218 | r = x*x + y*y 219 | if(r.lt.1) exit 220 | end do 221 | t=sqrt(-2._dp*log(r)/r) 222 | g1 = x*t 223 | g2 = y*t 224 | xi = g1*w+c 225 | end subroutine random_gau_dp 226 | 227 | subroutine random_exp_dp(xi) 228 | ! Random number sampled from exp(-tau) 229 | implicit none 230 | real(dp),intent(out) :: xi 231 | do 232 | call random(xi) 233 | if(xi < 1._dp) exit 234 | end do 235 | xi = - log( 1._dp - xi ) 236 | end subroutine random_exp_dp 237 | 238 | 239 | subroutine random_sphere_dp(mu,phi) 240 | ! Random longitude/latitude on a sphere 241 | implicit none 242 | real(dp),intent(out) :: mu,phi 243 | call random_uni(mu,-1._dp,+1._dp) 244 | call random_uni(phi,0._dp,twopi_dp) 245 | end subroutine random_sphere_dp 246 | 247 | 248 | subroutine random_poisson_dp(xi,xm) 249 | ! Random number drawn from Poisson distribution with 250 | ! expected value xm 251 | 252 | implicit none 253 | 254 | real(dp),intent(in) :: xm 255 | real(dp),intent(out) :: xi 256 | real(dp) :: em,harvest,t,y 257 | 258 | real(dp), save :: alxm,g,oldm=-1.0_dp,sq 259 | !$OMP THREADPRIVATE(alxm,g,oldm,sq) 260 | 261 | if (xm < 12.0) then 262 | if (xm /= oldm) then 263 | oldm=xm 264 | g=exp(-xm) 265 | end if 266 | em=-1 267 | t=1.0 268 | do 269 | em=em+1.0_dp 270 | call random_dp(harvest) 271 | t=t*harvest 272 | if (t <= g) exit 273 | end do 274 | else 275 | if (xm /= oldm) then 276 | oldm=xm 277 | sq=sqrt(2.0_dp*xm) 278 | alxm=log(xm) 279 | g=xm*alxm-gammln_dp(xm+1.0_dp) 280 | end if 281 | do 282 | do 283 | call random_dp(harvest) 284 | y=tan(pi*harvest) 285 | em=sq*y+xm 286 | if (em >= 0.0) exit 287 | end do 288 | em=int(em) 289 | t=0.9_dp*(1.0_dp+y**2)*exp(em*alxm-gammln_dp(em+1.0_dp)-g) 290 | call random_dp(harvest) 291 | if (harvest <= t) exit 292 | end do 293 | end if 294 | xi = em 295 | end subroutine random_poisson_dp 296 | 297 | subroutine random_planck_frequency_dp(nu,T) 298 | 299 | ! Random frequency sampled from a planck function with temperature T 300 | 301 | ! The algorithm is taken from 'Sampling a random variable distributed 302 | ! according to planck's law' by Barnett and Canfield 303 | 304 | implicit none 305 | 306 | real(dp),intent(in) :: T 307 | real(dp),intent(out) :: nu 308 | real(dp) :: x,r,r1,r2,r3,r4,a,y,z 309 | 310 | real(dp),parameter :: k = 1.3806503e-23_dp ! J/K 311 | real(dp),parameter :: h = 6.626068e-34_dp ! J.s 312 | 313 | ! Sample a random number from x^3/(exp(x)-1) 314 | 315 | do 316 | 317 | call random(r1) 318 | call random(r2) 319 | call random(r3) 320 | call random(r4) 321 | 322 | r = r1*r2*r3*r4 323 | 324 | if(r > 0._dp) exit 325 | 326 | end do 327 | 328 | x = - log(r) 329 | 330 | a = 1._dp 331 | y = 1._dp 332 | z = 1._dp 333 | 334 | call random(r1) 335 | do 336 | if(1.08232_dp*r1 <= a) exit 337 | y = y + 1._dp 338 | z = 1._dp/y 339 | a = a + z*z*z*z 340 | end do 341 | x = x * z 342 | 343 | ! Convert to frequency 344 | 345 | nu = x * k * T / h 346 | 347 | end subroutine random_planck_frequency_dp 348 | 349 | real(dp) function gammln_dp(xx) 350 | 351 | implicit none 352 | 353 | real(dp),intent(in) :: xx 354 | integer :: j 355 | real(dp) :: ser,tmp,x,y 356 | 357 | real(dp),save :: cof(6) = (/76.18009172947146_dp,& 358 | &-86.50532032941677_dp,24.01409824083091_dp,& 359 | &-1.231739572450155_dp,.1208650973866179e-2_dp,& 360 | &-.5395239384953e-5_dp/) 361 | !$OMP THREADPRIVATE(cof) 362 | 363 | real(dp),save :: stp = 2.5066282746310005_dp 364 | !$OMP THREADPRIVATE(stp) 365 | 366 | x=xx 367 | y=x 368 | tmp=x+5.5_dp 369 | tmp=(x+0.5_dp)*log(tmp)-tmp 370 | ser=1.000000000190015_dp 371 | 372 | do j=1,6 373 | y=y+1._dp 374 | ser=ser+cof(j)/y 375 | end do 376 | 377 | gammln_dp=tmp+log(stp*ser/x) 378 | return 379 | 380 | end function gammln_dp 381 | 382 | 383 | subroutine random_uni_sp(xi,a,b) 384 | ! Uniform random number between a and b 385 | implicit none 386 | real(sp),intent(in) :: a,b 387 | real(sp),intent(out) :: xi 388 | call random(xi) 389 | xi = a + (b-a) * xi 390 | end subroutine random_uni_sp 391 | 392 | subroutine random_gau_sp(xi,c,w) 393 | ! Gaussian random number with center c and 1-sigma w 394 | implicit none 395 | real(sp),intent(in) :: c,w 396 | real(sp),intent(out) :: xi 397 | real(sp) :: r,g1,g2,x,y,t 398 | do 399 | call random_uni(x,-1._sp,+1._sp) 400 | call random_uni(y,-1._sp,+1._sp) 401 | r = x*x + y*y 402 | if(r.lt.1) exit 403 | end do 404 | t=sqrt(-2._sp*log(r)/r) 405 | g1 = x*t 406 | g2 = y*t 407 | xi = g1*w+c 408 | end subroutine random_gau_sp 409 | 410 | subroutine random_exp_sp(xi) 411 | ! Random number sampled from exp(-tau) 412 | implicit none 413 | real(sp),intent(out) :: xi 414 | do 415 | call random(xi) 416 | if(xi < 1._sp) exit 417 | end do 418 | xi = - log( 1._sp - xi ) 419 | end subroutine random_exp_sp 420 | 421 | 422 | subroutine random_sphere_sp(mu,phi) 423 | ! Random longitude/latitude on a sphere 424 | implicit none 425 | real(sp),intent(out) :: mu,phi 426 | call random_uni(mu,-1._sp,+1._sp) 427 | call random_uni(phi,0._sp,twopi_sp) 428 | end subroutine random_sphere_sp 429 | 430 | 431 | subroutine random_poisson_sp(xi,xm) 432 | ! Random number drawn from Poisson distribution with 433 | ! expected value xm 434 | 435 | implicit none 436 | 437 | real(sp),intent(in) :: xm 438 | real(sp),intent(out) :: xi 439 | real(sp) :: em,harvest,t,y 440 | 441 | real(sp), save :: alxm,g,oldm=-1.0_sp,sq 442 | !$OMP THREADPRIVATE(alxm,g,oldm,sq) 443 | 444 | if (xm < 12.0) then 445 | if (xm /= oldm) then 446 | oldm=xm 447 | g=exp(-xm) 448 | end if 449 | em=-1 450 | t=1.0 451 | do 452 | em=em+1.0_sp 453 | call random_sp(harvest) 454 | t=t*harvest 455 | if (t <= g) exit 456 | end do 457 | else 458 | if (xm /= oldm) then 459 | oldm=xm 460 | sq=sqrt(2.0_sp*xm) 461 | alxm=log(xm) 462 | g=xm*alxm-gammln_sp(xm+1.0_sp) 463 | end if 464 | do 465 | do 466 | call random_sp(harvest) 467 | y=tan(pi*harvest) 468 | em=sq*y+xm 469 | if (em >= 0.0) exit 470 | end do 471 | em=int(em) 472 | t=0.9_sp*(1.0_sp+y**2)*exp(em*alxm-gammln_sp(em+1.0_sp)-g) 473 | call random_sp(harvest) 474 | if (harvest <= t) exit 475 | end do 476 | end if 477 | xi = em 478 | end subroutine random_poisson_sp 479 | 480 | subroutine random_planck_frequency_sp(nu,T) 481 | 482 | ! Random frequency sampled from a planck function with temperature T 483 | 484 | ! The algorithm is taken from 'Sampling a random variable distributed 485 | ! according to planck's law' by Barnett and Canfield 486 | 487 | implicit none 488 | 489 | real(sp),intent(in) :: T 490 | real(sp),intent(out) :: nu 491 | real(sp) :: x,r,r1,r2,r3,r4,a,y,z 492 | 493 | real(sp),parameter :: k = 1.3806503e-23_sp ! J/K 494 | real(sp),parameter :: h = 6.626068e-34_sp ! J.s 495 | 496 | ! Sample a random number from x^3/(exp(x)-1) 497 | 498 | do 499 | 500 | call random(r1) 501 | call random(r2) 502 | call random(r3) 503 | call random(r4) 504 | 505 | r = r1*r2*r3*r4 506 | 507 | if(r > 0._dp) exit 508 | 509 | end do 510 | 511 | x = - log(r) 512 | 513 | a = 1._sp 514 | y = 1._sp 515 | z = 1._sp 516 | 517 | call random(r1) 518 | do 519 | if(1.08232_sp*r1 <= a) exit 520 | y = y + 1._sp 521 | z = 1._sp/y 522 | a = a + z*z*z*z 523 | end do 524 | x = x * z 525 | 526 | ! Convert to frequency 527 | 528 | nu = x * k * T / h 529 | 530 | end subroutine random_planck_frequency_sp 531 | 532 | real(sp) function gammln_sp(xx) 533 | 534 | implicit none 535 | 536 | real(sp),intent(in) :: xx 537 | integer :: j 538 | real(sp) :: ser,tmp,x,y 539 | 540 | real(sp),save :: cof(6) = (/76.18009172947146_sp,& 541 | &-86.50532032941677_sp,24.01409824083091_sp,& 542 | &-1.231739572450155_sp,.1208650973866179e-2_sp,& 543 | &-.5395239384953e-5_sp/) 544 | !$OMP THREADPRIVATE(cof) 545 | 546 | real(sp),save :: stp = 2.5066282746310005_sp 547 | !$OMP THREADPRIVATE(stp) 548 | 549 | x=xx 550 | y=x 551 | tmp=x+5.5_sp 552 | tmp=(x+0.5_sp)*log(tmp)-tmp 553 | ser=1.000000000190015_sp 554 | 555 | do j=1,6 556 | y=y+1._sp 557 | ser=ser+cof(j)/y 558 | end do 559 | 560 | gammln_sp=tmp+log(stp*ser/x) 561 | return 562 | 563 | end function gammln_sp 564 | 565 | 566 | 567 | end module lib_random 568 | -------------------------------------------------------------------------------- /src/lib_statistics.f90: -------------------------------------------------------------------------------- 1 | ! MD5 of template: de2e124b77d41b637ba47e23b573548c 2 | ! Statistics 3 | ! 4 | ! ------------------------------------------------------------------------------ 5 | ! Copyright (c) 2009-13, Thomas P. Robitaille 6 | ! 7 | ! All rights reserved. 8 | ! 9 | ! Redistribution and use in source and binary forms, with or without 10 | ! modification, are permitted provided that the following conditions are met: 11 | ! 12 | ! * Redistributions of source code must retain the above copyright notice, this 13 | ! list of conditions and the following disclaimer. 14 | ! 15 | ! * Redistributions in binary form must reproduce the above copyright notice, 16 | ! this list of conditions and the following disclaimer in the documentation 17 | ! and/or other materials provided with the distribution. 18 | ! 19 | ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 20 | ! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 21 | ! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | ! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 23 | ! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 25 | ! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | ! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 27 | ! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ! ------------------------------------------------------------------------------ 30 | 31 | module lib_statistics 32 | 33 | use lib_array 34 | implicit none 35 | save 36 | 37 | private 38 | 39 | integer,parameter :: idp = selected_int_kind(13) 40 | integer,parameter :: sp = selected_real_kind(p=6,r=37) 41 | integer,parameter :: dp = selected_real_kind(p=15,r=307) 42 | 43 | public :: mean 44 | interface mean 45 | module procedure mean_sp 46 | module procedure mean_dp 47 | end interface mean 48 | 49 | public :: median 50 | interface median 51 | module procedure median_sp 52 | module procedure median_dp 53 | end interface median 54 | 55 | public :: quantile 56 | interface quantile 57 | module procedure quantile_sp 58 | module procedure quantile_dp 59 | end interface quantile 60 | 61 | public :: variance 62 | interface variance 63 | module procedure variance_sp 64 | module procedure variance_dp 65 | end interface variance 66 | 67 | public :: clipped_mean 68 | interface clipped_mean 69 | module procedure clipped_mean_sp 70 | module procedure clipped_mean_dp 71 | end interface clipped_mean 72 | 73 | contains 74 | 75 | 76 | real(dp) function mean_dp(x, mask) 77 | implicit none 78 | real(dp),intent(in) :: x(:) 79 | logical,intent(in),optional :: mask(:) 80 | if(present(mask)) then 81 | mean_dp = sum(x, mask=mask)/size(x) 82 | else 83 | mean_dp = sum(x)/size(x) 84 | end if 85 | end function mean_dp 86 | 87 | real(dp) function median_dp(x) 88 | implicit none 89 | real(dp),intent(in) :: x(:) 90 | real(dp),dimension(size(x)) :: x_sorted 91 | integer :: n 92 | n = size(x) 93 | x_sorted = x 94 | call quicksort(x_sorted) 95 | if(mod(n,2).eq.0) then 96 | median_dp=(x_sorted(n/2)+x_sorted(n/2+1))/2. 97 | else 98 | median_dp=x_sorted((n-1)/2+1) 99 | end if 100 | end function median_dp 101 | 102 | real(dp) function quantile_dp(x, percent, mask) 103 | implicit none 104 | real(dp),intent(in) :: x(:), percent 105 | logical,intent(in),optional :: mask(:) 106 | real(dp),allocatable :: x_sorted(:) 107 | integer :: n, ipos 108 | if(present(mask)) then 109 | n = count(mask) 110 | allocate(x_sorted(n)) 111 | x_sorted = pack(x, mask) 112 | else 113 | n = size(x) 114 | allocate(x_sorted(n)) 115 | x_sorted = x 116 | end if 117 | call quicksort(x_sorted) 118 | if(percent >= 100._dp) then 119 | ipos = n 120 | else if(percent <= 0._dp) then 121 | ipos = 1 122 | else 123 | ipos=nint(percent/100._dp*real(n-1, dp))+1 124 | end if 125 | quantile_dp=x_sorted(ipos) 126 | end function quantile_dp 127 | 128 | real(dp) function variance_dp(x, mask) 129 | implicit none 130 | real(dp),intent(in) :: x(:) 131 | logical,intent(in),optional :: mask(:) 132 | variance_dp = sum(x-mean(x, mask=mask)**2._dp)/(size(x)-1) 133 | end function variance_dp 134 | 135 | real(dp) function clipped_mean_dp(x, n) 136 | implicit none 137 | real(dp),intent(in) :: x(:) 138 | integer,intent(in) :: n 139 | logical,dimension(size(x)) :: keep 140 | real(dp) :: sigma 141 | integer :: n_before 142 | keep = .true. 143 | n_before = 0 144 | do 145 | clipped_mean_dp = mean(x, mask=keep) 146 | sigma = sqrt(variance(x, mask=keep)) 147 | keep = keep .and. abs(x-clipped_mean_dp) < real(n, dp) * sigma 148 | if(count(keep)==n_before) exit 149 | n_before = count(keep) 150 | end do 151 | end function clipped_mean_dp 152 | 153 | 154 | real(sp) function mean_sp(x, mask) 155 | implicit none 156 | real(sp),intent(in) :: x(:) 157 | logical,intent(in),optional :: mask(:) 158 | if(present(mask)) then 159 | mean_sp = sum(x, mask=mask)/size(x) 160 | else 161 | mean_sp = sum(x)/size(x) 162 | end if 163 | end function mean_sp 164 | 165 | real(sp) function median_sp(x) 166 | implicit none 167 | real(sp),intent(in) :: x(:) 168 | real(sp),dimension(size(x)) :: x_sorted 169 | integer :: n 170 | n = size(x) 171 | x_sorted = x 172 | call quicksort(x_sorted) 173 | if(mod(n,2).eq.0) then 174 | median_sp=(x_sorted(n/2)+x_sorted(n/2+1))/2. 175 | else 176 | median_sp=x_sorted((n-1)/2+1) 177 | end if 178 | end function median_sp 179 | 180 | real(sp) function quantile_sp(x, percent, mask) 181 | implicit none 182 | real(sp),intent(in) :: x(:), percent 183 | logical,intent(in),optional :: mask(:) 184 | real(sp),allocatable :: x_sorted(:) 185 | integer :: n, ipos 186 | if(present(mask)) then 187 | n = count(mask) 188 | allocate(x_sorted(n)) 189 | x_sorted = pack(x, mask) 190 | else 191 | n = size(x) 192 | allocate(x_sorted(n)) 193 | x_sorted = x 194 | end if 195 | call quicksort(x_sorted) 196 | if(percent >= 100._sp) then 197 | ipos = n 198 | else if(percent <= 0._sp) then 199 | ipos = 1 200 | else 201 | ipos=nint(percent/100._sp*real(n-1, sp))+1 202 | end if 203 | quantile_sp=x_sorted(ipos) 204 | end function quantile_sp 205 | 206 | real(sp) function variance_sp(x, mask) 207 | implicit none 208 | real(sp),intent(in) :: x(:) 209 | logical,intent(in),optional :: mask(:) 210 | variance_sp = sum(x-mean(x, mask=mask)**2._sp)/(size(x)-1) 211 | end function variance_sp 212 | 213 | real(sp) function clipped_mean_sp(x, n) 214 | implicit none 215 | real(sp),intent(in) :: x(:) 216 | integer,intent(in) :: n 217 | logical,dimension(size(x)) :: keep 218 | real(sp) :: sigma 219 | integer :: n_before 220 | keep = .true. 221 | n_before = 0 222 | do 223 | clipped_mean_sp = mean(x, mask=keep) 224 | sigma = sqrt(variance(x, mask=keep)) 225 | keep = keep .and. abs(x-clipped_mean_sp) < real(n, sp) * sigma 226 | if(count(keep)==n_before) exit 227 | n_before = count(keep) 228 | end do 229 | end function clipped_mean_sp 230 | 231 | 232 | end module lib_statistics 233 | -------------------------------------------------------------------------------- /src/lib_version.f90: -------------------------------------------------------------------------------- 1 | ! ------------------------------------------------------------------------------ 2 | ! Copyright (c) 2009-13, Thomas P. Robitaille 3 | ! 4 | ! All rights reserved. 5 | ! 6 | ! Redistribution and use in source and binary forms, with or without 7 | ! modification, are permitted provided that the following conditions are met: 8 | ! 9 | ! * Redistributions of source code must retain the above copyright notice, this 10 | ! list of conditions and the following disclaimer. 11 | ! 12 | ! * Redistributions in binary form must reproduce the above copyright notice, 13 | ! this list of conditions and the following disclaimer in the documentation 14 | ! and/or other materials provided with the distribution. 15 | ! 16 | ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 17 | ! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 18 | ! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | ! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 20 | ! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 22 | ! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 23 | ! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 24 | ! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 25 | ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | ! ------------------------------------------------------------------------------ 27 | 28 | module lib_version 29 | 30 | type version 31 | character(len=10) :: string 32 | end type version 33 | 34 | interface operator(>=) 35 | module procedure greater_or_equal 36 | end interface operator(>=) 37 | 38 | interface operator(<=) 39 | module procedure smaller_or_equal 40 | end interface operator(<=) 41 | 42 | interface operator(>) 43 | module procedure greater 44 | end interface operator(>) 45 | 46 | interface operator(<) 47 | module procedure smaller 48 | end interface operator(<) 49 | 50 | interface operator(==) 51 | module procedure equal 52 | end interface operator(==) 53 | 54 | contains 55 | 56 | logical function greater_or_equal(a, b) 57 | implicit none 58 | type(version),intent(in) :: a, b 59 | greater_or_equal = .not. smaller(a, b) 60 | end function greater_or_equal 61 | 62 | logical function smaller_or_equal(a, b) 63 | implicit none 64 | type(version),intent(in) :: a, b 65 | smaller_or_equal = .not. greater(a, b) 66 | end function smaller_or_equal 67 | 68 | logical function smaller(a, b) 69 | implicit none 70 | type(version),intent(in) :: a, b 71 | smaller = .not. greater(a, b) .and. .not. equal(a, b) 72 | end function smaller 73 | 74 | logical function equal(a, b) 75 | implicit none 76 | type(version),intent(in) :: a, b 77 | equal = a%string == b%string 78 | end function equal 79 | 80 | logical function greater(a, b) 81 | implicit none 82 | type(version),intent(in) :: a, b 83 | integer :: p1a, p2a, p1b, p2b, ia, ib 84 | 85 | p1a = 1 86 | p1b = 1 87 | 88 | do 89 | 90 | p2a = index(a%string(p1a:), '.') 91 | p2b = index(b%string(p1b:), '.') 92 | 93 | if(p2a == 0 .neqv. p2b == 0) then 94 | stop "ERROR: version strings need to have the same precision" 95 | end if 96 | 97 | if(p2a == 0) then 98 | read(a%string(p1a:), *) ia 99 | read(b%string(p1b:), *) ib 100 | else 101 | read(a%string(p1a:p1a + p2a - 2), *) ia 102 | read(b%string(p1b:p1b + p2b - 2), *) ib 103 | end if 104 | 105 | if(ia > ib) then 106 | greater = .true. 107 | return 108 | else if(ia < ib) then 109 | greater = .false. 110 | return 111 | end if 112 | 113 | if(p2a == 0 .or. p2b == 0) exit 114 | 115 | p1a = p2a + p1a 116 | p1b = p2b + p1b 117 | 118 | end do 119 | 120 | greater = .false. 121 | 122 | end function greater 123 | 124 | end module lib_version 125 | 126 | 127 | -------------------------------------------------------------------------------- /src/posix_default.f90: -------------------------------------------------------------------------------- 1 | ! ------------------------------------------------------------------------------ 2 | ! Copyright (c) 2009-13, Thomas P. Robitaille 3 | ! 4 | ! All rights reserved. 5 | ! 6 | ! Redistribution and use in source and binary forms, with or without 7 | ! modification, are permitted provided that the following conditions are met: 8 | ! 9 | ! * Redistributions of source code must retain the above copyright notice, this 10 | ! list of conditions and the following disclaimer. 11 | ! 12 | ! * Redistributions in binary form must reproduce the above copyright notice, 13 | ! this list of conditions and the following disclaimer in the documentation 14 | ! and/or other materials provided with the distribution. 15 | ! 16 | ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 17 | ! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 18 | ! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | ! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 20 | ! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 22 | ! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 23 | ! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 24 | ! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 25 | ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | ! ------------------------------------------------------------------------------ 27 | 28 | module posix 29 | 30 | use iso_c_binding 31 | 32 | implicit none 33 | save 34 | 35 | interface 36 | subroutine usleep(useconds) bind(C) 37 | use iso_c_binding 38 | implicit none 39 | integer(c_int32_t), value :: useconds 40 | end subroutine usleep 41 | end interface 42 | 43 | contains 44 | 45 | logical function file_exists(file) 46 | implicit none 47 | character(len=*),intent(in) :: file 48 | integer :: access 49 | file_exists = access(file,' ').eq.0 50 | end function file_exists 51 | 52 | logical function dir_exists(dir) 53 | implicit none 54 | character(len=*),intent(in) :: dir 55 | integer :: access 56 | dir_exists = access(dir,' ').eq.0 57 | end function dir_exists 58 | 59 | subroutine microsleep(microseconds) 60 | integer,intent(in) :: microseconds 61 | call usleep(int(microseconds, c_int32_t)) 62 | end subroutine microsleep 63 | 64 | end module posix 65 | -------------------------------------------------------------------------------- /src/posix_nag.f90: -------------------------------------------------------------------------------- 1 | ! ------------------------------------------------------------------------------ 2 | ! Copyright (c) 2009-13, Thomas P. Robitaille 3 | ! 4 | ! All rights reserved. 5 | ! 6 | ! Redistribution and use in source and binary forms, with or without 7 | ! modification, are permitted provided that the following conditions are met: 8 | ! 9 | ! * Redistributions of source code must retain the above copyright notice, this 10 | ! list of conditions and the following disclaimer. 11 | ! 12 | ! * Redistributions in binary form must reproduce the above copyright notice, 13 | ! this list of conditions and the following disclaimer in the documentation 14 | ! and/or other materials provided with the distribution. 15 | ! 16 | ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 17 | ! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 18 | ! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | ! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 20 | ! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 22 | ! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 23 | ! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 24 | ! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 25 | ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | ! ------------------------------------------------------------------------------ 27 | 28 | module posix 29 | 30 | use iso_c_binding 31 | 32 | use f90_unix, only : flush 33 | use f90_unix_file 34 | use f90_unix_proc, only : system 35 | 36 | implicit none 37 | 38 | interface 39 | subroutine usleep(useconds) bind(C) 40 | use iso_c_binding 41 | implicit none 42 | integer(c_int32_t), value :: useconds 43 | end subroutine usleep 44 | end interface 45 | 46 | contains 47 | 48 | logical function file_exists(file) 49 | implicit none 50 | character(len=*),intent(in) :: file 51 | integer :: errno 52 | call access(trim(file),F_OK,errno) 53 | file_exists = errno == 0 54 | end function file_exists 55 | 56 | logical function dir_exists(dir) 57 | implicit none 58 | character(len=*),intent(in) :: dir 59 | integer :: errno 60 | call access(trim(dir),F_OK,errno) 61 | dir_exists = errno == 0 62 | end function dir_exists 63 | 64 | subroutine microsleep(microseconds) 65 | integer,intent(in) :: microseconds 66 | call usleep(int(microseconds, c_int32_t)) 67 | end subroutine microsleep 68 | 69 | end module posix 70 | -------------------------------------------------------------------------------- /src/type_stokes.f90: -------------------------------------------------------------------------------- 1 | ! MD5 of template: b74cf17929540ac05b6b5addd22f9262 2 | ! Stokes vector related routines 3 | ! 4 | ! ------------------------------------------------------------------------------ 5 | ! Copyright (c) 2009-13, Thomas P. Robitaille 6 | ! 7 | ! All rights reserved. 8 | ! 9 | ! Redistribution and use in source and binary forms, with or without 10 | ! modification, are permitted provided that the following conditions are met: 11 | ! 12 | ! * Redistributions of source code must retain the above copyright notice, this 13 | ! list of conditions and the following disclaimer. 14 | ! 15 | ! * Redistributions in binary form must reproduce the above copyright notice, 16 | ! this list of conditions and the following disclaimer in the documentation 17 | ! and/or other materials provided with the distribution. 18 | ! 19 | ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 20 | ! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 21 | ! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | ! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 23 | ! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 25 | ! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | ! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 27 | ! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ! ------------------------------------------------------------------------------ 30 | 31 | module type_stokes 32 | 33 | implicit none 34 | save 35 | 36 | private 37 | 38 | integer,parameter :: sp = selected_real_kind(p=6,r=37) 39 | integer,parameter :: dp = selected_real_kind(p=15,r=307) 40 | 41 | public :: stokes_dp 42 | type stokes_dp 43 | real(dp) :: I,U,Q,V 44 | end type stokes_dp 45 | 46 | public :: stokes_sp 47 | type stokes_sp 48 | real(sp) :: I,U,Q,V 49 | end type stokes_sp 50 | 51 | public :: operator(+) 52 | interface operator(+) 53 | module procedure add_stokes_sp 54 | module procedure add_stokes_dp 55 | end interface operator(+) 56 | 57 | public :: operator(-) 58 | interface operator(-) 59 | module procedure sub_stokes_sp 60 | module procedure sub_stokes_dp 61 | end interface operator(-) 62 | 63 | public :: operator(*) 64 | interface operator(*) 65 | module procedure scalar_stokes_mult_sp,stokes_scalar_mult_sp,stokes_stokes_mult_sp 66 | module procedure scalar_stokes_mult_dp,stokes_scalar_mult_dp,stokes_stokes_mult_dp 67 | end interface operator(*) 68 | 69 | public :: operator(/) 70 | interface operator(/) 71 | module procedure scalar_stokes_div_sp,stokes_scalar_div_sp 72 | module procedure scalar_stokes_div_dp,stokes_scalar_div_dp 73 | end interface operator(/) 74 | 75 | public :: operator(**) 76 | interface operator(**) 77 | module procedure pow_stokes_sp 78 | module procedure pow_stokes_dp 79 | end interface operator(**) 80 | 81 | contains 82 | 83 | 84 | !**********************************************************************! 85 | ! Stokes addition 86 | !**********************************************************************! 87 | 88 | type(stokes_dp) function add_stokes_dp(a,b) result(s) 89 | 90 | implicit none 91 | 92 | type(stokes_dp),intent(in) :: a,b 93 | 94 | s%I = a%I + b%I 95 | s%Q = a%Q + b%Q 96 | s%U = a%U + b%U 97 | s%V = a%V + b%V 98 | 99 | end function add_stokes_dp 100 | 101 | !**********************************************************************! 102 | ! Stokes subtraction 103 | !**********************************************************************! 104 | 105 | type(stokes_dp) function sub_stokes_dp(a,b) result(s) 106 | 107 | implicit none 108 | 109 | type(stokes_dp),intent(in) :: a,b 110 | 111 | s%I = a%I - b%I 112 | s%Q = a%Q - b%Q 113 | s%U = a%U - b%U 114 | s%V = a%V - b%V 115 | 116 | end function sub_stokes_dp 117 | 118 | !**********************************************************************! 119 | ! Scalar * Stokes 120 | !**********************************************************************! 121 | 122 | type(stokes_dp) function scalar_stokes_mult_dp(a,b) result(s) 123 | 124 | implicit none 125 | 126 | real(dp),intent(in) :: a 127 | type(stokes_dp),intent(in) :: b 128 | 129 | s%I = a * b%I 130 | s%Q = a * b%Q 131 | s%U = a * b%U 132 | s%V = a * b%V 133 | 134 | end function scalar_stokes_mult_dp 135 | 136 | type(stokes_dp) function stokes_scalar_mult_dp(a,b) result(s) 137 | 138 | implicit none 139 | 140 | type(stokes_dp),intent(in) :: a 141 | real(dp),intent(in) :: b 142 | 143 | s%I = a%I * b 144 | s%Q = a%Q * b 145 | s%U = a%U * b 146 | s%V = a%V * b 147 | 148 | end function stokes_scalar_mult_dp 149 | 150 | type(stokes_dp) function stokes_stokes_mult_dp(a,b) result(s) 151 | 152 | implicit none 153 | 154 | type(stokes_dp),intent(in) :: a, b 155 | 156 | s%I = a%I * b%I 157 | s%Q = a%Q * b%Q 158 | s%U = a%U * b%U 159 | s%V = a%V * b%V 160 | 161 | end function stokes_stokes_mult_dp 162 | 163 | !**********************************************************************! 164 | ! Scalar / Stokes 165 | !**********************************************************************! 166 | 167 | type(stokes_dp) function scalar_stokes_div_dp(a,b) result(s) 168 | 169 | implicit none 170 | 171 | real(dp),intent(in) :: a 172 | type(stokes_dp),intent(in) :: b 173 | 174 | s%I = a / b%I 175 | s%Q = a / b%Q 176 | s%U = a / b%U 177 | s%V = a / b%V 178 | 179 | end function scalar_stokes_div_dp 180 | 181 | type(stokes_dp) function stokes_scalar_div_dp(a,b) result(s) 182 | 183 | implicit none 184 | 185 | type(stokes_dp),intent(in) :: a 186 | real(dp),intent(in) :: b 187 | 188 | s%I = a%I / b 189 | s%Q = a%Q / b 190 | s%U = a%U / b 191 | s%V = a%V / b 192 | 193 | end function stokes_scalar_div_dp 194 | 195 | !**********************************************************************! 196 | ! Stokes power 197 | !**********************************************************************! 198 | 199 | type(stokes_dp) function pow_stokes_dp(a,power) result(s) 200 | 201 | implicit none 202 | 203 | type(stokes_dp),intent(in) :: a 204 | real(dp),intent(in) :: power 205 | 206 | s%I = a%I ** power 207 | s%Q = a%Q ** power 208 | s%U = a%U ** power 209 | s%V = a%V ** power 210 | 211 | end function pow_stokes_dp 212 | 213 | 214 | !**********************************************************************! 215 | ! Stokes addition 216 | !**********************************************************************! 217 | 218 | type(stokes_sp) function add_stokes_sp(a,b) result(s) 219 | 220 | implicit none 221 | 222 | type(stokes_sp),intent(in) :: a,b 223 | 224 | s%I = a%I + b%I 225 | s%Q = a%Q + b%Q 226 | s%U = a%U + b%U 227 | s%V = a%V + b%V 228 | 229 | end function add_stokes_sp 230 | 231 | !**********************************************************************! 232 | ! Stokes subtraction 233 | !**********************************************************************! 234 | 235 | type(stokes_sp) function sub_stokes_sp(a,b) result(s) 236 | 237 | implicit none 238 | 239 | type(stokes_sp),intent(in) :: a,b 240 | 241 | s%I = a%I - b%I 242 | s%Q = a%Q - b%Q 243 | s%U = a%U - b%U 244 | s%V = a%V - b%V 245 | 246 | end function sub_stokes_sp 247 | 248 | !**********************************************************************! 249 | ! Scalar * Stokes 250 | !**********************************************************************! 251 | 252 | type(stokes_sp) function scalar_stokes_mult_sp(a,b) result(s) 253 | 254 | implicit none 255 | 256 | real(sp),intent(in) :: a 257 | type(stokes_sp),intent(in) :: b 258 | 259 | s%I = a * b%I 260 | s%Q = a * b%Q 261 | s%U = a * b%U 262 | s%V = a * b%V 263 | 264 | end function scalar_stokes_mult_sp 265 | 266 | type(stokes_sp) function stokes_scalar_mult_sp(a,b) result(s) 267 | 268 | implicit none 269 | 270 | type(stokes_sp),intent(in) :: a 271 | real(sp),intent(in) :: b 272 | 273 | s%I = a%I * b 274 | s%Q = a%Q * b 275 | s%U = a%U * b 276 | s%V = a%V * b 277 | 278 | end function stokes_scalar_mult_sp 279 | 280 | type(stokes_sp) function stokes_stokes_mult_sp(a,b) result(s) 281 | 282 | implicit none 283 | 284 | type(stokes_sp),intent(in) :: a, b 285 | 286 | s%I = a%I * b%I 287 | s%Q = a%Q * b%Q 288 | s%U = a%U * b%U 289 | s%V = a%V * b%V 290 | 291 | end function stokes_stokes_mult_sp 292 | 293 | !**********************************************************************! 294 | ! Scalar / Stokes 295 | !**********************************************************************! 296 | 297 | type(stokes_sp) function scalar_stokes_div_sp(a,b) result(s) 298 | 299 | implicit none 300 | 301 | real(sp),intent(in) :: a 302 | type(stokes_sp),intent(in) :: b 303 | 304 | s%I = a / b%I 305 | s%Q = a / b%Q 306 | s%U = a / b%U 307 | s%V = a / b%V 308 | 309 | end function scalar_stokes_div_sp 310 | 311 | type(stokes_sp) function stokes_scalar_div_sp(a,b) result(s) 312 | 313 | implicit none 314 | 315 | type(stokes_sp),intent(in) :: a 316 | real(sp),intent(in) :: b 317 | 318 | s%I = a%I / b 319 | s%Q = a%Q / b 320 | s%U = a%U / b 321 | s%V = a%V / b 322 | 323 | end function stokes_scalar_div_sp 324 | 325 | !**********************************************************************! 326 | ! Stokes power 327 | !**********************************************************************! 328 | 329 | type(stokes_sp) function pow_stokes_sp(a,power) result(s) 330 | 331 | implicit none 332 | 333 | type(stokes_sp),intent(in) :: a 334 | real(sp),intent(in) :: power 335 | 336 | s%I = a%I ** power 337 | s%Q = a%Q ** power 338 | s%U = a%U ** power 339 | s%V = a%V ** power 340 | 341 | end function pow_stokes_sp 342 | 343 | 344 | end module type_stokes 345 | -------------------------------------------------------------------------------- /src/type_var1d_pdf.f90: -------------------------------------------------------------------------------- 1 | ! MD5 of template: f092f5ca93d239079bc43db4fba9bf60 2 | ! ------------------------------------------------------------------------------ 3 | ! Copyright (c) 2009-13, Thomas P. Robitaille 4 | ! 5 | ! All rights reserved. 6 | ! 7 | ! Redistribution and use in source and binary forms, with or without 8 | ! modification, are permitted provided that the following conditions are met: 9 | ! 10 | ! * Redistributions of source code must retain the above copyright notice, this 11 | ! list of conditions and the following disclaimer. 12 | ! 13 | ! * Redistributions in binary form must reproduce the above copyright notice, 14 | ! this list of conditions and the following disclaimer in the documentation 15 | ! and/or other materials provided with the distribution. 16 | ! 17 | ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 18 | ! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | ! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | ! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 21 | ! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 23 | ! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 24 | ! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 25 | ! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | ! ------------------------------------------------------------------------------ 28 | 29 | module type_var1d_pdf 30 | 31 | use lib_array, only : locate 32 | use lib_random, only : random 33 | use type_pdf, only : pdf_sp, pdf_dp, sample_pdf, set_pdf 34 | 35 | implicit none 36 | save 37 | 38 | private 39 | 40 | integer,parameter :: sp = selected_real_kind(p=6,r=37) 41 | integer,parameter :: dp = selected_real_kind(p=15,r=307) 42 | 43 | 44 | ! The purpose of this class is to implement a 1-d PDF that depends on another variable that is provided when sampling. The two PDFs neighboring the value requested are then sampled with the same random number, and the resulting value is then interpolated. 45 | 46 | 47 | public :: var1d_pdf_dp 48 | type var1d_pdf_dp 49 | integer :: nz 50 | real(dp), allocatable :: z(:) 51 | type(pdf_dp), allocatable :: p(:) 52 | end type var1d_pdf_dp 53 | 54 | 55 | public :: var1d_pdf_sp 56 | type var1d_pdf_sp 57 | integer :: nz 58 | real(sp), allocatable :: z(:) 59 | type(pdf_sp), allocatable :: p(:) 60 | end type var1d_pdf_sp 61 | 62 | 63 | public :: set_var1d_pdf 64 | interface set_var1d_pdf 65 | module procedure set_var1d_pdf_sp 66 | module procedure set_var1d_pdf_dp 67 | end interface set_var1d_pdf 68 | 69 | public :: sample_var1d_pdf 70 | interface sample_var1d_pdf 71 | module procedure sample_var1d_pdf_sp 72 | module procedure sample_var1d_pdf_dp 73 | end interface sample_var1d_pdf 74 | 75 | contains 76 | 77 | 78 | type(var1d_pdf_dp) function set_var1d_pdf_dp(x, z, prob) result(v) 79 | 80 | ! Initialize a var1d_pdf_dp object 81 | ! 82 | ! This version assumes that all the PDFs are defined on the same grid. 83 | ! We can easily create a version that has different x values for each 84 | ! PDF. 85 | ! 86 | ! Parameters 87 | ! ---------- 88 | ! x : 1-d array (size nx) 89 | ! x values in the PDFs 90 | ! z : 1-d array (size nz) 91 | ! Values that the PDFs are defined for 92 | ! prob : 2-d array (size nx, nz) 93 | ! The probabilities for all the x and z values 94 | 95 | implicit none 96 | real(dp),intent(in) :: x(:), z(:), prob(:,:) 97 | integer :: k 98 | 99 | if(size(prob,1) /= size(x)) stop "incorrect dimensions for prob" 100 | if(size(prob,2) /= size(z)) stop "incorrect dimensions for prob" 101 | 102 | v%nz = size(z) 103 | 104 | allocate(v%z(v%nz)) 105 | allocate(v%p(v%nz)) 106 | 107 | v%z = z 108 | 109 | do k=1,v%nz 110 | call set_pdf(v%p(k), x, prob(:, k)) 111 | end do 112 | 113 | end function set_var1d_pdf_dp 114 | 115 | real(dp) function sample_var1d_pdf_dp(z, v) result(x) 116 | 117 | ! Sample a var1d_pdf_dp object 118 | ! 119 | ! Parameters 120 | ! ---------- 121 | ! z : real(dp) 122 | ! The z value to sample the PDFs for 123 | ! v : var1d_pdf_dp 124 | ! The variable PDF to sample 125 | ! 126 | ! Returns 127 | ! ------- 128 | ! x : real(dp) 129 | ! The sampled value 130 | 131 | real(dp),intent(in) :: z 132 | type(var1d_pdf_dp),intent(in) :: v 133 | real(dp) :: x1, x2, xi 134 | integer :: iz 135 | 136 | ! Find bin in z array 137 | iz = locate(v%z, z) 138 | 139 | ! Sample random value 140 | call random(xi) 141 | 142 | ! Sample both PDFs 143 | x1 = sample_pdf(v%p(iz), xi_alt=xi) 144 | x2 = sample_pdf(v%p(iz+1), xi_alt=xi) 145 | 146 | ! Calculate result 147 | x = (z - v%z(iz)) / (v%z(iz+1) - v%z(iz)) * (x2 - x1) + x1 148 | 149 | end function sample_var1d_pdf_dp 150 | 151 | 152 | type(var1d_pdf_sp) function set_var1d_pdf_sp(x, z, prob) result(v) 153 | 154 | ! Initialize a var1d_pdf_sp object 155 | ! 156 | ! This version assumes that all the PDFs are defined on the same grid. 157 | ! We can easily create a version that has different x values for each 158 | ! PDF. 159 | ! 160 | ! Parameters 161 | ! ---------- 162 | ! x : 1-d array (size nx) 163 | ! x values in the PDFs 164 | ! z : 1-d array (size nz) 165 | ! Values that the PDFs are defined for 166 | ! prob : 2-d array (size nx, nz) 167 | ! The probabilities for all the x and z values 168 | 169 | implicit none 170 | real(sp),intent(in) :: x(:), z(:), prob(:,:) 171 | integer :: k 172 | 173 | if(size(prob,1) /= size(x)) stop "incorrect dimensions for prob" 174 | if(size(prob,2) /= size(z)) stop "incorrect dimensions for prob" 175 | 176 | v%nz = size(z) 177 | 178 | allocate(v%z(v%nz)) 179 | allocate(v%p(v%nz)) 180 | 181 | v%z = z 182 | 183 | do k=1,v%nz 184 | call set_pdf(v%p(k), x, prob(:, k)) 185 | end do 186 | 187 | end function set_var1d_pdf_sp 188 | 189 | real(sp) function sample_var1d_pdf_sp(z, v) result(x) 190 | 191 | ! Sample a var1d_pdf_sp object 192 | ! 193 | ! Parameters 194 | ! ---------- 195 | ! z : real(sp) 196 | ! The z value to sample the PDFs for 197 | ! v : var1d_pdf_sp 198 | ! The variable PDF to sample 199 | ! 200 | ! Returns 201 | ! ------- 202 | ! x : real(sp) 203 | ! The sampled value 204 | 205 | real(sp),intent(in) :: z 206 | type(var1d_pdf_sp),intent(in) :: v 207 | real(sp) :: x1, x2, xi 208 | integer :: iz 209 | 210 | ! Find bin in z array 211 | iz = locate(v%z, z) 212 | 213 | ! Sample random value 214 | call random(xi) 215 | 216 | ! Sample both PDFs 217 | x1 = sample_pdf(v%p(iz), xi_alt=xi) 218 | x2 = sample_pdf(v%p(iz+1), xi_alt=xi) 219 | 220 | ! Calculate result 221 | x = (z - v%z(iz)) / (v%z(iz+1) - v%z(iz)) * (x2 - x1) + x1 222 | 223 | end function sample_var1d_pdf_sp 224 | 225 | 226 | end module type_var1d_pdf 227 | 228 | -------------------------------------------------------------------------------- /src/type_var2d_pdf2d.f90: -------------------------------------------------------------------------------- 1 | ! MD5 of template: 8bd22331adb474e07197fb1405bb97d4 2 | ! ------------------------------------------------------------------------------ 3 | ! Copyright (c) 2009-13, Thomas P. Robitaille 4 | ! 5 | ! All rights reserved. 6 | ! 7 | ! Redistribution and use in source and binary forms, with or without 8 | ! modification, are permitted provided that the following conditions are met: 9 | ! 10 | ! * Redistributions of source code must retain the above copyright notice, this 11 | ! list of conditions and the following disclaimer. 12 | ! 13 | ! * Redistributions in binary form must reproduce the above copyright notice, 14 | ! this list of conditions and the following disclaimer in the documentation 15 | ! and/or other materials provided with the distribution. 16 | ! 17 | ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 18 | ! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | ! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | ! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 21 | ! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 23 | ! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 24 | ! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 25 | ! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | ! ------------------------------------------------------------------------------ 28 | 29 | module type_var2d_pdf2d 30 | 31 | use lib_array, only : locate, interp2d 32 | use lib_random, only : random 33 | use type_pdf2d, only : pdf2d_sp, pdf2d_dp, sample_pdf2d, set_pdf2d, interpolate_pdf2d 34 | 35 | implicit none 36 | save 37 | 38 | private 39 | 40 | integer,parameter :: sp = selected_real_kind(p=6,r=37) 41 | integer,parameter :: dp = selected_real_kind(p=15,r=307) 42 | 43 | ! The purpose of this class is to implement a 2-d PDF that depends on two 44 | ! other variables that are provided when sampling. The four PDFs neighboring 45 | ! the value requested are then sampled with the same random number, and the 46 | ! resulting value is then interpolated using bilinear interpolation. 47 | 48 | 49 | public :: var2d_pdf2d_dp 50 | type var2d_pdf2d_dp 51 | integer :: nw, nz 52 | real(dp), allocatable :: w(:) 53 | real(dp), allocatable :: z(:) 54 | type(pdf2d_dp), allocatable :: p(:,:) 55 | end type var2d_pdf2d_dp 56 | 57 | 58 | public :: var2d_pdf2d_sp 59 | type var2d_pdf2d_sp 60 | integer :: nw, nz 61 | real(sp), allocatable :: w(:) 62 | real(sp), allocatable :: z(:) 63 | type(pdf2d_sp), allocatable :: p(:,:) 64 | end type var2d_pdf2d_sp 65 | 66 | 67 | public :: set_var2d_pdf2d 68 | interface set_var2d_pdf2d 69 | module procedure set_var2d_pdf2d_sp 70 | module procedure set_var2d_pdf2d_dp 71 | end interface set_var2d_pdf2d 72 | 73 | public :: sample_var2d_pdf2d 74 | interface sample_var2d_pdf2d 75 | module procedure sample_var2d_pdf2d_sp 76 | module procedure sample_var2d_pdf2d_dp 77 | end interface sample_var2d_pdf2d 78 | 79 | public :: interpolate_var2d_pdf2d 80 | interface interpolate_var2d_pdf2d 81 | module procedure interpolate_var2d_pdf2d_sp 82 | module procedure interpolate_var2d_pdf2d_dp 83 | end interface interpolate_var2d_pdf2d 84 | 85 | contains 86 | 87 | 88 | type(var2d_pdf2d_dp) function set_var2d_pdf2d_dp(x, y, w, z, prob) result(v) 89 | 90 | ! Initialize a var2d_pdf2d_dp object 91 | ! 92 | ! This version assumes that all the PDFs are defined on the same grid. 93 | ! We can easily create a version that has different x and y values for 94 | ! each PDF. 95 | ! 96 | ! Parameters 97 | ! ---------- 98 | ! x : 1-d array (size nx) 99 | ! x values in the PDFs 100 | ! y : 1-d array (size ny) 101 | ! y values in the PDFs 102 | ! w : 1-d array (size nw) 103 | ! First set of values that the PDFs are defined for 104 | ! z : 1-d array (size nz) 105 | ! Second set of values that the PDFs are defined for 106 | ! prob : 2-d array (size nx, ny, nw, nz) 107 | ! The probabilities for all the x, y, w, and z values 108 | 109 | implicit none 110 | real(dp),intent(in) :: x(:), y(:), w(:), z(:), prob(:,:,:,:) 111 | integer :: iw,iz 112 | 113 | if(size(prob,1) /= size(x)) stop "incorrect dimensions for prob" 114 | if(size(prob,2) /= size(y)) stop "incorrect dimensions for prob" 115 | if(size(prob,3) /= size(w)) stop "incorrect dimensions for prob" 116 | if(size(prob,4) /= size(z)) stop "incorrect dimensions for prob" 117 | 118 | v%nw = size(w) 119 | v%nz = size(z) 120 | 121 | allocate(v%w(v%nw)) 122 | allocate(v%z(v%nz)) 123 | allocate(v%p(v%nw, v%nz)) 124 | 125 | v%w = w 126 | v%z = z 127 | 128 | do iw=1,v%nw 129 | do iz=1,v%nz 130 | v%p(iw,iz) = set_pdf2d(x, y, prob(:, :, iw, iz)) 131 | end do 132 | end do 133 | 134 | end function set_var2d_pdf2d_dp 135 | 136 | subroutine sample_var2d_pdf2d_dp(w, z, v, x, y) 137 | 138 | ! Sample a var2d_pdf2d_dp object 139 | ! 140 | ! Parameters 141 | ! ---------- 142 | ! w, z : real(dp) 143 | ! The w and z value to sample the PDFs for 144 | ! v : var2d_pdf2d_dp 145 | ! The variable PDF to sample 146 | ! 147 | ! Returns 148 | ! ------- 149 | ! x, y : real(dp) 150 | ! The sampled values 151 | 152 | real(dp),intent(in) :: w, z 153 | type(var2d_pdf2d_dp),intent(in) :: v 154 | real(dp),intent(out) :: x, y 155 | real(dp) :: x11,x12,x21,x22,y11,y12,y21,y22,xi(4) 156 | integer :: iw, iz 157 | integer :: i 158 | 159 | ! Find bin in w and z arrays 160 | iw = locate(v%w, w) 161 | iz = locate(v%z, z) 162 | 163 | ! Sample random values 164 | do i=1,4 165 | call random(xi(i)) 166 | end do 167 | 168 | ! Sample neighboring PDFs 169 | call sample_pdf2d(v%p(iw, iz), x11, y11, xi_alt=xi) 170 | call sample_pdf2d(v%p(iw+1, iz), x21, y21, xi_alt=xi) 171 | call sample_pdf2d(v%p(iw, iz+1), x12, y12, xi_alt=xi) 172 | call sample_pdf2d(v%p(iw+1, iz+1), x22, y22, xi_alt=xi) 173 | 174 | ! Calculate result using bilinear interpolation 175 | 176 | x = (x11 * (v%w(iw + 1) - w) * (v%z(iz + 1) - z) & 177 | & + x21 * (w - v%w(iw)) * (v%z(iz + 1) - z) & 178 | & + x12 * (v%w(iw + 1) - w) * (z - v%z(iz)) & 179 | & + x22 * (w - v%w(iw)) * (z - v%z(iz))) & 180 | & / (v%w(iw+1) - v%w(iw)) / (v%z(iz+1) - v%z(iz)) 181 | 182 | y = (y11 * (v%w(iw + 1) - w) * (v%z(iz + 1) - z) & 183 | & + y21 * (w - v%w(iw)) * (v%z(iz + 1) - z) & 184 | & + y12 * (v%w(iw + 1) - w) * (z - v%z(iz)) & 185 | & + y22 * (w - v%w(iw)) * (z - v%z(iz))) & 186 | & / (v%w(iw+1) - v%w(iw)) / (v%z(iz+1) - v%z(iz)) 187 | 188 | end subroutine sample_var2d_pdf2d_dp 189 | 190 | 191 | real(dp) function interpolate_var2d_pdf2d_dp(w, z, v, x, y, bounds_error, fill_value) result(prob) 192 | 193 | ! Interpolate a 2-d PDF 194 | ! 195 | ! Parameters 196 | ! ---------- 197 | ! w, z : real(dp) 198 | ! The w and z value to sample the PDFs for 199 | ! v : var2d_pdf2d_dp 200 | ! The variable PDF to interpolate 201 | ! x, y : real(dp) 202 | ! Position at which to interpolate the 2-d PDF 203 | ! bounds_error : logical, optional 204 | ! Whether to raise an error if the interpolation is out of bounds 205 | ! fill_value : real(dp) 206 | ! The value to use for out-of-bounds interpolation if bounds_error = .false. 207 | ! 208 | ! Returns 209 | ! ------- 210 | ! prob : real(dp) 211 | ! The probability at the position requested 212 | 213 | implicit none 214 | 215 | real(dp),intent(in) :: w, z 216 | type(var2d_pdf2d_dp),intent(in) :: v 217 | real(dp),intent(in) :: x, y 218 | logical,intent(in),optional :: bounds_error 219 | real(dp),intent(in),optional :: fill_value 220 | 221 | real(dp) :: p11,p12,p21,p22 222 | integer :: iw, iz 223 | 224 | ! Find bin in w and z arrays 225 | iw = locate(v%w, w) 226 | iz = locate(v%z, z) 227 | 228 | ! Interpolate neighboring PDFs 229 | p11 = interpolate_pdf2d(v%p(iw, iz), x, y, bounds_error, fill_value) 230 | p21 = interpolate_pdf2d(v%p(iw+1, iz), x, y, bounds_error, fill_value) 231 | p12 = interpolate_pdf2d(v%p(iw, iz+1), x, y, bounds_error, fill_value) 232 | p22 = interpolate_pdf2d(v%p(iw+1, iz+1), x, y, bounds_error, fill_value) 233 | 234 | ! Calculate result using bilinear interpolation 235 | 236 | prob = (p11 * (v%w(iw + 1) - w) * (v%z(iz + 1) - z) & 237 | & + p21 * (w - v%w(iw)) * (v%z(iz + 1) - z) & 238 | & + p12 * (v%w(iw + 1) - w) * (z - v%z(iz)) & 239 | & + p22 * (w - v%w(iw)) * (z - v%z(iz))) & 240 | & / (v%w(iw+1) - v%w(iw)) / (v%z(iz+1) - v%z(iz)) 241 | 242 | end function interpolate_var2d_pdf2d_dp 243 | 244 | 245 | type(var2d_pdf2d_sp) function set_var2d_pdf2d_sp(x, y, w, z, prob) result(v) 246 | 247 | ! Initialize a var2d_pdf2d_sp object 248 | ! 249 | ! This version assumes that all the PDFs are defined on the same grid. 250 | ! We can easily create a version that has different x and y values for 251 | ! each PDF. 252 | ! 253 | ! Parameters 254 | ! ---------- 255 | ! x : 1-d array (size nx) 256 | ! x values in the PDFs 257 | ! y : 1-d array (size ny) 258 | ! y values in the PDFs 259 | ! w : 1-d array (size nw) 260 | ! First set of values that the PDFs are defined for 261 | ! z : 1-d array (size nz) 262 | ! Second set of values that the PDFs are defined for 263 | ! prob : 2-d array (size nx, ny, nw, nz) 264 | ! The probabilities for all the x, y, w, and z values 265 | 266 | implicit none 267 | real(sp),intent(in) :: x(:), y(:), w(:), z(:), prob(:,:,:,:) 268 | integer :: iw,iz 269 | 270 | if(size(prob,1) /= size(x)) stop "incorrect dimensions for prob" 271 | if(size(prob,2) /= size(y)) stop "incorrect dimensions for prob" 272 | if(size(prob,3) /= size(w)) stop "incorrect dimensions for prob" 273 | if(size(prob,4) /= size(z)) stop "incorrect dimensions for prob" 274 | 275 | v%nw = size(w) 276 | v%nz = size(z) 277 | 278 | allocate(v%w(v%nw)) 279 | allocate(v%z(v%nz)) 280 | allocate(v%p(v%nw, v%nz)) 281 | 282 | v%w = w 283 | v%z = z 284 | 285 | do iw=1,v%nw 286 | do iz=1,v%nz 287 | v%p(iw,iz) = set_pdf2d(x, y, prob(:, :, iw, iz)) 288 | end do 289 | end do 290 | 291 | end function set_var2d_pdf2d_sp 292 | 293 | subroutine sample_var2d_pdf2d_sp(w, z, v, x, y) 294 | 295 | ! Sample a var2d_pdf2d_sp object 296 | ! 297 | ! Parameters 298 | ! ---------- 299 | ! w, z : real(sp) 300 | ! The w and z value to sample the PDFs for 301 | ! v : var2d_pdf2d_sp 302 | ! The variable PDF to sample 303 | ! 304 | ! Returns 305 | ! ------- 306 | ! x, y : real(sp) 307 | ! The sampled values 308 | 309 | real(sp),intent(in) :: w, z 310 | type(var2d_pdf2d_sp),intent(in) :: v 311 | real(sp),intent(out) :: x, y 312 | real(sp) :: x11,x12,x21,x22,y11,y12,y21,y22,xi(4) 313 | integer :: iw, iz 314 | integer :: i 315 | 316 | ! Find bin in w and z arrays 317 | iw = locate(v%w, w) 318 | iz = locate(v%z, z) 319 | 320 | ! Sample random values 321 | do i=1,4 322 | call random(xi(i)) 323 | end do 324 | 325 | ! Sample neighboring PDFs 326 | call sample_pdf2d(v%p(iw, iz), x11, y11, xi_alt=xi) 327 | call sample_pdf2d(v%p(iw+1, iz), x21, y21, xi_alt=xi) 328 | call sample_pdf2d(v%p(iw, iz+1), x12, y12, xi_alt=xi) 329 | call sample_pdf2d(v%p(iw+1, iz+1), x22, y22, xi_alt=xi) 330 | 331 | ! Calculate result using bilinear interpolation 332 | 333 | x = (x11 * (v%w(iw + 1) - w) * (v%z(iz + 1) - z) & 334 | & + x21 * (w - v%w(iw)) * (v%z(iz + 1) - z) & 335 | & + x12 * (v%w(iw + 1) - w) * (z - v%z(iz)) & 336 | & + x22 * (w - v%w(iw)) * (z - v%z(iz))) & 337 | & / (v%w(iw+1) - v%w(iw)) / (v%z(iz+1) - v%z(iz)) 338 | 339 | y = (y11 * (v%w(iw + 1) - w) * (v%z(iz + 1) - z) & 340 | & + y21 * (w - v%w(iw)) * (v%z(iz + 1) - z) & 341 | & + y12 * (v%w(iw + 1) - w) * (z - v%z(iz)) & 342 | & + y22 * (w - v%w(iw)) * (z - v%z(iz))) & 343 | & / (v%w(iw+1) - v%w(iw)) / (v%z(iz+1) - v%z(iz)) 344 | 345 | end subroutine sample_var2d_pdf2d_sp 346 | 347 | 348 | real(sp) function interpolate_var2d_pdf2d_sp(w, z, v, x, y, bounds_error, fill_value) result(prob) 349 | 350 | ! Interpolate a 2-d PDF 351 | ! 352 | ! Parameters 353 | ! ---------- 354 | ! w, z : real(sp) 355 | ! The w and z value to sample the PDFs for 356 | ! v : var2d_pdf2d_sp 357 | ! The variable PDF to interpolate 358 | ! x, y : real(sp) 359 | ! Position at which to interpolate the 2-d PDF 360 | ! bounds_error : logical, optional 361 | ! Whether to raise an error if the interpolation is out of bounds 362 | ! fill_value : real(sp) 363 | ! The value to use for out-of-bounds interpolation if bounds_error = .false. 364 | ! 365 | ! Returns 366 | ! ------- 367 | ! prob : real(sp) 368 | ! The probability at the position requested 369 | 370 | implicit none 371 | 372 | real(sp),intent(in) :: w, z 373 | type(var2d_pdf2d_sp),intent(in) :: v 374 | real(sp),intent(in) :: x, y 375 | logical,intent(in),optional :: bounds_error 376 | real(sp),intent(in),optional :: fill_value 377 | 378 | real(sp) :: p11,p12,p21,p22 379 | integer :: iw, iz 380 | 381 | ! Find bin in w and z arrays 382 | iw = locate(v%w, w) 383 | iz = locate(v%z, z) 384 | 385 | ! Interpolate neighboring PDFs 386 | p11 = interpolate_pdf2d(v%p(iw, iz), x, y, bounds_error, fill_value) 387 | p21 = interpolate_pdf2d(v%p(iw+1, iz), x, y, bounds_error, fill_value) 388 | p12 = interpolate_pdf2d(v%p(iw, iz+1), x, y, bounds_error, fill_value) 389 | p22 = interpolate_pdf2d(v%p(iw+1, iz+1), x, y, bounds_error, fill_value) 390 | 391 | ! Calculate result using bilinear interpolation 392 | 393 | prob = (p11 * (v%w(iw + 1) - w) * (v%z(iz + 1) - z) & 394 | & + p21 * (w - v%w(iw)) * (v%z(iz + 1) - z) & 395 | & + p12 * (v%w(iw + 1) - w) * (z - v%z(iz)) & 396 | & + p22 * (w - v%w(iw)) * (z - v%z(iz))) & 397 | & / (v%w(iw+1) - v%w(iw)) / (v%z(iz+1) - v%z(iz)) 398 | 399 | end function interpolate_var2d_pdf2d_sp 400 | 401 | 402 | end module type_var2d_pdf2d 403 | 404 | -------------------------------------------------------------------------------- /templates/lib_algebra_template.f90: -------------------------------------------------------------------------------- 1 | ! Algebra routines 2 | ! 3 | ! ------------------------------------------------------------------------------ 4 | ! Copyright (c) 2009-13, Thomas P. Robitaille 5 | ! 6 | ! All rights reserved. 7 | ! 8 | ! Redistribution and use in source and binary forms, with or without 9 | ! modification, are permitted provided that the following conditions are met: 10 | ! 11 | ! * Redistributions of source code must retain the above copyright notice, this 12 | ! list of conditions and the following disclaimer. 13 | ! 14 | ! * Redistributions in binary form must reproduce the above copyright notice, 15 | ! this list of conditions and the following disclaimer in the documentation 16 | ! and/or other materials provided with the distribution. 17 | ! 18 | ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19 | ! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | ! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | ! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | ! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | ! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | ! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | ! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | ! ------------------------------------------------------------------------------ 29 | 30 | module lib_algebra 31 | 32 | implicit none 33 | save 34 | 35 | private 36 | 37 | integer,parameter :: sp = selected_real_kind(p=6,r=37) 38 | integer,parameter :: dp = selected_real_kind(p=15,r=307) 39 | 40 | public :: cbrt 41 | interface cbrt 42 | module procedure cbrt_sp 43 | module procedure cbrt_dp 44 | end interface cbrt 45 | 46 | public :: quadratic 47 | interface quadratic 48 | module procedure quadratic_sp 49 | module procedure quadratic_dp 50 | end interface quadratic 51 | 52 | public :: quadratic_reduced 53 | interface quadratic_reduced 54 | module procedure quadratic_reduced_sp 55 | module procedure quadratic_reduced_dp 56 | end interface quadratic_reduced 57 | 58 | public :: quadratic_pascal 59 | interface quadratic_pascal 60 | module procedure quadratic_pascal_sp 61 | module procedure quadratic_pascal_dp 62 | end interface quadratic_pascal 63 | 64 | public :: quadratic_pascal_reduced 65 | interface quadratic_pascal_reduced 66 | module procedure quadratic_pascal_reduced_sp 67 | module procedure quadratic_pascal_reduced_dp 68 | end interface quadratic_pascal_reduced 69 | 70 | public :: lineq_gausselim 71 | interface lineq_gausselim 72 | module procedure lineq_gausselim_sp 73 | module procedure lineq_gausselim_dp 74 | end interface lineq_gausselim 75 | 76 | contains 77 | 78 | !!@FOR real(sp):sp real(dp):dp 79 | 80 | @T function cbrt_(x) 81 | implicit none 82 | @T :: x 83 | @T,parameter :: alpha = 1._ / 3._ 84 | if(x >= 0.) then 85 | cbrt_ = x**alpha 86 | else 87 | cbrt_ = - (abs(x))**alpha 88 | end if 89 | end function cbrt_ 90 | 91 | subroutine quadratic_reduced_(b,c,x1,x2) 92 | implicit none 93 | @T,intent(in) :: b,c 94 | @T,intent(out) :: x1,x2 95 | @T :: delta 96 | delta = b*b - 4._*c 97 | if(delta > 0) then 98 | delta = sqrt(delta) 99 | x1 = ( - b - delta ) * 0.5_ 100 | x2 = ( - b + delta ) * 0.5_ 101 | else 102 | x1 = huge(x1) 103 | x2 = huge(x2) 104 | end if 105 | end subroutine quadratic_reduced_ 106 | 107 | subroutine quadratic_(a,b,c,x1,x2) 108 | implicit none 109 | @T,intent(in) :: a,b,c 110 | @T,intent(out) :: x1,x2 111 | @T :: delta,factor 112 | delta = b*b - 4._*a*c 113 | if(delta > 0) then 114 | delta = sqrt(delta) 115 | factor = 0.5_ / a 116 | x1 = ( - b - delta ) * factor 117 | x2 = ( - b + delta ) * factor 118 | else 119 | x1 = huge(x1) 120 | x2 = huge(x2) 121 | end if 122 | end subroutine quadratic_ 123 | 124 | subroutine quadratic_pascal_(a,b,c,x1,x2) 125 | implicit none 126 | @T,intent(in) :: a,b,c 127 | @T,intent(out) :: x1,x2 128 | @T :: q,delta 129 | delta = b*b - 4._*a*c 130 | if(delta > 0) then 131 | delta = sqrt(delta) 132 | delta = sign(delta,b) 133 | q = -0.5_ * ( b + delta ) 134 | x1 = q / a 135 | x2 = c / q 136 | else if(delta < 0) then 137 | x1 = -huge(x1) 138 | x2 = -huge(x2) 139 | else 140 | x1 = - 2.0_ * c / b 141 | x2 = -huge(x2) 142 | end if 143 | end subroutine quadratic_pascal_ 144 | 145 | subroutine quadratic_pascal_reduced_(b,c,x1,x2) 146 | implicit none 147 | @T,intent(in) :: b,c 148 | @T,intent(out) :: x1,x2 149 | @T :: q,delta 150 | delta = b*b - 4._*c 151 | if(delta > 0) then 152 | delta = sqrt(delta) 153 | delta = sign(delta,b) 154 | q = -0.5_ * ( b + delta ) 155 | x1 = q 156 | x2 = c / q 157 | else if(delta < 0) then 158 | x1 = -huge(x1) 159 | x2 = -huge(x2) 160 | else 161 | x1 = - 2.0_ * c / b 162 | x2 = -huge(x2) 163 | end if 164 | end subroutine quadratic_pascal_reduced_ 165 | 166 | subroutine lineq_gausselim_(a,b) 167 | 168 | implicit none 169 | real(),intent(inout) :: a(:,:),b(:) 170 | real() :: frac 171 | integer :: i,j 172 | integer :: n 173 | 174 | n = size(a,1) 175 | 176 | do i=1,n-1 177 | if(a(i,i)==0) stop "Zero pivot value" 178 | do j=i+1,n 179 | if(a(i,j).ne.0.) then 180 | frac = a(i,j)/a(i,i) 181 | b(j) = b(j) - frac * b(i) 182 | a(i:,j) = a(i:,j) - frac * a(i:,i) 183 | end if 184 | end do 185 | end do 186 | 187 | do i=n,2,-1 188 | do j=i-1,1,-1 189 | if(a(i,j).ne.0.) then 190 | frac = a(i,j)/a(i,i) 191 | b(j) = b(j) - frac * b(i) 192 | a(i:,j) = a(i:,j) - frac * a(i:,i) 193 | end if 194 | end do 195 | end do 196 | 197 | do i=1,n 198 | b(i) = b(i) / a(i,i) 199 | end do 200 | 201 | end subroutine lineq_gausselim_ 202 | 203 | !!@END FOR 204 | 205 | end module lib_algebra 206 | -------------------------------------------------------------------------------- /templates/lib_conf_template.f90: -------------------------------------------------------------------------------- 1 | ! Array related routines (Integration, Interpolation, etc.) 2 | ! 3 | ! ------------------------------------------------------------------------------ 4 | ! Copyright (c) 2009-13, Thomas P. Robitaille 5 | ! 6 | ! All rights reserved. 7 | ! 8 | ! Redistribution and use in source and binary forms, with or without 9 | ! modification, are permitted provided that the following conditions are met: 10 | ! 11 | ! * Redistributions of source code must retain the above copyright notice, this 12 | ! list of conditions and the following disclaimer. 13 | ! 14 | ! * Redistributions in binary form must reproduce the above copyright notice, 15 | ! this list of conditions and the following disclaimer in the documentation 16 | ! and/or other materials provided with the distribution. 17 | ! 18 | ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19 | ! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | ! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | ! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | ! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | ! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | ! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | ! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | ! ------------------------------------------------------------------------------ 29 | ! 30 | ! This module contains subroutines to make it easy to read in 31 | ! configuration files. The expected format of a .conf file is 32 | ! an ASCII file with lines containing lines such as: 33 | ! 34 | ! parameter = value 35 | ! 36 | ! Note that character variables should be enclosed in inverted commas 37 | ! especially when giving paths to files. Commented lines (starting with 38 | ! a #) and blank lines are allowed. Comments directly following a 39 | ! parameter statement on the same line are NOT allowed: 40 | ! 41 | ! parameter = value # this is an INVALID comment 42 | ! 43 | ! The subroutines are: 44 | ! 45 | ! load_config_file(filename) - load a config file into RAM, ignoring 46 | ! comments and blank lines 47 | ! 48 | ! read_config(parameter,value) - read in the value for 'parameter' 49 | ! 50 | ! read_config is in fact an interface to four different subroutines 51 | ! depending on the type of the 'value' variable. This variable can 52 | ! be real(sp), real(dp), integer, or character(len=*) 53 | 54 | module lib_conf 55 | 56 | implicit none 57 | save 58 | 59 | private 60 | public :: load_config_file 61 | 62 | integer,parameter :: idp = selected_int_kind(13) 63 | integer,parameter :: sp = selected_real_kind(p=6,r=37) 64 | integer,parameter :: dp = selected_real_kind(p=15,r=307) 65 | 66 | integer,parameter :: config_file_len=1000 67 | integer,parameter :: config_line_len=100 68 | character(len=6),parameter :: config_line_fmt='(A100)' 69 | 70 | integer,private :: n_lines 71 | ! number of lines is the currently loaded config file 72 | 73 | character(len=config_line_len),dimension(config_file_len),private :: line 74 | ! the lines of the config file 75 | 76 | public :: read_config 77 | interface read_config 78 | module procedure config_real8,config_real4,config_char,config_int4,config_int8,config_logical 79 | end interface read_config 80 | 81 | interface read_from_string 82 | module procedure read_int4_from_string 83 | module procedure read_int8_from_string 84 | module procedure read_real4_from_string 85 | module procedure read_real8_from_string 86 | module procedure read_char_from_string 87 | module procedure read_logical_from_string 88 | end interface read_from_string 89 | 90 | contains 91 | 92 | subroutine read_int4_from_string(string,value) 93 | implicit none 94 | character(len=*),intent(in) :: string 95 | integer,intent(out) :: value 96 | read(string,*) value 97 | end subroutine read_int4_from_string 98 | 99 | subroutine read_int8_from_string(string,value) 100 | implicit none 101 | character(len=*),intent(in) :: string 102 | integer(idp),intent(out) :: value 103 | read(string,*) value 104 | end subroutine read_int8_from_string 105 | 106 | subroutine read_real4_from_string(string,value) 107 | implicit none 108 | character(len=*),intent(in) :: string 109 | real(sp),intent(out) :: value 110 | read(string,*) value 111 | end subroutine read_real4_from_string 112 | 113 | subroutine read_real8_from_string(string,value) 114 | implicit none 115 | character(len=*),intent(in) :: string 116 | real(dp),intent(out) :: value 117 | read(string,*) value 118 | end subroutine read_real8_from_string 119 | 120 | subroutine read_char_from_string(string,value) 121 | implicit none 122 | character(len=*),intent(in) :: string 123 | character(len=*),intent(out) :: value 124 | value = trim(adjustl(string)) 125 | end subroutine read_char_from_string 126 | 127 | subroutine read_logical_from_string(string,value) 128 | implicit none 129 | character(len=*),intent(in) :: string 130 | logical,intent(out) :: value 131 | select case(trim(adjustl(string))) 132 | case('Y','y','yes','YES','Yes','true',"'YES'") 133 | value=.true. 134 | case('N','n','no','NO','No','false',"'NO'") 135 | value=.false. 136 | case default 137 | print *,"unknown logical"//trim(string) 138 | end select 139 | end subroutine read_logical_from_string 140 | 141 | subroutine load_config_file(filename) 142 | 143 | implicit none 144 | 145 | ! --- Input --- ! 146 | 147 | character(len=*),intent(in) :: filename 148 | ! the name of the .conf file to read in 149 | 150 | ! --- Local variables --- ! 151 | 152 | character(len=config_line_len) :: line_temp 153 | 154 | integer :: ioerr 155 | ! used for I/O errors 156 | 157 | open(unit=80, file=filename, status='old') 158 | 159 | n_lines = 0 160 | line = '' 161 | 162 | do 163 | 164 | ! --- Read in the next line --- ! 165 | 166 | read(80,config_line_fmt,iostat=ioerr) line_temp 167 | if(ioerr.ne.0) exit 168 | 169 | ! --- Remove preceding whitespace --- ! 170 | 171 | line_temp = adjustl(line_temp) 172 | 173 | ! --- Ignore lines with nothing and lines with comments --- ! 174 | 175 | if(line_temp(1:1).ne.'#'.and.trim(line_temp).ne.'') then 176 | 177 | n_lines = n_lines + 1 178 | line(n_lines) = line_temp 179 | 180 | end if 181 | 182 | end do 183 | 184 | close(unit=80) 185 | 186 | end subroutine load_config_file 187 | 188 | !!@FOR integer:int4 integer(idp):int8 character(len=*):char real(sp):real4 real(dp):real8 logical:logical 189 | 190 | subroutine config_(par_name,value,element) 191 | 192 | implicit none 193 | 194 | ! --- Input --- ! 195 | 196 | character(len=*),intent(in) :: par_name 197 | ! parameter to search for 198 | 199 | integer,optional,intent(in) :: element 200 | ! array element (if needed) 201 | 202 | ! --- Output --- ! 203 | 204 | @T,intent(out) :: value 205 | ! the value that was read in 206 | 207 | character(len=100) :: c_element,par_name_new,name_check 208 | ! temporary parameter name (e.g. with array index) 209 | 210 | integer :: i,pos 211 | ! loop and position variables 212 | 213 | logical :: found 214 | ! whether the parameter was found 215 | 216 | found = .false. 217 | 218 | if(present(element)) then 219 | write(c_element,'(I0)') element 220 | par_name_new = trim(par_name)//'('//trim(c_element)//')' 221 | else 222 | par_name_new = par_name 223 | end if 224 | 225 | do i=1,n_lines 226 | 227 | if(index(line(i),trim(par_name_new)).gt.0) then 228 | 229 | pos = index(line(i),'=') 230 | name_check = adjustl(line(i)(1:pos-1)) 231 | if(trim(name_check) == trim(par_name_new)) then 232 | call read_from_string(line(i)(pos+1:),value) 233 | found = .true. 234 | exit 235 | end if 236 | 237 | end if 238 | 239 | end do 240 | 241 | if(.not.found) then 242 | print *, "Parameter not found : "//trim(par_name_new) 243 | stop 244 | end if 245 | 246 | end subroutine config_ 247 | 248 | !!@END FOR 249 | 250 | end module lib_conf 251 | -------------------------------------------------------------------------------- /templates/lib_random_template.f90: -------------------------------------------------------------------------------- 1 | ! Random number generation related routines 2 | ! 3 | ! ------------------------------------------------------------------------------ 4 | ! Copyright (c) 2009-13, Thomas P. Robitaille 5 | ! 6 | ! All rights reserved. 7 | ! 8 | ! Redistribution and use in source and binary forms, with or without 9 | ! modification, are permitted provided that the following conditions are met: 10 | ! 11 | ! * Redistributions of source code must retain the above copyright notice, this 12 | ! list of conditions and the following disclaimer. 13 | ! 14 | ! * Redistributions in binary form must reproduce the above copyright notice, 15 | ! this list of conditions and the following disclaimer in the documentation 16 | ! and/or other materials provided with the distribution. 17 | ! 18 | ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19 | ! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | ! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | ! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | ! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | ! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | ! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | ! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | ! ------------------------------------------------------------------------------ 29 | 30 | module lib_random 31 | 32 | implicit none 33 | save 34 | 35 | private 36 | 37 | integer,parameter :: sp = selected_real_kind(p=6,r=37) 38 | integer,parameter :: dp = selected_real_kind(p=15,r=307) 39 | 40 | integer :: idum = -1204132124 41 | real(dp) :: u(97) 42 | !$OMP THREADPRIVATE(idum, u) 43 | 44 | real(dp),parameter :: pi = 3.14159265358979323846_dp 45 | real(sp),parameter :: pi_sp = 3.14159265358979323846_sp 46 | real(dp),parameter :: pi_dp = 3.14159265358979323846_dp 47 | 48 | real(dp),parameter :: twopi = 2._dp * pi 49 | real(sp),parameter :: twopi_sp = pi_sp + pi_sp 50 | real(dp),parameter :: twopi_dp = pi_dp + pi_dp 51 | 52 | public :: set_seed 53 | public :: set_seed_64 54 | 55 | public :: random 56 | interface random 57 | module procedure random_sp 58 | module procedure random_dp 59 | end interface random 60 | 61 | public :: random_exp 62 | interface random_exp 63 | module procedure random_exp_sp 64 | module procedure random_exp_dp 65 | end interface random_exp 66 | 67 | public :: random_uni 68 | interface random_uni 69 | module procedure random_uni_sp 70 | module procedure random_uni_dp 71 | end interface random_uni 72 | 73 | public :: random_gau 74 | interface random_gau 75 | module procedure random_gau_sp 76 | module procedure random_gau_dp 77 | end interface random_gau 78 | 79 | public :: random_sphere 80 | interface random_sphere 81 | module procedure random_sphere_sp 82 | module procedure random_sphere_dp 83 | end interface random_sphere 84 | 85 | public :: random_poisson 86 | interface random_poisson 87 | module procedure random_poisson_sp 88 | module procedure random_poisson_dp 89 | end interface random_poisson 90 | 91 | public :: random_planck_frequency 92 | interface random_planck_frequency 93 | module procedure random_planck_frequency_sp 94 | module procedure random_planck_frequency_dp 95 | end interface random_planck_frequency 96 | 97 | contains 98 | 99 | subroutine set_seed(seed) 100 | ! Note: this should be called with a different seed in each thread or 101 | ! process. 102 | implicit none 103 | integer,intent(in) :: seed 104 | idum = -abs(seed) 105 | call set_seed_64(abs(seed), 987654321) 106 | end subroutine set_seed 107 | 108 | subroutine set_seed_64(seed1,seed2) 109 | implicit none 110 | integer,intent(in) :: seed1,seed2 111 | integer i,j,x,y 112 | real(dp) :: s,t 113 | x=seed1 114 | y=seed2 115 | do i=1,97 116 | s=0._dp 117 | t=0.5_dp 118 | do j=1,53 119 | x=mod(6969*x,65543) 120 | y=mod(8888*x,65579) 121 | if (iand(ieor(x,y),32).gt.0) s=s+t 122 | t=0.5_dp*t 123 | end do 124 | u(i)=s 125 | end do 126 | end subroutine set_seed_64 127 | 128 | subroutine random_string(string) 129 | implicit none 130 | character(len=*),intent(out) :: string 131 | integer :: i,j 132 | real(dp) :: xi 133 | do i=1,len(string) 134 | call random(xi) 135 | j = int(xi*26._dp) 136 | call random(xi) 137 | if(xi < 0.5) then 138 | j = j + 65 139 | else 140 | j = j + 97 141 | end if 142 | string(i:i) = char(j) 143 | end do 144 | end subroutine random_string 145 | 146 | subroutine random_sp(xi) 147 | ! Random number between 0 and 1 148 | ! Inspired by Numerical Recipes 149 | implicit none 150 | real(sp),intent(out) :: xi 151 | real(sp),save :: am 152 | !$OMP THREADPRIVATE(am) 153 | integer, parameter :: ia=16807,im=2147483647,iq=127773,ir=2836 154 | integer, save :: ix=-1,iy=-1,k 155 | !$OMP THREADPRIVATE(ix, iy, k) 156 | if (idum <= 0 .or. iy < 0) then 157 | am=nearest(1.0_sp,-1.0_sp)/im 158 | iy=ior(ieor(888889999,abs(idum)),1) 159 | ix=ieor(777755555,abs(idum)) 160 | idum=abs(idum)+1 161 | end if 162 | ix=ieor(ix,ishft(ix,13)) 163 | ix=ieor(ix,ishft(ix,-17)) 164 | ix=ieor(ix,ishft(ix,5)) 165 | k=iy/iq 166 | iy=ia*(iy-k*iq)-ir*k 167 | if (iy < 0) iy=iy+im 168 | xi=am*ior(iand(im,ieor(ix,iy)),1) 169 | end subroutine random_sp 170 | 171 | subroutine random_dp(xi) 172 | ! Random number between 0 and 1 173 | ! Based on "The 64-bit universal RNG", Marsaglia & Tsang (2004) 174 | implicit none 175 | real(dp),intent(out) :: xi 176 | integer,save :: i=97 177 | integer,save :: j=33 178 | real(dp),save :: c=0 179 | !$OMP THREADPRIVATE(i, j, c) 180 | real(dp) :: x 181 | real(dp), parameter :: r=9007199254740881._dp/9007199254740992._dp 182 | real(dp), parameter :: d=362436069876._dp/9007199254740992._dp 183 | x=u(i)-u(j) 184 | if (x.lt.0.0) x=x+1.0_dp 185 | u(i)=x 186 | i=i-1 187 | if (i.eq.0) i=97 188 | j=j-1 189 | if (j.eq.0) j=97 190 | c=c-d 191 | if (c.lt.0.0) c=c+r 192 | x=x-c 193 | xi=x 194 | if (x.lt.0.) xi=x+1._dp 195 | return 196 | end subroutine random_dp 197 | 198 | !!@FOR real(sp):sp real(dp):dp 199 | 200 | subroutine random_uni_(xi,a,b) 201 | ! Uniform random number between a and b 202 | implicit none 203 | real(),intent(in) :: a,b 204 | real(),intent(out) :: xi 205 | call random(xi) 206 | xi = a + (b-a) * xi 207 | end subroutine random_uni_ 208 | 209 | subroutine random_gau_(xi,c,w) 210 | ! Gaussian random number with center c and 1-sigma w 211 | implicit none 212 | real(),intent(in) :: c,w 213 | real(),intent(out) :: xi 214 | real() :: r,g1,g2,x,y,t 215 | do 216 | call random_uni(x,-1._,+1._) 217 | call random_uni(y,-1._,+1._) 218 | r = x*x + y*y 219 | if(r.lt.1) exit 220 | end do 221 | t=sqrt(-2._*log(r)/r) 222 | g1 = x*t 223 | g2 = y*t 224 | xi = g1*w+c 225 | end subroutine random_gau_ 226 | 227 | subroutine random_exp_(xi) 228 | ! Random number sampled from exp(-tau) 229 | implicit none 230 | real(),intent(out) :: xi 231 | do 232 | call random(xi) 233 | if(xi < 1._) exit 234 | end do 235 | xi = - log( 1._ - xi ) 236 | end subroutine random_exp_ 237 | 238 | 239 | subroutine random_sphere_(mu,phi) 240 | ! Random longitude/latitude on a sphere 241 | implicit none 242 | real(),intent(out) :: mu,phi 243 | call random_uni(mu,-1._,+1._) 244 | call random_uni(phi,0._,twopi_) 245 | end subroutine random_sphere_ 246 | 247 | 248 | subroutine random_poisson_(xi,xm) 249 | ! Random number drawn from Poisson distribution with 250 | ! expected value xm 251 | 252 | implicit none 253 | 254 | real(),intent(in) :: xm 255 | real(),intent(out) :: xi 256 | real() :: em,harvest,t,y 257 | 258 | real(), save :: alxm,g,oldm=-1.0_,sq 259 | !$OMP THREADPRIVATE(alxm,g,oldm,sq) 260 | 261 | if (xm < 12.0) then 262 | if (xm /= oldm) then 263 | oldm=xm 264 | g=exp(-xm) 265 | end if 266 | em=-1 267 | t=1.0 268 | do 269 | em=em+1.0_ 270 | call random_(harvest) 271 | t=t*harvest 272 | if (t <= g) exit 273 | end do 274 | else 275 | if (xm /= oldm) then 276 | oldm=xm 277 | sq=sqrt(2.0_*xm) 278 | alxm=log(xm) 279 | g=xm*alxm-gammln_(xm+1.0_) 280 | end if 281 | do 282 | do 283 | call random_(harvest) 284 | y=tan(pi*harvest) 285 | em=sq*y+xm 286 | if (em >= 0.0) exit 287 | end do 288 | em=int(em) 289 | t=0.9_*(1.0_+y**2)*exp(em*alxm-gammln_(em+1.0_)-g) 290 | call random_(harvest) 291 | if (harvest <= t) exit 292 | end do 293 | end if 294 | xi = em 295 | end subroutine random_poisson_ 296 | 297 | subroutine random_planck_frequency_(nu,T) 298 | 299 | ! Random frequency sampled from a planck function with temperature T 300 | 301 | ! The algorithm is taken from 'Sampling a random variable distributed 302 | ! according to planck's law' by Barnett and Canfield 303 | 304 | implicit none 305 | 306 | real(),intent(in) :: T 307 | real(),intent(out) :: nu 308 | real() :: x,r,r1,r2,r3,r4,a,y,z 309 | 310 | real(),parameter :: k = 1.3806503e-23_ ! J/K 311 | real(),parameter :: h = 6.626068e-34_ ! J.s 312 | 313 | ! Sample a random number from x^3/(exp(x)-1) 314 | 315 | do 316 | 317 | call random(r1) 318 | call random(r2) 319 | call random(r3) 320 | call random(r4) 321 | 322 | r = r1*r2*r3*r4 323 | 324 | if(r > 0._dp) exit 325 | 326 | end do 327 | 328 | x = - log(r) 329 | 330 | a = 1._ 331 | y = 1._ 332 | z = 1._ 333 | 334 | call random(r1) 335 | do 336 | if(1.08232_*r1 <= a) exit 337 | y = y + 1._ 338 | z = 1._/y 339 | a = a + z*z*z*z 340 | end do 341 | x = x * z 342 | 343 | ! Convert to frequency 344 | 345 | nu = x * k * T / h 346 | 347 | end subroutine random_planck_frequency_ 348 | 349 | real() function gammln_(xx) 350 | 351 | implicit none 352 | 353 | real(),intent(in) :: xx 354 | integer :: j 355 | real() :: ser,tmp,x,y 356 | 357 | real(),save :: cof(6) = (/76.18009172947146_,& 358 | &-86.50532032941677_,24.01409824083091_,& 359 | &-1.231739572450155_,.1208650973866179e-2_,& 360 | &-.5395239384953e-5_/) 361 | !$OMP THREADPRIVATE(cof) 362 | 363 | real(),save :: stp = 2.5066282746310005_ 364 | !$OMP THREADPRIVATE(stp) 365 | 366 | x=xx 367 | y=x 368 | tmp=x+5.5_ 369 | tmp=(x+0.5_)*log(tmp)-tmp 370 | ser=1.000000000190015_ 371 | 372 | do j=1,6 373 | y=y+1._ 374 | ser=ser+cof(j)/y 375 | end do 376 | 377 | gammln_=tmp+log(stp*ser/x) 378 | return 379 | 380 | end function gammln_ 381 | 382 | !!@END FOR 383 | 384 | 385 | end module lib_random 386 | -------------------------------------------------------------------------------- /templates/lib_statistics_template.f90: -------------------------------------------------------------------------------- 1 | ! Statistics 2 | ! 3 | ! ------------------------------------------------------------------------------ 4 | ! Copyright (c) 2009-13, Thomas P. Robitaille 5 | ! 6 | ! All rights reserved. 7 | ! 8 | ! Redistribution and use in source and binary forms, with or without 9 | ! modification, are permitted provided that the following conditions are met: 10 | ! 11 | ! * Redistributions of source code must retain the above copyright notice, this 12 | ! list of conditions and the following disclaimer. 13 | ! 14 | ! * Redistributions in binary form must reproduce the above copyright notice, 15 | ! this list of conditions and the following disclaimer in the documentation 16 | ! and/or other materials provided with the distribution. 17 | ! 18 | ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19 | ! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | ! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | ! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | ! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | ! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | ! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | ! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | ! ------------------------------------------------------------------------------ 29 | 30 | module lib_statistics 31 | 32 | use lib_array 33 | implicit none 34 | save 35 | 36 | private 37 | 38 | integer,parameter :: idp = selected_int_kind(13) 39 | integer,parameter :: sp = selected_real_kind(p=6,r=37) 40 | integer,parameter :: dp = selected_real_kind(p=15,r=307) 41 | 42 | public :: mean 43 | interface mean 44 | module procedure mean_sp 45 | module procedure mean_dp 46 | end interface mean 47 | 48 | public :: median 49 | interface median 50 | module procedure median_sp 51 | module procedure median_dp 52 | end interface median 53 | 54 | public :: quantile 55 | interface quantile 56 | module procedure quantile_sp 57 | module procedure quantile_dp 58 | end interface quantile 59 | 60 | public :: variance 61 | interface variance 62 | module procedure variance_sp 63 | module procedure variance_dp 64 | end interface variance 65 | 66 | public :: clipped_mean 67 | interface clipped_mean 68 | module procedure clipped_mean_sp 69 | module procedure clipped_mean_dp 70 | end interface clipped_mean 71 | 72 | contains 73 | 74 | !!@FOR real(sp):sp real(dp):dp 75 | 76 | @T function mean_(x, mask) 77 | implicit none 78 | @T,intent(in) :: x(:) 79 | logical,intent(in),optional :: mask(:) 80 | if(present(mask)) then 81 | mean_ = sum(x, mask=mask)/size(x) 82 | else 83 | mean_ = sum(x)/size(x) 84 | end if 85 | end function mean_ 86 | 87 | @T function median_(x) 88 | implicit none 89 | @T,intent(in) :: x(:) 90 | @T,dimension(size(x)) :: x_sorted 91 | integer :: n 92 | n = size(x) 93 | x_sorted = x 94 | call quicksort(x_sorted) 95 | if(mod(n,2).eq.0) then 96 | median_=(x_sorted(n/2)+x_sorted(n/2+1))/2. 97 | else 98 | median_=x_sorted((n-1)/2+1) 99 | end if 100 | end function median_ 101 | 102 | @T function quantile_(x, percent, mask) 103 | implicit none 104 | @T,intent(in) :: x(:), percent 105 | logical,intent(in),optional :: mask(:) 106 | @T,allocatable :: x_sorted(:) 107 | integer :: n, ipos 108 | if(present(mask)) then 109 | n = count(mask) 110 | allocate(x_sorted(n)) 111 | x_sorted = pack(x, mask) 112 | else 113 | n = size(x) 114 | allocate(x_sorted(n)) 115 | x_sorted = x 116 | end if 117 | call quicksort(x_sorted) 118 | if(percent >= 100._) then 119 | ipos = n 120 | else if(percent <= 0._) then 121 | ipos = 1 122 | else 123 | ipos=nint(percent/100._*real(n-1, ))+1 124 | end if 125 | quantile_=x_sorted(ipos) 126 | end function quantile_ 127 | 128 | @T function variance_(x, mask) 129 | implicit none 130 | @T,intent(in) :: x(:) 131 | logical,intent(in),optional :: mask(:) 132 | variance_ = sum(x-mean(x, mask=mask)**2._)/(size(x)-1) 133 | end function variance_ 134 | 135 | @T function clipped_mean_(x, n) 136 | implicit none 137 | @T,intent(in) :: x(:) 138 | integer,intent(in) :: n 139 | logical,dimension(size(x)) :: keep 140 | @T :: sigma 141 | integer :: n_before 142 | keep = .true. 143 | n_before = 0 144 | do 145 | clipped_mean_ = mean(x, mask=keep) 146 | sigma = sqrt(variance(x, mask=keep)) 147 | keep = keep .and. abs(x-clipped_mean_) < real(n, ) * sigma 148 | if(count(keep)==n_before) exit 149 | n_before = count(keep) 150 | end do 151 | end function clipped_mean_ 152 | 153 | !!@END FOR 154 | 155 | end module lib_statistics 156 | -------------------------------------------------------------------------------- /templates/type_angle3d_template.f90: -------------------------------------------------------------------------------- 1 | ! 3D angle related routines 2 | ! 3 | ! ------------------------------------------------------------------------------ 4 | ! Copyright (c) 2009-13, Thomas P. Robitaille 5 | ! 6 | ! All rights reserved. 7 | ! 8 | ! Redistribution and use in source and binary forms, with or without 9 | ! modification, are permitted provided that the following conditions are met: 10 | ! 11 | ! * Redistributions of source code must retain the above copyright notice, this 12 | ! list of conditions and the following disclaimer. 13 | ! 14 | ! * Redistributions in binary form must reproduce the above copyright notice, 15 | ! this list of conditions and the following disclaimer in the documentation 16 | ! and/or other materials provided with the distribution. 17 | ! 18 | ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19 | ! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | ! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | ! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | ! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | ! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | ! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | ! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | ! ------------------------------------------------------------------------------ 29 | 30 | module type_angle3d 31 | 32 | implicit none 33 | save 34 | 35 | private 36 | 37 | integer,parameter :: sp = selected_real_kind(p=6,r=37) 38 | integer,parameter :: dp = selected_real_kind(p=15,r=307) 39 | 40 | real(dp),parameter :: pi = 3.14159265358979323846_dp 41 | real(dp),parameter :: deg2rad = pi / 180._dp 42 | real(dp),parameter :: rad2deg = 180._dp / pi 43 | 44 | public :: angle3d_sp 45 | type angle3d_sp 46 | real(sp) :: cost,sint,cosp,sinp 47 | end type angle3d_sp 48 | 49 | public :: angle3d_dp 50 | type angle3d_dp 51 | real(dp) :: cost,sint,cosp,sinp 52 | end type angle3d_dp 53 | 54 | public :: operator(.eq.) 55 | interface operator(.eq.) 56 | module procedure equal_sp 57 | module procedure equal_dp 58 | end interface operator(.eq.) 59 | 60 | public :: angle3d_deg 61 | interface angle3d_deg 62 | module procedure angle3d_deg_sp 63 | module procedure angle3d_deg_dp 64 | end interface angle3d_deg 65 | 66 | public :: display_angle 67 | interface display_angle 68 | module procedure display_angle_sp 69 | module procedure display_angle_dp 70 | end interface display_angle 71 | 72 | public :: operator(.dot.) 73 | interface operator(.dot.) 74 | module procedure dot_product_sp 75 | module procedure dot_product_dp 76 | end interface operator(.dot.) 77 | 78 | public :: rotate_angle3d 79 | interface rotate_angle3d 80 | module procedure rotate_angle3d_sp 81 | module procedure rotate_angle3d_dp 82 | end interface rotate_angle3d 83 | 84 | public :: difference_angle3d 85 | interface difference_angle3d 86 | module procedure difference_angle3d_sp 87 | module procedure difference_angle3d_dp 88 | end interface difference_angle3d 89 | 90 | public :: random_sphere_angle3d 91 | interface random_sphere_angle3d 92 | module procedure random_sphere_angle3d_sp 93 | module procedure random_sphere_angle3d_dp 94 | end interface random_sphere_angle3d 95 | 96 | public :: operator(-) 97 | interface operator(-) 98 | module procedure minus_angle_sp 99 | module procedure minus_angle_dp 100 | end interface operator(-) 101 | 102 | interface sin2cos 103 | module procedure sin2cos_sp 104 | module procedure sin2cos_dp 105 | end interface sin2cos 106 | 107 | interface cos2sin 108 | module procedure sin2cos_sp 109 | module procedure sin2cos_dp 110 | end interface cos2sin 111 | 112 | contains 113 | 114 | 115 | !!@FOR real(sp):sp real():dp 116 | 117 | logical function equal_(a, b) result(e) 118 | 119 | implicit none 120 | 121 | type(angle3d_),intent(in) :: a, b 122 | 123 | e = a%cost == b%cost .and. a%sint == b%sint .and. a%cosp == b%cosp .and. a%sinp == b%sinp 124 | 125 | end function equal_ 126 | 127 | type(angle3d_) function angle3d_deg_(theta,phi) result(a) 128 | 129 | implicit none 130 | 131 | real(),intent(in) :: theta,phi 132 | 133 | a%cost = cos(theta*deg2rad) 134 | a%sint = sin(theta*deg2rad) 135 | a%cosp = cos(phi*deg2rad) 136 | a%sinp = sin(phi*deg2rad) 137 | 138 | end function angle3d_deg_ 139 | 140 | 141 | subroutine display_angle_(a) 142 | implicit none 143 | type(angle3d_),intent(in) :: a 144 | print '("Theta = ",F8.4," degrees")',atan2(a%sint,a%cost)*rad2deg 145 | print '("Phi = ",F8.4," degrees")',atan2(a%sinp,a%cosp)*rad2deg 146 | end subroutine display_angle_ 147 | 148 | 149 | real() function dot_product_(a, b) result(p) 150 | 151 | implicit none 152 | 153 | type(angle3d_),intent(in) :: a, b 154 | 155 | p = a%sint*a%cosp*b%sint*b%cosp + a%sint*a%sinp*b%sint*b%sinp + a%cost * b%cost 156 | 157 | end function dot_product_ 158 | 159 | 160 | subroutine rotate_angle3d_(a_local,a_coord,a_final) 161 | 162 | ! This subroutine is used to add a local angle, such as as 163 | ! photon emission angle on the surface of a star, or a photon 164 | ! scattering angle, to an already existing position angle. 165 | ! The former is given by a_local, the latter, by a_coord, and 166 | ! the final angle by a_angle. We solve this using spherical 167 | ! trigonometry. Consider a spherical triangle with corner angles 168 | ! (A,B,C) and side angles (a,b,c). The angle B is attached to the 169 | ! z axis, and the sides a and c are on the great circles passing 170 | ! through the z-axis. The meaning of the angles is as follows: 171 | 172 | ! a = old theta angle (initial direction angle) 173 | ! b = local theta angle (scattering or emission angle) 174 | ! c = new theta angle (final direction angle) 175 | 176 | ! A = no meaning (but useful for scattering) 177 | ! B = new phi - old phi 178 | ! C = local phi angle (scattering or emission angle) 179 | 180 | implicit none 181 | 182 | type(angle3d_),intent(in) :: a_local 183 | type(angle3d_),intent(in) :: a_coord 184 | type(angle3d_),intent(out) :: a_final 185 | 186 | real() :: cos_a,sin_a 187 | real() :: cos_b,sin_b 188 | real() :: cos_c,sin_c 189 | 190 | real() :: cos_big_b,sin_big_b 191 | real() :: cos_big_c,sin_big_c 192 | 193 | real() :: delta 194 | logical :: same_sign 195 | 196 | ! Special case - if coord%theta is 0, then final = local 197 | if(abs(a_coord%sint) < 1.e-10_) then 198 | if(a_coord%cost > 0._) then 199 | a_final = a_local 200 | a_final%cosp = + a_local%cosp * a_coord%cosp + a_local%sinp * a_coord%sinp 201 | a_final%sinp = + a_local%cosp * a_coord%sinp - a_local%sinp * a_coord%cosp 202 | else 203 | a_final = a_local 204 | a_final%cost = - a_local%cost 205 | a_final%cosp = + a_local%cosp * a_coord%cosp - a_local%sinp * a_coord%sinp 206 | a_final%sinp = + a_local%cosp * a_coord%sinp + a_local%sinp * a_coord%cosp 207 | end if 208 | return 209 | end if 210 | 211 | ! --- Assign spherical triangle angles values --- ! 212 | 213 | ! The angles in the spherical triangle are as follows: 214 | 215 | cos_a = a_coord%cost 216 | sin_a = a_coord%sint 217 | 218 | cos_b = a_local%cost 219 | sin_b = a_local%sint 220 | 221 | if(a_local%sinp < 0._) then ! the angle in the triangle is then actually 2*pi - local phi 222 | cos_big_C = + a_local%cosp 223 | sin_big_C = - a_local%sinp 224 | else ! the angle is local phi 225 | cos_big_C = + a_local%cosp 226 | sin_big_C = + a_local%sinp 227 | end if 228 | 229 | ! --- Solve the spherical triangle --- ! 230 | 231 | if (abs(sin_a) > abs(cos_a)) then 232 | same_sign = sin_a > 0._ .eqv. sin_b > 0._ 233 | delta = cos_b - cos_a 234 | else 235 | same_sign = cos_a > 0._ .eqv. cos_b > 0._ 236 | delta = sin_b - sin_a 237 | end if 238 | 239 | if(same_sign .and. abs(delta) < 1.e-5_ .and. sin_big_C < 1.e-5_ .and. cos_big_c > 0._) then 240 | if (abs(sin_a) > abs(cos_a)) then 241 | sin_c = sqrt(delta * delta * (1._ + (cos_a/sin_a)**2) + sin_a * sin_b * sin_big_C * sin_big_C) 242 | else 243 | sin_c = sqrt(delta * delta * (1._ + (sin_a/cos_a)**2) + sin_a * sin_b * sin_big_C * sin_big_C) 244 | end if 245 | cos_c = sin2cos(sin_c) 246 | else 247 | cos_c = cos_a * cos_b + sin_a * sin_b * cos_big_c 248 | sin_c = cos2sin(cos_c) 249 | end if 250 | 251 | ! Special case - if local and coord theta are the same and C = 0, return 252 | ! vertical vector. We can't do better than that because we are limited by 253 | ! numerical precision, in particular for delta (above) which will be limited 254 | ! in precision 255 | if(abs(sin_c) < 1.e-10_) then 256 | write(*,'(" WARNING: final angle is vertical, and phi is undetermined (set to 0) [rotate_angle3d]")') 257 | if(cos_c > 0._) then 258 | a_final = angle3d_deg(0._,0._) 259 | else 260 | a_final = angle3d_deg(180._,0._) 261 | end if 262 | return 263 | end if 264 | 265 | cos_big_b = ( cos_b - cos_a * cos_c ) / ( sin_a * sin_c ) 266 | sin_big_b = + sin_big_c * sin_b / sin_c 267 | 268 | ! --- Find final theta and phi values --- ! 269 | 270 | a_final%cost = cos_c 271 | a_final%sint = sin_c 272 | 273 | if(a_local%sinp < 0._) then ! the top angle is old phi - new phi 274 | a_final%cosp = + cos_big_b * a_coord%cosp + sin_big_b * a_coord%sinp 275 | a_final%sinp = + cos_big_b * a_coord%sinp - sin_big_b * a_coord%cosp 276 | else ! the top angle is new phi - old phi 277 | a_final%cosp = + cos_big_b * a_coord%cosp - sin_big_b * a_coord%sinp 278 | a_final%sinp = + cos_big_b * a_coord%sinp + sin_big_b * a_coord%cosp 279 | end if 280 | 281 | end subroutine rotate_angle3d_ 282 | 283 | subroutine difference_angle3d_(a_coord,a_final,a_local) 284 | 285 | ! This subroutine is used to find the local angle by which 286 | ! a coordinate angle would have to be rotated to give the 287 | ! final angle specified. This is complementary to the rotate_ 288 | ! angle3d routine. 289 | 290 | ! We solve this using spherical 291 | ! trigonometry. Consider a spherical triangle with corner angles 292 | ! (A,B,C) and side angles (a,b,c). The angle B is attached to the 293 | ! z axis, and the sides a and c are on the great circles passing 294 | ! through the z-axis. The meaning of the angles is as follows: 295 | 296 | ! a = old theta angle (initial direction angle) 297 | ! b = local theta angle (scattering or emission angle) 298 | ! c = new theta angle (final direction angle) 299 | 300 | ! A = no meaning (but useful for scattering) 301 | ! B = new phi - old phi 302 | ! C = local phi angle (scattering or emission angle) 303 | 304 | implicit none 305 | 306 | type(angle3d_),intent(out) :: a_local 307 | type(angle3d_),intent(in) :: a_coord 308 | type(angle3d_),intent(in) :: a_final 309 | 310 | real() :: cos_a,sin_a 311 | real() :: cos_b,sin_b 312 | real() :: cos_c,sin_c 313 | 314 | real() :: cos_big_b,sin_big_b 315 | real() :: cos_big_c,sin_big_c 316 | 317 | real(dp) :: delta,diff 318 | logical :: same_sign 319 | 320 | ! Special case - if coord%theta is 0, then final = local 321 | if(abs(a_coord%sint) < 1.e-10_) then 322 | if(a_coord%cost > 0._) then 323 | a_local = a_final 324 | a_local%cosp = + a_coord%cosp * a_final%cosp + a_coord%sinp * a_final%sinp 325 | a_local%sinp = - a_coord%cosp * a_final%sinp + a_coord%sinp * a_final%cosp 326 | else 327 | a_local = a_final 328 | a_local%cost = - a_local%cost 329 | a_local%cosp = + a_coord%cosp * a_final%cosp + a_coord%sinp * a_final%sinp 330 | a_local%sinp = + a_coord%cosp * a_final%sinp - a_coord%sinp * a_final%cosp 331 | end if 332 | return 333 | end if 334 | 335 | ! --- Assign spherical triangle angles values --- ! 336 | 337 | ! The angles in the spherical triangle are as follows: 338 | 339 | cos_a = a_coord%cost 340 | sin_a = a_coord%sint 341 | 342 | cos_c = a_final%cost 343 | sin_c = a_final%sint 344 | 345 | cos_big_B = a_coord%cosp * a_final%cosp + a_coord%sinp * a_final%sinp 346 | sin_big_B = a_coord%sinp * a_final%cosp - a_coord%cosp * a_final%sinp 347 | 348 | ! --- Solve the spherical triangle --- ! 349 | 350 | cos_b = cos_a * cos_c + sin_a * sin_c * cos_big_B 351 | sin_b = cos2sin(cos_b) 352 | 353 | ! If cos_b is -1, then the angles are opposite and phi is undefined 354 | if(abs(cos_b + 1._) < 1.e-10_) then 355 | a_local = angle3d_deg(180._,0._) 356 | return 357 | end if 358 | 359 | ! If cos_b is +1, then the angles are the same and phi is undefined 360 | if(abs(cos_b - 1._) < 1.e-10_) then 361 | a_local = angle3d_deg(0._,0._) 362 | return 363 | end if 364 | 365 | same_sign = cos_a > 0._ .eqv. cos_b > 0._ .and. sin_a > 0._ .eqv. sin_b > 0._ 366 | if(abs(sin_a) > abs(cos_a)) then 367 | delta = cos_b - cos_a 368 | else 369 | delta = sin_b - sin_a 370 | end if 371 | 372 | if(same_sign .and. abs(delta) < 1.e-5_ .and. sin_c < 1.e-5_) then 373 | 374 | if (abs(sin_a) > abs(cos_a)) then 375 | diff = (sin_c * sin_c - delta * delta * (1._ + (cos_a / sin_a)**2)) / (sin_a * sin_b) 376 | else 377 | diff = (sin_c * sin_c - delta * delta * (1._ + (sin_a / cos_a)**2)) / (sin_a * sin_b) 378 | end if 379 | 380 | if(diff >= 0._) then 381 | sin_big_c = sqrt(diff) 382 | else 383 | sin_big_c = 0._ 384 | end if 385 | 386 | if(cos_c > 0._) then 387 | cos_big_c = sin2cos(sin_big_c) 388 | else 389 | cos_big_c = - sin2cos(sin_big_c) 390 | end if 391 | 392 | else 393 | sin_big_c = + abs(sin_big_b) * sin_c / sin_b 394 | cos_big_c = ( cos_c - cos_a * cos_b ) / ( sin_a * sin_b ) 395 | end if 396 | 397 | ! If sin_big_c is zero, this can cause issues in other routines, so we 398 | ! make it the next floating point, which should have no effect on 399 | ! calculations but prevents issues. 400 | if(sin_big_c == 0._) sin_big_c = tiny(1._) 401 | 402 | ! --- Find final theta and phi values --- ! 403 | 404 | a_local%cost = cos_b 405 | a_local%sint = sin_b 406 | 407 | if(sin_big_b < 0._) then 408 | 409 | a_local%cosp = cos_big_C 410 | a_local%sinp = sin_big_C 411 | 412 | else 413 | 414 | a_local%cosp = cos_big_C 415 | a_local%sinp = - sin_big_C 416 | 417 | end if 418 | 419 | end subroutine difference_angle3d_ 420 | 421 | @T function sin2cos_(x) result(y) 422 | implicit none 423 | @T, intent(in) :: x 424 | if(x * x < 1._) then 425 | y = sqrt(1._ - x * x) 426 | else 427 | y = 0._ 428 | end if 429 | end function sin2cos_ 430 | 431 | subroutine random_sphere_angle3d_(a) 432 | ! Random position on a unit sphere 433 | use lib_random 434 | implicit none 435 | type(angle3d_),intent(out) :: a 436 | real() :: phi 437 | call random_sphere(a%cost,phi) 438 | a%sint = sqrt(1._ - a%cost * a%cost) 439 | a%cosp = cos(phi) 440 | a%sinp = sin(phi) 441 | end subroutine random_sphere_angle3d_ 442 | 443 | type(angle3d_) function minus_angle_(a) result(b) 444 | implicit none 445 | type(angle3d_),intent(in) :: a 446 | b = angle3d_(-a%cost, a%sint, -a%cosp, -a%sinp) 447 | end function minus_angle_ 448 | 449 | !!@END FOR 450 | 451 | end module type_angle3d 452 | -------------------------------------------------------------------------------- /templates/type_pdf2d_template.f90: -------------------------------------------------------------------------------- 1 | ! ------------------------------------------------------------------------------ 2 | ! Copyright (c) 2009-13, Thomas P. Robitaille 3 | ! 4 | ! All rights reserved. 5 | ! 6 | ! Redistribution and use in source and binary forms, with or without 7 | ! modification, are permitted provided that the following conditions are met: 8 | ! 9 | ! * Redistributions of source code must retain the above copyright notice, this 10 | ! list of conditions and the following disclaimer. 11 | ! 12 | ! * Redistributions in binary form must reproduce the above copyright notice, 13 | ! this list of conditions and the following disclaimer in the documentation 14 | ! and/or other materials provided with the distribution. 15 | ! 16 | ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 17 | ! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 18 | ! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | ! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 20 | ! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 22 | ! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 23 | ! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 24 | ! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 25 | ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | ! ------------------------------------------------------------------------------ 27 | 28 | module type_pdf2d 29 | 30 | use lib_array, only : locate, interp2d 31 | use lib_random, only : random 32 | 33 | implicit none 34 | 35 | private 36 | 37 | integer,parameter :: sp = selected_real_kind(p=6,r=37) 38 | integer,parameter :: dp = selected_real_kind(p=15,r=307) 39 | 40 | ! We define a 2-d PDF by a set of nx x ny probabilities defined at nodes given by x(1...nx) and y(1...ny). We start by defining a binned PDF that has dimensions nx-1 x ny-1 and defines the probability in the rectangles defined by the nodes. The value of the probability in each bin is simply the average of the four probability points defining the rectangle. Once we have this, we compute the CDF along the x-direction (this also has shape nx-1 x ny-1). We then use the total probabilities in the x-direction to define a PDF in the y direction with ny-1 elements (pdfy). We construct the corresponding CDF (cdfy) and sample a y bin from this. We then sample the x bin from the 2-d CDF along the slice defined by the y bin. Finally, we sample from the function: 41 | ! 42 | ! z = b1 + b2 * x + b3 * y + b4 * x * y 43 | ! 44 | ! which is defined by the bilinear interpolation of the four points. 45 | ! 46 | ! TODO: support for log sampling? 47 | 48 | !!@FOR real(sp):sp real(dp):dp 49 | 50 | public :: pdf2d_ 51 | type pdf2d_ 52 | integer :: nx, ny 53 | @T,allocatable :: x(:), y(:) 54 | @T,allocatable :: prob(:,:) 55 | @T,allocatable :: pdf(:,:) 56 | @T,allocatable :: cdf(:,:) 57 | @T,allocatable :: cdfy(:) 58 | @T,allocatable :: pdfy(:) 59 | logical :: normalized = .false. 60 | end type pdf2d_ 61 | 62 | !!@END FOR 63 | 64 | public :: set_pdf2d 65 | interface set_pdf2d 66 | module procedure set_pdf2d_sp 67 | module procedure set_pdf2d_dp 68 | end interface set_pdf2d 69 | 70 | public :: sample_pdf2d 71 | interface sample_pdf2d 72 | module procedure sample_pdf2d_sp 73 | module procedure sample_pdf2d_dp 74 | end interface sample_pdf2d 75 | 76 | public :: interpolate_pdf2d 77 | interface interpolate_pdf2d 78 | module procedure interpolate_pdf2d_sp 79 | module procedure interpolate_pdf2d_dp 80 | end interface interpolate_pdf2d 81 | 82 | contains 83 | 84 | !!@FOR real(sp):sp real(dp):dp 85 | 86 | type(pdf2d_) function set_pdf2d_(x, y, prob) result(p) 87 | 88 | ! Initialize a 2-d PDF object 89 | ! 90 | ! Parameters 91 | ! ---------- 92 | ! x : 1-d array (size nx) 93 | ! The x values at which the probabilites are defined 94 | ! y : 1-d array (size ny) 95 | ! The y values at which the probabilites are defined 96 | ! prob : 2-d array (size nx x ny) 97 | ! The probabilities defined at (x,y) 98 | ! 99 | ! Returns 100 | ! ------- 101 | ! p : pdf2d_ 102 | ! The 2-d PDF object 103 | 104 | implicit none 105 | 106 | @T,intent(in) :: x(:), y(:), prob(:,:) 107 | @T,allocatable :: area(:,:) 108 | 109 | @T :: norm 110 | 111 | integer :: i, j 112 | 113 | p%nx = size(x) 114 | p%ny = size(y) 115 | 116 | allocate(p%x(p%nx)) 117 | allocate(p%y(p%ny)) 118 | 119 | p%x = x 120 | p%y = y 121 | 122 | if(size(prob,1) /= size(x)) stop "incorrect dimensions for prob" 123 | if(size(prob,2) /= size(y)) stop "incorrect dimensions for prob" 124 | 125 | allocate(p%prob(p%nx, p%ny)) 126 | 127 | p%prob = prob 128 | 129 | ! Compute area of each rectangle 130 | allocate(area(p%nx-1, p%ny-1)) 131 | do i=1,p%nx - 1 132 | do j=1,p%ny - 1 133 | area(i, j) = (x(i+1) - x(i)) * (y(j+1) - y(j)) 134 | end do 135 | end do 136 | 137 | ! Compute binned PDF as average of four neighboring points times area of rectangle 138 | 139 | allocate(p%pdf(p%nx-1,p%ny-1)) 140 | 141 | p%pdf = (prob(1:p%nx-1,1:p%ny-1) & 142 | & + prob(1:p%nx-1,2:p%ny) & 143 | & + prob(2:p%nx,1:p%ny-1) & 144 | & + prob(2:p%nx,2:p%ny)) & 145 | & * area * 0.25_dp 146 | 147 | ! Find total probability 148 | norm = sum(p%pdf) 149 | 150 | ! Normalize unbinned probability 151 | p%prob = p%prob / norm 152 | 153 | ! Normalize PDF 154 | p%pdf = p%pdf / norm 155 | p%normalized = .true. 156 | 157 | ! Compute 2-d CDF along x direction 158 | 159 | allocate(p%cdf(p%nx-1,p%ny-1)) 160 | 161 | p%cdf(1,:) = p%pdf(1,:) 162 | do i=2,p%nx - 1 163 | p%cdf(i,:) = p%cdf(i-1,:) + p%pdf(i,:) 164 | end do 165 | 166 | ! Find PDF and CDF in y direction 167 | allocate(p%pdfy(p%ny-1)) 168 | allocate(p%cdfy(p%ny-1)) 169 | p%pdfy = p%cdf(p%nx-1,:) 170 | p%cdfy(1) = p%pdfy(1) 171 | do j=2,p%ny - 1 172 | p%cdfy(j) = p%cdfy(j-1) + p%pdfy(j) 173 | end do 174 | p%cdfy = p%cdfy / p%cdfy(p%ny-1) 175 | 176 | ! Normalize 2-d CDF (has to be done after calculating the y-axis PDF/CDF) 177 | do i=1,p%nx - 1 178 | p%cdf(i,:) = p%cdf(i,:) / p%cdf(p%nx-1,:) 179 | end do 180 | 181 | end function set_pdf2d_ 182 | 183 | subroutine sample_pdf2d_(p, x, y, xi_alt) 184 | 185 | ! Sample a 2-d PDF 186 | ! 187 | ! Parameters 188 | ! ---------- 189 | ! p : pdf2d_ 190 | ! The 2-d PDF object to sample from 191 | ! xi_alt : @T array with 4 elements, optional 192 | ! Random numbers to use for the sampling 193 | ! 194 | ! Returns 195 | ! ------- 196 | ! x, y : @T 197 | ! The x- and y-position sampled 198 | 199 | implicit none 200 | 201 | type(pdf2d_), intent(in) :: p 202 | @T,intent(out) :: x, y 203 | @T,intent(in),optional :: xi_alt(4) 204 | @T :: xi(4) 205 | integer :: xbin, ybin 206 | @T :: b1, b2, b3, b4 207 | @T :: a, b, c, delta 208 | integer :: i 209 | 210 | ! Sample random numbers if not specified 211 | 212 | if(present(xi_alt)) then 213 | xi = xi_alt 214 | else 215 | do i=1,4 216 | call random(xi(i)) 217 | end do 218 | end if 219 | 220 | ! Find y bin 221 | if(xi(1) < p%cdfy(1)) then 222 | ybin = 1 223 | else 224 | ybin = locate(p%cdfy, xi(1)) + 1 225 | end if 226 | 227 | ! Find x bin 228 | if(xi(2) < p%cdf(1, ybin)) then 229 | xbin = 1 230 | else 231 | xbin = locate(p%cdf(:,ybin), xi(2)) + 1 232 | end if 233 | 234 | ! Now sample the position within the rectangle. We first find the normalized position in the range [0:1,0:1]. We do this by sampling from a function given by the plane: 235 | ! 236 | ! z = b1 + b2 * x + b3 * y + b4 * x * y 237 | ! 238 | ! which is the bilinear interpolation of the points. The coefficients are given by: 239 | 240 | b1 = p%prob(xbin, ybin) 241 | b2 = p%prob(xbin + 1, ybin) - b1 242 | b3 = p%prob(xbin, ybin + 1) - b1 243 | b4 = p%prob(xbin + 1, ybin + 1) - b2 - b3 - b1 244 | ! 245 | ! print *,'-----' 246 | ! print *,p%prob(xbin, ybin) 247 | ! print *,p%prob(xbin+1, ybin) 248 | ! print *,p%prob(xbin, ybin+1) 249 | ! print *,p%prob(xbin+1, ybin+1) 250 | ! print *,b1,b2,b3,b4 251 | 252 | ! We now construct the cumulative PDF in the y direction, and sample from that. The solution is a second-order polynomial with coefficients: 253 | 254 | a = 0.5_ * (b3 + 0.5_ * b4) 255 | b = (b1 + 0.5_ * b2) 256 | c = - xi(3) * (a + b) 257 | delta = sqrt(b * b - 4._ * a * c) 258 | 259 | ! We have to choose the solution in the range [0:1] 260 | 261 | if (a < 0) then 262 | if (b > delta) then 263 | y = (-b + delta) / a * 0.5 264 | else 265 | y = (-b - delta) / a * 0.5 266 | end if 267 | else if (a > 0) then 268 | if (-b < delta) then 269 | y = (-b + delta) / a * 0.5 270 | else 271 | y = (-b - delta) / a * 0.5 272 | end if 273 | else ! a == 0 so not a quadratic 274 | y = - c / b 275 | end if 276 | 277 | ! print *,a,b,c,y 278 | 279 | ! Now that we have y, we can sample x, and the solution is also a polynomial with coefficients 280 | 281 | a = 0.5_ * (b2 + b4 * y) 282 | b = b1 + b3 * y 283 | c = - xi(4) * (a + b) 284 | delta = sqrt(b * b - 4._ * a * c) 285 | 286 | ! We have to choose the solution in the range [0:1] 287 | 288 | if (a < 0) then 289 | if (b > delta) then 290 | x = (-b + delta) / a * 0.5 291 | else 292 | x = (-b - delta) / a * 0.5 293 | end if 294 | else if (a > 0) then 295 | if (-b < delta) then 296 | x = (-b + delta) / a * 0.5 297 | else 298 | x = (-b - delta) / a * 0.5 299 | end if 300 | else ! a == 0 so not a quadratic 301 | x = - c / b 302 | end if 303 | 304 | ! x and y are in relative units - now scale to correct positions 305 | x = x * (p%x(xbin+1) - p%x(xbin)) + p%x(xbin) 306 | y = y * (p%y(ybin+1) - p%y(ybin)) + p%y(ybin) 307 | 308 | end subroutine sample_pdf2d_ 309 | 310 | @T function interpolate_pdf2d_(p, x, y, bounds_error, fill_value) result(prob) 311 | 312 | ! Interpolate a 2-d PDF 313 | ! 314 | ! Parameters 315 | ! ---------- 316 | ! p : pdf2d_ 317 | ! The PDF to interpolate 318 | ! x, y : @T 319 | ! Position at which to interpolate the 2-d PDF 320 | ! bounds_error : logical, optional 321 | ! Whether to raise an error if the interpolation is out of bounds 322 | ! fill_value : @T 323 | ! The value to use for out-of-bounds interpolation if bounds_error = .false. 324 | ! 325 | ! Returns 326 | ! ------- 327 | ! prob : @T 328 | ! The probability at the position requested 329 | 330 | implicit none 331 | type(pdf2d_),intent(in) :: p 332 | @T,intent(in) :: x, y 333 | logical,intent(in),optional :: bounds_error 334 | real(),intent(in),optional :: fill_value 335 | if(.not.p%normalized) stop "[interpolate_pdf] PDF is not normalized" 336 | prob = interp2d(p%x, p%y, p%prob, x, y, bounds_error, fill_value) 337 | end function interpolate_pdf2d_ 338 | 339 | !!@END FOR 340 | 341 | end module type_pdf2d 342 | -------------------------------------------------------------------------------- /templates/type_pdf_template.f90: -------------------------------------------------------------------------------- 1 | ! Probability Distribution Function (PDF) related routines 2 | ! 3 | ! ------------------------------------------------------------------------------ 4 | ! Copyright (c) 2009-13, Thomas P. Robitaille 5 | ! 6 | ! All rights reserved. 7 | ! 8 | ! Redistribution and use in source and binary forms, with or without 9 | ! modification, are permitted provided that the following conditions are met: 10 | ! 11 | ! * Redistributions of source code must retain the above copyright notice, this 12 | ! list of conditions and the following disclaimer. 13 | ! 14 | ! * Redistributions in binary form must reproduce the above copyright notice, 15 | ! this list of conditions and the following disclaimer in the documentation 16 | ! and/or other materials provided with the distribution. 17 | ! 18 | ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19 | ! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | ! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | ! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | ! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | ! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | ! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | ! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | ! ------------------------------------------------------------------------------ 29 | 30 | module type_pdf 31 | 32 | use lib_array 33 | use lib_random 34 | 35 | implicit none 36 | 37 | private 38 | 39 | integer,parameter :: sp = selected_real_kind(p=6,r=37) 40 | integer,parameter :: dp = selected_real_kind(p=15,r=307) 41 | 42 | real,parameter :: unset = -1.e30 43 | 44 | !!@FOR real(sp):sp real(dp):dp 45 | 46 | public :: pdf_ 47 | type pdf_ 48 | integer :: n = 0 49 | @T,allocatable :: x(:) 50 | @T,allocatable :: pdf(:) 51 | @T,allocatable :: cdf(:) 52 | logical :: log = .false. 53 | logical :: normalized = .false. 54 | 55 | ! Simple mode means that the interpolation in the CDF is done in an 56 | ! approximate way, and does not take into account that computing a CDF from 57 | ! a linear function gives a non-linear CDF. The correct calculation is done 58 | ! by default, and actually ends up being faster because there are fewer calls 59 | ! to functions. The 'correct' way required 3 or 4 additional arrays to be 60 | ! pre-computed to make it faster, so it is more RAM intensive. 61 | logical :: simple = .false. 62 | @T,allocatable :: a(:),b(:),r(:),rx(:),rc(:) 63 | 64 | end type pdf_ 65 | 66 | public :: pdf_discrete_ 67 | type pdf_discrete_ 68 | integer :: n = 0 69 | @T,allocatable :: pdf(:) 70 | @T,allocatable :: cdf(:) 71 | logical :: normalized = .false. 72 | end type pdf_discrete_ 73 | 74 | !!@END FOR 75 | 76 | public :: allocate_pdf 77 | interface allocate_pdf 78 | module procedure allocate_pdf_discrete_sp 79 | module procedure allocate_pdf_discrete_dp 80 | module procedure allocate_pdf_cont_sp 81 | module procedure allocate_pdf_cont_dp 82 | end interface allocate_pdf 83 | 84 | public :: set_pdf 85 | interface set_pdf 86 | module procedure set_pdf_discrete_sp 87 | module procedure set_pdf_discrete_dp 88 | module procedure set_pdf_cont_sp 89 | module procedure set_pdf_cont_dp 90 | end interface set_pdf 91 | 92 | public :: normalize_pdf 93 | interface normalize_pdf 94 | module procedure normalize_pdf_discrete_sp 95 | module procedure normalize_pdf_discrete_dp 96 | module procedure normalize_pdf_cont_sp 97 | module procedure normalize_pdf_cont_dp 98 | end interface normalize_pdf 99 | 100 | public :: check_pdf 101 | interface check_pdf 102 | module procedure check_pdf_discrete_sp 103 | module procedure check_pdf_discrete_dp 104 | module procedure check_pdf_cont_sp 105 | module procedure check_pdf_cont_dp 106 | end interface check_pdf 107 | 108 | public :: find_cdf 109 | interface find_cdf 110 | module procedure find_cdf_discrete_sp 111 | module procedure find_cdf_discrete_dp 112 | module procedure find_cdf_cont_sp 113 | module procedure find_cdf_cont_dp 114 | end interface find_cdf 115 | 116 | public :: sample_pdf 117 | interface sample_pdf 118 | module procedure sample_pdf_discrete_sp 119 | module procedure sample_pdf_discrete_dp 120 | module procedure sample_pdf_cont_sp 121 | module procedure sample_pdf_cont_dp 122 | end interface sample_pdf 123 | 124 | public :: sample_pdf_log 125 | interface sample_pdf_log 126 | module procedure sample_pdf_cont_log_sp 127 | module procedure sample_pdf_cont_log_dp 128 | end interface sample_pdf_log 129 | 130 | public :: interpolate_pdf 131 | interface interpolate_pdf 132 | module procedure interpolate_pdf_cont_sp 133 | module procedure interpolate_pdf_cont_dp 134 | end interface interpolate_pdf 135 | 136 | contains 137 | 138 | !!@FOR real(sp):sp real(dp):dp 139 | 140 | subroutine find_cdf_discrete_(p) 141 | implicit none 142 | type(pdf_discrete_),intent(inout) :: p 143 | integer :: i 144 | @T :: norm 145 | if(p%n==0) stop "[find_cdf_discrete] PDF is not set correctly (y)" 146 | p%cdf(1) = p%pdf(1) 147 | do i=2,p%n 148 | p%cdf(i) = p%cdf(i-1) + p%pdf(i) 149 | end do 150 | norm = p%cdf(p%n) 151 | if(norm==0._) stop "[find_cdf_discrete] all PDF elements are zero" 152 | p%cdf = p%cdf / norm 153 | end subroutine find_cdf_discrete_ 154 | 155 | subroutine allocate_pdf_discrete_(p,n) 156 | implicit none 157 | type(pdf_discrete_),intent(out) :: p 158 | integer,intent(in) :: n 159 | p%n = n 160 | allocate(p%pdf(n)) 161 | allocate(p%cdf(n)) 162 | end subroutine allocate_pdf_discrete_ 163 | 164 | subroutine allocate_pdf_cont_(p,n) 165 | implicit none 166 | type(pdf_),intent(out) :: p 167 | integer,intent(in) :: n 168 | p%n = n 169 | allocate(p%x(n)) 170 | allocate(p%pdf(n)) 171 | allocate(p%cdf(n)) 172 | end subroutine allocate_pdf_cont_ 173 | 174 | subroutine normalize_pdf_discrete_(p) 175 | implicit none 176 | type(pdf_discrete_),intent(inout) :: p 177 | @T :: norm 178 | norm = sum(p%pdf) 179 | if(norm==0._) stop "[normalize_pdf_discrete] all PDF elements are zero" 180 | p%pdf = p%pdf / norm 181 | p%normalized = .true. 182 | end subroutine normalize_pdf_discrete_ 183 | 184 | subroutine normalize_pdf_cont_(p) 185 | implicit none 186 | type(pdf_),intent(inout) :: p 187 | if(p%log) then 188 | p%pdf = p%pdf / integral_loglog(p%x, p%pdf) 189 | else 190 | p%pdf = p%pdf / integral(p%x, p%pdf) 191 | end if 192 | p%normalized = .true. 193 | end subroutine normalize_pdf_cont_ 194 | 195 | subroutine set_pdf_discrete_(p,y) 196 | implicit none 197 | type(pdf_discrete_),intent(out) :: p 198 | @T,intent(in) :: y(:) 199 | call allocate_pdf(p,size(y)) 200 | p%pdf = y 201 | call normalize_pdf(p) 202 | call find_cdf(p) 203 | call check_pdf(p) 204 | end subroutine set_pdf_discrete_ 205 | 206 | subroutine set_pdf_cont_(p,x,y,log,simple) 207 | implicit none 208 | type(pdf_),intent(out) :: p 209 | @T,intent(in) :: x(:),y(:) 210 | logical,intent(in),optional :: log,simple 211 | if(size(x).ne.size(y)) stop "[set_pdf] x and y array sizes differ" 212 | call allocate_pdf(p,size(y)) 213 | p%x = x 214 | p%pdf = y 215 | if(present(log)) p%log = log 216 | if(present(simple)) p%simple = simple 217 | call normalize_pdf(p) 218 | call find_cdf(p) 219 | call check_pdf(p) 220 | end subroutine set_pdf_cont_ 221 | 222 | subroutine check_pdf_discrete_(p) 223 | implicit none 224 | type(pdf_discrete_),intent(in) :: p 225 | if(p%n==0) stop "[check_pdf_discrete] PDF size not set" 226 | if(.not.allocated(p%pdf)) stop "[check_pdf_discrete] PDF pdf array not allocated" 227 | if(.not.allocated(p%cdf)) stop "[check_pdf_discrete] PDF cdf array not allocated" 228 | if(p%n.ne.size(p%pdf)) stop "[check_pdf_discrete] PDF pdf array has incorrect size" 229 | if(p%n.ne.size(p%cdf)) stop "[check_pdf_discrete] PDF cdf array has incorrect size" 230 | if(any(p%pdf < 0.)) stop "[check_pdf_discrete] PDF has negative probabilities" 231 | if(.not.p%normalized) stop "[check_pdf_discrete] PDF is not normalized" 232 | end subroutine check_pdf_discrete_ 233 | 234 | subroutine check_pdf_cont_(p) 235 | implicit none 236 | type(pdf_),intent(in) :: p 237 | integer :: i 238 | if(p%n==0) stop "[check_pdf] PDF size not set" 239 | if(.not.allocated(p%x)) stop "[check_pdf] PDF x array not allocated" 240 | if(.not.allocated(p%pdf)) stop "[check_pdf] PDF pdf array not allocated" 241 | if(.not.allocated(p%cdf)) stop "[check_pdf] PDF cdf array not allocated" 242 | if(p%n.ne.size(p%x)) stop "[check_pdf] PDF x array has incorrect size" 243 | if(p%n.ne.size(p%pdf)) stop "[check_pdf] PDF pdf array has incorrect size" 244 | if(p%n.ne.size(p%cdf)) stop "[check_pdf] PDF cdf array has incorrect size" 245 | do i=2,p%n 246 | if(.not.(p%x(i)>p%x(i-1))) stop "[check_pdf] PDF x array is not sorted" 247 | end do 248 | if(any(p%pdf < 0.)) stop "[check_pdf] PDF has negative probabilities" 249 | if(.not.p%normalized) stop "[check_pdf] PDF is not normalized" 250 | end subroutine check_pdf_cont_ 251 | 252 | subroutine find_cdf_cont_(p) 253 | implicit none 254 | type(pdf_),intent(inout) :: p 255 | integer :: i 256 | call check_pdf(p) 257 | if(p%log) then 258 | p%cdf = cumulative_integral_loglog(p%x,p%pdf) 259 | else 260 | p%cdf = cumulative_integral(p%x,p%pdf) 261 | end if 262 | p%cdf = p%cdf / p%cdf(p%n) 263 | if(.not.p%simple) then 264 | if(p%log) then 265 | allocate(p%b(p%n-1)) 266 | allocate(p%r(p%n-1)) 267 | do i=1,p%n-1 268 | p%b(i) = log10(p%pdf(i) / p%pdf(i+1)) / log10(p%x(i) / p%x(i+1)) 269 | p%r(i) = (p%x(i+1) / p%x(i)) ** (p%b(i) + 1._dp) 270 | end do 271 | else 272 | allocate(p%a(p%n-1)) 273 | allocate(p%b(p%n-1)) 274 | allocate(p%rx(p%n-1)) 275 | allocate(p%rc(p%n-1)) 276 | do i=1,p%n-1 277 | p%a(i) = (p%pdf(i) - p%pdf(i+1)) / (p%x(i) - p%x(i+1)) 278 | p%b(i) = p%pdf(i) - p%a(i) * p%x(i) 279 | p%rx(i) = p%x(i+1) / p%x(i) 280 | p%rc(i) = p%b(i) / p%a(i) 281 | end do 282 | end if 283 | end if 284 | end subroutine find_cdf_cont_ 285 | 286 | integer function sample_pdf_discrete_(p) 287 | implicit none 288 | type(pdf_discrete_) :: p 289 | integer :: j,jmin,jmax 290 | @T :: xi 291 | call random(xi) 292 | if(xi <= p%cdf(1)) then 293 | sample_pdf_discrete_ = 1 294 | else if(xi >= p%cdf(p%n)) then 295 | sample_pdf_discrete_ = p%n 296 | else 297 | jmin = 1 298 | jmax = p%n 299 | do 300 | j = (jmax + jmin) / 2 301 | if(xi > p%cdf(j)) then 302 | jmin = j 303 | else 304 | jmax = j 305 | end if 306 | if(jmax == jmin + 1) exit 307 | end do 308 | sample_pdf_discrete_ = jmax 309 | end if 310 | end function sample_pdf_discrete_ 311 | 312 | @T function sample_pdf_cont_(p,xi_alt) 313 | implicit none 314 | type(pdf_),intent(in) :: p 315 | @T,optional,intent(in) :: xi_alt 316 | @T :: xi 317 | integer :: i 318 | if(present(xi_alt)) then 319 | xi = xi_alt 320 | else 321 | call random(xi) 322 | end if 323 | if(xi <= p%cdf(1)) then 324 | sample_pdf_cont_ = p%x(1) 325 | else if(xi >= p%cdf(p%n)) then 326 | sample_pdf_cont_ = p%x(p%n) 327 | else 328 | if(p%simple) then 329 | if(p%log) then 330 | sample_pdf_cont_ = interp1d_linlog(p%cdf(:), p%x(:), xi) 331 | else 332 | sample_pdf_cont_ = interp1d(p%cdf(:), p%x(:), xi) 333 | end if 334 | else 335 | i = locate(p%cdf, xi) 336 | xi = (xi - p%cdf(i)) / (p%cdf(i+1) - p%cdf(i)) 337 | if(p%log) then 338 | sample_pdf_cont_ = (xi * (p%r(i) - 1._dp) + 1._dp) ** (1._dp / (p%b(i) + 1._dp)) * p%x(i) 339 | else 340 | if(p%a(i)==0._dp) then 341 | sample_pdf_cont_ = xi * (p%x(i+1) - p%x(i)) + p%x(i) 342 | else if(p%x(i)==0._dp) then 343 | sample_pdf_cont_ = - p%rc(i) + sign(sqrt(p%rc(i) * p%rc(i) & 344 | & + xi * p%x(i+1) * p%x(i+1) & 345 | & + 2._ * p%rc(i) * xi * p%x(i+1)), p%a(i)) 346 | else 347 | sample_pdf_cont_ = - p%rc(i) + sign(sqrt(p%rc(i) * p%rc(i) & 348 | & + p%x(i) * p%x(i) * (xi * (p%rx(i) * p%rx(i) - 1._) + 1._) & 349 | & + 2._ * p%rc(i) * p%x(i) * (xi * (p%rx(i) - 1._) + 1._)), p%a(i)) 350 | end if 351 | end if 352 | end if 353 | end if 354 | end function sample_pdf_cont_ 355 | 356 | @T function sample_pdf_cont_log_(p,xi_alt) 357 | implicit none 358 | type(pdf_),intent(in) :: p 359 | @T,optional,intent(in) :: xi_alt 360 | @T :: xi 361 | if(present(xi_alt)) then 362 | xi = xi_alt 363 | else 364 | call random(xi) 365 | end if 366 | sample_pdf_cont_log_ = interp1d_loglog(p%cdf(:),p%x(:),xi) 367 | end function sample_pdf_cont_log_ 368 | 369 | @T function interpolate_pdf_cont_(p, x, bounds_error, fill_value) result(prob) 370 | implicit none 371 | type(pdf_),intent(in) :: p 372 | @T,intent(in) :: x 373 | logical,intent(in),optional :: bounds_error 374 | real(),intent(in),optional :: fill_value 375 | if(.not.p%normalized) stop "[interpolate_pdf] PDF is not normalized" 376 | if(p%log) then 377 | prob = interp1d_loglog(p%x, p%pdf, x, bounds_error, fill_value) 378 | else 379 | prob = interp1d(p%x, p%pdf, x, bounds_error, fill_value) 380 | end if 381 | end function interpolate_pdf_cont_ 382 | 383 | !!@END FOR 384 | 385 | end module type_pdf 386 | -------------------------------------------------------------------------------- /templates/type_stokes_template.f90: -------------------------------------------------------------------------------- 1 | ! Stokes vector related routines 2 | ! 3 | ! ------------------------------------------------------------------------------ 4 | ! Copyright (c) 2009-13, Thomas P. Robitaille 5 | ! 6 | ! All rights reserved. 7 | ! 8 | ! Redistribution and use in source and binary forms, with or without 9 | ! modification, are permitted provided that the following conditions are met: 10 | ! 11 | ! * Redistributions of source code must retain the above copyright notice, this 12 | ! list of conditions and the following disclaimer. 13 | ! 14 | ! * Redistributions in binary form must reproduce the above copyright notice, 15 | ! this list of conditions and the following disclaimer in the documentation 16 | ! and/or other materials provided with the distribution. 17 | ! 18 | ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19 | ! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | ! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | ! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | ! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | ! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | ! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | ! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | ! ------------------------------------------------------------------------------ 29 | 30 | module type_stokes 31 | 32 | implicit none 33 | save 34 | 35 | private 36 | 37 | integer,parameter :: sp = selected_real_kind(p=6,r=37) 38 | integer,parameter :: dp = selected_real_kind(p=15,r=307) 39 | 40 | public :: stokes_dp 41 | type stokes_dp 42 | real(dp) :: I,U,Q,V 43 | end type stokes_dp 44 | 45 | public :: stokes_sp 46 | type stokes_sp 47 | real(sp) :: I,U,Q,V 48 | end type stokes_sp 49 | 50 | public :: operator(+) 51 | interface operator(+) 52 | module procedure add_stokes_sp 53 | module procedure add_stokes_dp 54 | end interface operator(+) 55 | 56 | public :: operator(-) 57 | interface operator(-) 58 | module procedure sub_stokes_sp 59 | module procedure sub_stokes_dp 60 | end interface operator(-) 61 | 62 | public :: operator(*) 63 | interface operator(*) 64 | module procedure scalar_stokes_mult_sp,stokes_scalar_mult_sp,stokes_stokes_mult_sp 65 | module procedure scalar_stokes_mult_dp,stokes_scalar_mult_dp,stokes_stokes_mult_dp 66 | end interface operator(*) 67 | 68 | public :: operator(/) 69 | interface operator(/) 70 | module procedure scalar_stokes_div_sp,stokes_scalar_div_sp 71 | module procedure scalar_stokes_div_dp,stokes_scalar_div_dp 72 | end interface operator(/) 73 | 74 | public :: operator(**) 75 | interface operator(**) 76 | module procedure pow_stokes_sp 77 | module procedure pow_stokes_dp 78 | end interface operator(**) 79 | 80 | contains 81 | 82 | !!@FOR real(sp):sp real(dp):dp 83 | 84 | !**********************************************************************! 85 | ! Stokes addition 86 | !**********************************************************************! 87 | 88 | type(stokes_) function add_stokes_(a,b) result(s) 89 | 90 | implicit none 91 | 92 | type(stokes_),intent(in) :: a,b 93 | 94 | s%I = a%I + b%I 95 | s%Q = a%Q + b%Q 96 | s%U = a%U + b%U 97 | s%V = a%V + b%V 98 | 99 | end function add_stokes_ 100 | 101 | !**********************************************************************! 102 | ! Stokes subtraction 103 | !**********************************************************************! 104 | 105 | type(stokes_) function sub_stokes_(a,b) result(s) 106 | 107 | implicit none 108 | 109 | type(stokes_),intent(in) :: a,b 110 | 111 | s%I = a%I - b%I 112 | s%Q = a%Q - b%Q 113 | s%U = a%U - b%U 114 | s%V = a%V - b%V 115 | 116 | end function sub_stokes_ 117 | 118 | !**********************************************************************! 119 | ! Scalar * Stokes 120 | !**********************************************************************! 121 | 122 | type(stokes_) function scalar_stokes_mult_(a,b) result(s) 123 | 124 | implicit none 125 | 126 | @T,intent(in) :: a 127 | type(stokes_),intent(in) :: b 128 | 129 | s%I = a * b%I 130 | s%Q = a * b%Q 131 | s%U = a * b%U 132 | s%V = a * b%V 133 | 134 | end function scalar_stokes_mult_ 135 | 136 | type(stokes_) function stokes_scalar_mult_(a,b) result(s) 137 | 138 | implicit none 139 | 140 | type(stokes_),intent(in) :: a 141 | @T,intent(in) :: b 142 | 143 | s%I = a%I * b 144 | s%Q = a%Q * b 145 | s%U = a%U * b 146 | s%V = a%V * b 147 | 148 | end function stokes_scalar_mult_ 149 | 150 | type(stokes_) function stokes_stokes_mult_(a,b) result(s) 151 | 152 | implicit none 153 | 154 | type(stokes_),intent(in) :: a, b 155 | 156 | s%I = a%I * b%I 157 | s%Q = a%Q * b%Q 158 | s%U = a%U * b%U 159 | s%V = a%V * b%V 160 | 161 | end function stokes_stokes_mult_ 162 | 163 | !**********************************************************************! 164 | ! Scalar / Stokes 165 | !**********************************************************************! 166 | 167 | type(stokes_) function scalar_stokes_div_(a,b) result(s) 168 | 169 | implicit none 170 | 171 | @T,intent(in) :: a 172 | type(stokes_),intent(in) :: b 173 | 174 | s%I = a / b%I 175 | s%Q = a / b%Q 176 | s%U = a / b%U 177 | s%V = a / b%V 178 | 179 | end function scalar_stokes_div_ 180 | 181 | type(stokes_) function stokes_scalar_div_(a,b) result(s) 182 | 183 | implicit none 184 | 185 | type(stokes_),intent(in) :: a 186 | @T,intent(in) :: b 187 | 188 | s%I = a%I / b 189 | s%Q = a%Q / b 190 | s%U = a%U / b 191 | s%V = a%V / b 192 | 193 | end function stokes_scalar_div_ 194 | 195 | !**********************************************************************! 196 | ! Stokes power 197 | !**********************************************************************! 198 | 199 | type(stokes_) function pow_stokes_(a,power) result(s) 200 | 201 | implicit none 202 | 203 | type(stokes_),intent(in) :: a 204 | real(),intent(in) :: power 205 | 206 | s%I = a%I ** power 207 | s%Q = a%Q ** power 208 | s%U = a%U ** power 209 | s%V = a%V ** power 210 | 211 | end function pow_stokes_ 212 | 213 | !!@END FOR 214 | 215 | end module type_stokes 216 | -------------------------------------------------------------------------------- /templates/type_var1d_pdf_template.f90: -------------------------------------------------------------------------------- 1 | ! ------------------------------------------------------------------------------ 2 | ! Copyright (c) 2009-13, Thomas P. Robitaille 3 | ! 4 | ! All rights reserved. 5 | ! 6 | ! Redistribution and use in source and binary forms, with or without 7 | ! modification, are permitted provided that the following conditions are met: 8 | ! 9 | ! * Redistributions of source code must retain the above copyright notice, this 10 | ! list of conditions and the following disclaimer. 11 | ! 12 | ! * Redistributions in binary form must reproduce the above copyright notice, 13 | ! this list of conditions and the following disclaimer in the documentation 14 | ! and/or other materials provided with the distribution. 15 | ! 16 | ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 17 | ! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 18 | ! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | ! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 20 | ! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 22 | ! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 23 | ! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 24 | ! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 25 | ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | ! ------------------------------------------------------------------------------ 27 | 28 | module type_var1d_pdf 29 | 30 | use lib_array, only : locate 31 | use lib_random, only : random 32 | use type_pdf, only : pdf_sp, pdf_dp, sample_pdf, set_pdf 33 | 34 | implicit none 35 | save 36 | 37 | private 38 | 39 | integer,parameter :: sp = selected_real_kind(p=6,r=37) 40 | integer,parameter :: dp = selected_real_kind(p=15,r=307) 41 | 42 | 43 | ! The purpose of this class is to implement a 1-d PDF that depends on another variable that is provided when sampling. The two PDFs neighboring the value requested are then sampled with the same random number, and the resulting value is then interpolated. 44 | 45 | !!@FOR real(sp):sp real():dp 46 | 47 | public :: var1d_pdf_ 48 | type var1d_pdf_ 49 | integer :: nz 50 | real(), allocatable :: z(:) 51 | type(pdf_), allocatable :: p(:) 52 | end type var1d_pdf_ 53 | 54 | !!@END FOR 55 | 56 | public :: set_var1d_pdf 57 | interface set_var1d_pdf 58 | module procedure set_var1d_pdf_sp 59 | module procedure set_var1d_pdf_dp 60 | end interface set_var1d_pdf 61 | 62 | public :: sample_var1d_pdf 63 | interface sample_var1d_pdf 64 | module procedure sample_var1d_pdf_sp 65 | module procedure sample_var1d_pdf_dp 66 | end interface sample_var1d_pdf 67 | 68 | contains 69 | 70 | !!@FOR real(sp):sp real():dp 71 | 72 | type(var1d_pdf_) function set_var1d_pdf_(x, z, prob) result(v) 73 | 74 | ! Initialize a var1d_pdf_ object 75 | ! 76 | ! This version assumes that all the PDFs are defined on the same grid. 77 | ! We can easily create a version that has different x values for each 78 | ! PDF. 79 | ! 80 | ! Parameters 81 | ! ---------- 82 | ! x : 1-d array (size nx) 83 | ! x values in the PDFs 84 | ! z : 1-d array (size nz) 85 | ! Values that the PDFs are defined for 86 | ! prob : 2-d array (size nx, nz) 87 | ! The probabilities for all the x and z values 88 | 89 | implicit none 90 | real(),intent(in) :: x(:), z(:), prob(:,:) 91 | integer :: k 92 | 93 | if(size(prob,1) /= size(x)) stop "incorrect dimensions for prob" 94 | if(size(prob,2) /= size(z)) stop "incorrect dimensions for prob" 95 | 96 | v%nz = size(z) 97 | 98 | allocate(v%z(v%nz)) 99 | allocate(v%p(v%nz)) 100 | 101 | v%z = z 102 | 103 | do k=1,v%nz 104 | call set_pdf(v%p(k), x, prob(:, k)) 105 | end do 106 | 107 | end function set_var1d_pdf_ 108 | 109 | real() function sample_var1d_pdf_(z, v) result(x) 110 | 111 | ! Sample a var1d_pdf_ object 112 | ! 113 | ! Parameters 114 | ! ---------- 115 | ! z : real() 116 | ! The z value to sample the PDFs for 117 | ! v : var1d_pdf_ 118 | ! The variable PDF to sample 119 | ! 120 | ! Returns 121 | ! ------- 122 | ! x : real() 123 | ! The sampled value 124 | 125 | real(),intent(in) :: z 126 | type(var1d_pdf_),intent(in) :: v 127 | real() :: x1, x2, xi 128 | integer :: iz 129 | 130 | ! Find bin in z array 131 | iz = locate(v%z, z) 132 | 133 | ! Sample random value 134 | call random(xi) 135 | 136 | ! Sample both PDFs 137 | x1 = sample_pdf(v%p(iz), xi_alt=xi) 138 | x2 = sample_pdf(v%p(iz+1), xi_alt=xi) 139 | 140 | ! Calculate result 141 | x = (z - v%z(iz)) / (v%z(iz+1) - v%z(iz)) * (x2 - x1) + x1 142 | 143 | end function sample_var1d_pdf_ 144 | 145 | !!@END FOR 146 | 147 | end module type_var1d_pdf 148 | 149 | -------------------------------------------------------------------------------- /templates/type_var2d_pdf2d_template.f90: -------------------------------------------------------------------------------- 1 | ! ------------------------------------------------------------------------------ 2 | ! Copyright (c) 2009-13, Thomas P. Robitaille 3 | ! 4 | ! All rights reserved. 5 | ! 6 | ! Redistribution and use in source and binary forms, with or without 7 | ! modification, are permitted provided that the following conditions are met: 8 | ! 9 | ! * Redistributions of source code must retain the above copyright notice, this 10 | ! list of conditions and the following disclaimer. 11 | ! 12 | ! * Redistributions in binary form must reproduce the above copyright notice, 13 | ! this list of conditions and the following disclaimer in the documentation 14 | ! and/or other materials provided with the distribution. 15 | ! 16 | ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 17 | ! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 18 | ! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | ! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 20 | ! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 22 | ! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 23 | ! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 24 | ! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 25 | ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | ! ------------------------------------------------------------------------------ 27 | 28 | module type_var2d_pdf2d 29 | 30 | use lib_array, only : locate, interp2d 31 | use lib_random, only : random 32 | use type_pdf2d, only : pdf2d_sp, pdf2d_dp, sample_pdf2d, set_pdf2d, interpolate_pdf2d 33 | 34 | implicit none 35 | save 36 | 37 | private 38 | 39 | integer,parameter :: sp = selected_real_kind(p=6,r=37) 40 | integer,parameter :: dp = selected_real_kind(p=15,r=307) 41 | 42 | ! The purpose of this class is to implement a 2-d PDF that depends on two 43 | ! other variables that are provided when sampling. The four PDFs neighboring 44 | ! the value requested are then sampled with the same random number, and the 45 | ! resulting value is then interpolated using bilinear interpolation. 46 | 47 | !!@FOR real(sp):sp real():dp 48 | 49 | public :: var2d_pdf2d_ 50 | type var2d_pdf2d_ 51 | integer :: nw, nz 52 | real(), allocatable :: w(:) 53 | real(), allocatable :: z(:) 54 | type(pdf2d_), allocatable :: p(:,:) 55 | end type var2d_pdf2d_ 56 | 57 | !!@END FOR 58 | 59 | public :: set_var2d_pdf2d 60 | interface set_var2d_pdf2d 61 | module procedure set_var2d_pdf2d_sp 62 | module procedure set_var2d_pdf2d_dp 63 | end interface set_var2d_pdf2d 64 | 65 | public :: sample_var2d_pdf2d 66 | interface sample_var2d_pdf2d 67 | module procedure sample_var2d_pdf2d_sp 68 | module procedure sample_var2d_pdf2d_dp 69 | end interface sample_var2d_pdf2d 70 | 71 | public :: interpolate_var2d_pdf2d 72 | interface interpolate_var2d_pdf2d 73 | module procedure interpolate_var2d_pdf2d_sp 74 | module procedure interpolate_var2d_pdf2d_dp 75 | end interface interpolate_var2d_pdf2d 76 | 77 | contains 78 | 79 | !!@FOR real(sp):sp real():dp 80 | 81 | type(var2d_pdf2d_) function set_var2d_pdf2d_(x, y, w, z, prob) result(v) 82 | 83 | ! Initialize a var2d_pdf2d_ object 84 | ! 85 | ! This version assumes that all the PDFs are defined on the same grid. 86 | ! We can easily create a version that has different x and y values for 87 | ! each PDF. 88 | ! 89 | ! Parameters 90 | ! ---------- 91 | ! x : 1-d array (size nx) 92 | ! x values in the PDFs 93 | ! y : 1-d array (size ny) 94 | ! y values in the PDFs 95 | ! w : 1-d array (size nw) 96 | ! First set of values that the PDFs are defined for 97 | ! z : 1-d array (size nz) 98 | ! Second set of values that the PDFs are defined for 99 | ! prob : 2-d array (size nx, ny, nw, nz) 100 | ! The probabilities for all the x, y, w, and z values 101 | 102 | implicit none 103 | real(),intent(in) :: x(:), y(:), w(:), z(:), prob(:,:,:,:) 104 | integer :: iw,iz 105 | 106 | if(size(prob,1) /= size(x)) stop "incorrect dimensions for prob" 107 | if(size(prob,2) /= size(y)) stop "incorrect dimensions for prob" 108 | if(size(prob,3) /= size(w)) stop "incorrect dimensions for prob" 109 | if(size(prob,4) /= size(z)) stop "incorrect dimensions for prob" 110 | 111 | v%nw = size(w) 112 | v%nz = size(z) 113 | 114 | allocate(v%w(v%nw)) 115 | allocate(v%z(v%nz)) 116 | allocate(v%p(v%nw, v%nz)) 117 | 118 | v%w = w 119 | v%z = z 120 | 121 | do iw=1,v%nw 122 | do iz=1,v%nz 123 | v%p(iw,iz) = set_pdf2d(x, y, prob(:, :, iw, iz)) 124 | end do 125 | end do 126 | 127 | end function set_var2d_pdf2d_ 128 | 129 | subroutine sample_var2d_pdf2d_(w, z, v, x, y) 130 | 131 | ! Sample a var2d_pdf2d_ object 132 | ! 133 | ! Parameters 134 | ! ---------- 135 | ! w, z : @T 136 | ! The w and z value to sample the PDFs for 137 | ! v : var2d_pdf2d_ 138 | ! The variable PDF to sample 139 | ! 140 | ! Returns 141 | ! ------- 142 | ! x, y : @T 143 | ! The sampled values 144 | 145 | real(),intent(in) :: w, z 146 | type(var2d_pdf2d_),intent(in) :: v 147 | real(),intent(out) :: x, y 148 | real() :: x11,x12,x21,x22,y11,y12,y21,y22,xi(4) 149 | integer :: iw, iz 150 | integer :: i 151 | 152 | ! Find bin in w and z arrays 153 | iw = locate(v%w, w) 154 | iz = locate(v%z, z) 155 | 156 | ! Sample random values 157 | do i=1,4 158 | call random(xi(i)) 159 | end do 160 | 161 | ! Sample neighboring PDFs 162 | call sample_pdf2d(v%p(iw, iz), x11, y11, xi_alt=xi) 163 | call sample_pdf2d(v%p(iw+1, iz), x21, y21, xi_alt=xi) 164 | call sample_pdf2d(v%p(iw, iz+1), x12, y12, xi_alt=xi) 165 | call sample_pdf2d(v%p(iw+1, iz+1), x22, y22, xi_alt=xi) 166 | 167 | ! Calculate result using bilinear interpolation 168 | 169 | x = (x11 * (v%w(iw + 1) - w) * (v%z(iz + 1) - z) & 170 | & + x21 * (w - v%w(iw)) * (v%z(iz + 1) - z) & 171 | & + x12 * (v%w(iw + 1) - w) * (z - v%z(iz)) & 172 | & + x22 * (w - v%w(iw)) * (z - v%z(iz))) & 173 | & / (v%w(iw+1) - v%w(iw)) / (v%z(iz+1) - v%z(iz)) 174 | 175 | y = (y11 * (v%w(iw + 1) - w) * (v%z(iz + 1) - z) & 176 | & + y21 * (w - v%w(iw)) * (v%z(iz + 1) - z) & 177 | & + y12 * (v%w(iw + 1) - w) * (z - v%z(iz)) & 178 | & + y22 * (w - v%w(iw)) * (z - v%z(iz))) & 179 | & / (v%w(iw+1) - v%w(iw)) / (v%z(iz+1) - v%z(iz)) 180 | 181 | end subroutine sample_var2d_pdf2d_ 182 | 183 | 184 | @T function interpolate_var2d_pdf2d_(w, z, v, x, y, bounds_error, fill_value) result(prob) 185 | 186 | ! Interpolate a 2-d PDF 187 | ! 188 | ! Parameters 189 | ! ---------- 190 | ! w, z : @T 191 | ! The w and z value to sample the PDFs for 192 | ! v : var2d_pdf2d_ 193 | ! The variable PDF to interpolate 194 | ! x, y : @T 195 | ! Position at which to interpolate the 2-d PDF 196 | ! bounds_error : logical, optional 197 | ! Whether to raise an error if the interpolation is out of bounds 198 | ! fill_value : @T 199 | ! The value to use for out-of-bounds interpolation if bounds_error = .false. 200 | ! 201 | ! Returns 202 | ! ------- 203 | ! prob : @T 204 | ! The probability at the position requested 205 | 206 | implicit none 207 | 208 | real(),intent(in) :: w, z 209 | type(var2d_pdf2d_),intent(in) :: v 210 | @T,intent(in) :: x, y 211 | logical,intent(in),optional :: bounds_error 212 | real(),intent(in),optional :: fill_value 213 | 214 | @T :: p11,p12,p21,p22 215 | integer :: iw, iz 216 | 217 | ! Find bin in w and z arrays 218 | iw = locate(v%w, w) 219 | iz = locate(v%z, z) 220 | 221 | ! Interpolate neighboring PDFs 222 | p11 = interpolate_pdf2d(v%p(iw, iz), x, y, bounds_error, fill_value) 223 | p21 = interpolate_pdf2d(v%p(iw+1, iz), x, y, bounds_error, fill_value) 224 | p12 = interpolate_pdf2d(v%p(iw, iz+1), x, y, bounds_error, fill_value) 225 | p22 = interpolate_pdf2d(v%p(iw+1, iz+1), x, y, bounds_error, fill_value) 226 | 227 | ! Calculate result using bilinear interpolation 228 | 229 | prob = (p11 * (v%w(iw + 1) - w) * (v%z(iz + 1) - z) & 230 | & + p21 * (w - v%w(iw)) * (v%z(iz + 1) - z) & 231 | & + p12 * (v%w(iw + 1) - w) * (z - v%z(iz)) & 232 | & + p22 * (w - v%w(iw)) * (z - v%z(iz))) & 233 | & / (v%w(iw+1) - v%w(iw)) / (v%z(iz+1) - v%z(iz)) 234 | 235 | end function interpolate_var2d_pdf2d_ 236 | 237 | !!@END FOR 238 | 239 | end module type_var2d_pdf2d 240 | 241 | -------------------------------------------------------------------------------- /templates/type_vector3d_template.f90: -------------------------------------------------------------------------------- 1 | ! 3D vector related routines 2 | ! 3 | ! ------------------------------------------------------------------------------ 4 | ! Copyright (c) 2009-13, Thomas P. Robitaille 5 | ! 6 | ! All rights reserved. 7 | ! 8 | ! Redistribution and use in source and binary forms, with or without 9 | ! modification, are permitted provided that the following conditions are met: 10 | ! 11 | ! * Redistributions of source code must retain the above copyright notice, this 12 | ! list of conditions and the following disclaimer. 13 | ! 14 | ! * Redistributions in binary form must reproduce the above copyright notice, 15 | ! this list of conditions and the following disclaimer in the documentation 16 | ! and/or other materials provided with the distribution. 17 | ! 18 | ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19 | ! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | ! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | ! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | ! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | ! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | ! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | ! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | ! ------------------------------------------------------------------------------ 29 | 30 | module type_vector3d 31 | 32 | implicit none 33 | save 34 | 35 | private 36 | 37 | integer,parameter :: sp = selected_real_kind(p=6,r=37) 38 | integer,parameter :: dp = selected_real_kind(p=15,r=307) 39 | 40 | public :: vector3d_sp 41 | type vector3d_sp 42 | real(sp) :: x,y,z 43 | end type vector3d_sp 44 | 45 | public :: vector3d_dp 46 | type vector3d_dp 47 | real(dp) :: x,y,z 48 | end type vector3d_dp 49 | 50 | public :: operator(.eq.) 51 | interface operator(.eq.) 52 | module procedure equal_sp 53 | module procedure equal_dp 54 | end interface operator(.eq.) 55 | 56 | public :: operator(+) 57 | interface operator(+) 58 | module procedure add_vector3d_sp 59 | module procedure add_vector3d_dp 60 | end interface operator(+) 61 | 62 | public :: operator(-) 63 | interface operator(-) 64 | module procedure sub_vector3d_sp 65 | module procedure sub_vector3d_dp 66 | module procedure minus_vector3d_sp 67 | module procedure minus_vector3d_dp 68 | end interface operator(-) 69 | 70 | public :: operator(.dot.) 71 | interface operator(.dot.) 72 | module procedure dot_product_sp 73 | module procedure dot_product_dp 74 | end interface operator(.dot.) 75 | 76 | public :: operator(.cross.) 77 | interface operator(.cross.) 78 | module procedure cross_product_sp 79 | module procedure cross_product_dp 80 | end interface operator(.cross.) 81 | 82 | public :: operator(*) 83 | interface operator(*) 84 | module procedure scalar_vector3d_mult_sp 85 | module procedure scalar_vector3d_mult_dp 86 | module procedure vector3d_scalar_mult_sp 87 | module procedure vector3d_scalar_mult_dp 88 | end interface operator(*) 89 | 90 | public :: operator(/) 91 | interface operator(/) 92 | module procedure scalar_vector3d_div_sp 93 | module procedure scalar_vector3d_div_dp 94 | module procedure vector3d_scalar_div_sp 95 | module procedure vector3d_scalar_div_dp 96 | end interface operator(/) 97 | 98 | public :: vector3d_to_angle3d 99 | interface vector3d_to_angle3d 100 | module procedure vector3d_to_angle3d_sp 101 | module procedure vector3d_to_angle3d_dp 102 | end interface vector3d_to_angle3d 103 | 104 | public :: angle3d_to_vector3d 105 | interface angle3d_to_vector3d 106 | module procedure angle3d_to_vector3d_sp 107 | module procedure angle3d_to_vector3d_dp 108 | end interface angle3d_to_vector3d 109 | 110 | public :: random_sphere_vector3d 111 | interface random_sphere_vector3d 112 | module procedure random_sphere_vector3d_sp 113 | module procedure random_sphere_vector3d_dp 114 | end interface random_sphere_vector3d 115 | 116 | contains 117 | 118 | !!@FOR real(sp):sp real(dp):dp 119 | 120 | !**********************************************************************! 121 | ! Test equality 122 | !**********************************************************************! 123 | 124 | logical function equal_(a, b) result(e) 125 | 126 | implicit none 127 | 128 | type(vector3d_),intent(in) :: a, b 129 | 130 | e = a%x == b%x .and. a%y == b%y .and. a%z == b%z 131 | 132 | end function equal_ 133 | 134 | !**********************************************************************! 135 | ! Vector addition 136 | !**********************************************************************! 137 | 138 | type(vector3d_) function add_vector3d_(a,b) result(v) 139 | 140 | implicit none 141 | 142 | type(vector3d_),intent(in) :: a,b 143 | 144 | v%x = a%x + b%x 145 | v%y = a%y + b%y 146 | v%z = a%z + b%z 147 | 148 | end function add_vector3d_ 149 | 150 | !**********************************************************************! 151 | ! Vector subtraction 152 | !**********************************************************************! 153 | 154 | type(vector3d_) function sub_vector3d_(a,b) result(v) 155 | 156 | implicit none 157 | 158 | type(vector3d_),intent(in) :: a,b 159 | 160 | v%x = a%x - b%x 161 | v%y = a%y - b%y 162 | v%z = a%z - b%z 163 | 164 | end function sub_vector3d_ 165 | 166 | !**********************************************************************! 167 | ! Unary minus for vectors 168 | !**********************************************************************! 169 | 170 | type(vector3d_) function minus_vector3d_(a) result(v) 171 | 172 | implicit none 173 | 174 | type(vector3d_),intent(in) :: a 175 | 176 | v%x = -a%x 177 | v%y = -a%y 178 | v%z = -a%z 179 | 180 | end function minus_vector3d_ 181 | 182 | !**********************************************************************! 183 | ! Vector dot product 184 | !**********************************************************************! 185 | 186 | real() function dot_product_(a,b) result(p) 187 | 188 | implicit none 189 | 190 | type(vector3d_),intent(in) :: a,b 191 | 192 | p = a%x*b%x + a%y*b%y + a%z*b%z 193 | 194 | end function dot_product_ 195 | 196 | !**********************************************************************! 197 | ! Vector cross product 198 | !**********************************************************************! 199 | 200 | type(vector3d_) function cross_product_(a,b) result(p) 201 | 202 | implicit none 203 | 204 | type(vector3d_),intent(in) :: a,b 205 | 206 | p%x = a%y*b%z - a%z*b%y 207 | p%y = a%z*b%x - a%x*b%z 208 | p%z = a%x*b%y - a%y*b%x 209 | 210 | end function cross_product_ 211 | 212 | !**********************************************************************! 213 | ! Scalar * Vector 214 | !**********************************************************************! 215 | 216 | type(vector3d_) function scalar_vector3d_mult_(a,b) result(v) 217 | 218 | implicit none 219 | 220 | real(),intent(in) :: a 221 | type(vector3d_),intent(in) :: b 222 | 223 | v%x = a * b%x 224 | v%y = a * b%y 225 | v%z = a * b%z 226 | 227 | end function scalar_vector3d_mult_ 228 | 229 | type(vector3d_) function vector3d_scalar_mult_(a,b) result(v) 230 | 231 | implicit none 232 | 233 | type(vector3d_),intent(in) :: a 234 | real(dp),intent(in) :: b 235 | 236 | v%x = a%x * b 237 | v%y = a%y * b 238 | v%z = a%z * b 239 | 240 | end function vector3d_scalar_mult_ 241 | 242 | !**********************************************************************! 243 | ! Scalar / Vector 244 | !**********************************************************************! 245 | 246 | type(vector3d_) function scalar_vector3d_div_(a,b) result(v) 247 | 248 | implicit none 249 | 250 | real(),intent(in) :: a 251 | type(vector3d_),intent(in) :: b 252 | 253 | v%x = a / b%x 254 | v%y = a / b%y 255 | v%z = a / b%z 256 | 257 | end function scalar_vector3d_div_ 258 | 259 | type(vector3d_) function vector3d_scalar_div_(a,b) result(v) 260 | 261 | implicit none 262 | 263 | type(vector3d_),intent(in) :: a 264 | real(),intent(in) :: b 265 | 266 | v%x = a%x / b 267 | v%y = a%y / b 268 | v%z = a%z / b 269 | 270 | end function vector3d_scalar_div_ 271 | 272 | !**********************************************************************! 273 | ! Vector to angle and vice-versa 274 | !**********************************************************************! 275 | 276 | subroutine vector3d_to_angle3d_(v,a) 277 | 278 | use type_angle3d 279 | 280 | implicit none 281 | 282 | type(vector3d_),intent(in) :: v 283 | ! input 3d vector 284 | 285 | type(angle3d_),intent(out) :: a 286 | ! output 3d angle 287 | 288 | real() :: small_r,big_r 289 | 290 | small_r = sqrt( v%x * v%x + v%y * v%y ) 291 | big_r = sqrt( v%x * v%x + v%y * v%y + v%z * v%z ) 292 | 293 | a%cosp = v%x / small_r 294 | a%sinp = v%y / small_r 295 | 296 | a%cost = v%z / big_r 297 | a%sint = small_r / big_r 298 | 299 | end subroutine vector3d_to_angle3d_ 300 | 301 | subroutine angle3d_to_vector3d_(a,v) 302 | 303 | use type_angle3d 304 | 305 | implicit none 306 | 307 | type(angle3d_),intent(in) :: a 308 | ! input 3d angle 309 | 310 | type(vector3d_),intent(out) :: v 311 | ! output 3d vector 312 | 313 | v%x = a%sint * a%cosp 314 | v%y = a%sint * a%sinp 315 | v%z = a%cost 316 | 317 | end subroutine angle3d_to_vector3d_ 318 | 319 | !**********************************************************************! 320 | ! Random position on a unit sphere 321 | !**********************************************************************! 322 | 323 | subroutine random_sphere_vector3d_(v) 324 | use lib_random 325 | implicit none 326 | type(vector3d_),intent(out) :: v 327 | real() :: mu,phi,radius_cut 328 | call random_sphere(mu,phi) 329 | radius_cut = sqrt(1._-mu*mu) 330 | v%x = radius_cut * cos(phi) 331 | v%y = radius_cut * sin(phi) 332 | v%z = mu 333 | end subroutine random_sphere_vector3d_ 334 | 335 | !!@END FOR 336 | 337 | end module type_vector3d 338 | --------------------------------------------------------------------------------