├── .gitignore ├── 01-derived-type.f90 ├── 02-oop-features.f90 ├── 03-abstract-types.f90 ├── 04-lapack-wrapper.f90 ├── LICENSE └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | # Emacs backup files 2 | *~ 3 | 4 | # Prerequisites 5 | *.d 6 | 7 | # Compiled Object files 8 | *.slo 9 | *.lo 10 | *.o 11 | *.obj 12 | 13 | # Precompiled Headers 14 | *.gch 15 | *.pch 16 | 17 | # Compiled Dynamic libraries 18 | *.so 19 | *.dylib 20 | *.dll 21 | 22 | # Fortran module files 23 | *.mod 24 | *.smod 25 | 26 | # Compiled Static libraries 27 | *.lai 28 | *.la 29 | *.a 30 | *.lib 31 | 32 | # Executables 33 | *.exe 34 | *.out 35 | *.app 36 | -------------------------------------------------------------------------------- /01-derived-type.f90: -------------------------------------------------------------------------------- 1 | module type_foo_mod 2 | type :: foo 3 | real, private :: real_comp 4 | integer, public :: int_comp 5 | end type foo 6 | end module type_foo_mod 7 | 8 | program foo_example 9 | use type_foo_mod 10 | type(foo) :: f1 11 | 12 | f1%int_comp = 42 13 | f1%real_comp = 3.14 ! ILLEGAL 14 | ! Can only access private 15 | ! component in defining module 16 | end program foo_example 17 | -------------------------------------------------------------------------------- /02-oop-features.f90: -------------------------------------------------------------------------------- 1 | module oop_example_mod 2 | type :: parent 3 | integer, private :: i = 5 4 | contains 5 | procedure :: get_val=>get_parent 6 | end type parent 7 | 8 | type, extends(parent) :: child 9 | contains 10 | procedure :: get_val=>get_child 11 | end type child 12 | contains 13 | integer function get_parent(this) 14 | class(parent), intent(in):: this 15 | get_parent = this%i 16 | end function 17 | 18 | integer function get_child(this) 19 | class(child), intent(in):: this 20 | get_child = 2*this%i - 1 21 | end function 22 | end module oop_example_mod 23 | 24 | program polymorphism_demo 25 | use oop_example_mod 26 | type(parent) :: p 27 | type(child) :: c 28 | 29 | call print_val(p) ! Prints 5 30 | call print_val(c) ! Prints 9 31 | 32 | contains 33 | 34 | subroutine print_val(obj) 35 | class(parent), intent(in) :: obj 36 | print*, obj%get_val() 37 | end subroutine print_val 38 | 39 | end program polymorphism_demo 40 | -------------------------------------------------------------------------------- /03-abstract-types.f90: -------------------------------------------------------------------------------- 1 | module interface_example_mod 2 | 3 | type, abstract :: differentiator 4 | contains 5 | procedure(diff), deferred :: derivative 6 | end type differentiator 7 | 8 | abstract interface 9 | function diff(this, f, dx) 10 | import differentiator 11 | class(differentiator), intent(in) :: this 12 | real, intent(in) :: f(:) 13 | real, intent(in) :: dx 14 | real, dimension(size(f)) :: diff 15 | end function diff 16 | end interface 17 | 18 | end module interface_example_mod 19 | 20 | 21 | 22 | module interface_implementation_mod 23 | use interface_example_mod 24 | 25 | type, extends(differentiator) :: centered_2nd_order 26 | contains 27 | procedure :: derivative 28 | end type centered_2nd_order 29 | 30 | contains 31 | 32 | function derivative(this, f, dx) 33 | class(centered_2nd_order), intent(in) :: this 34 | real, intent(in) :: f(:) 35 | real, intent(in) :: dx 36 | real, dimension(size(f)) :: derivative 37 | 38 | integer :: i, up, down 39 | 40 | do i = 1, size(f) 41 | up = min(i+1, size(f)) 42 | down = max(i-1, 1) 43 | derivative(i) = 0.5*(f(up) - f(down))/dx 44 | end do 45 | end function derivative 46 | 47 | end module interface_implementation_mod 48 | -------------------------------------------------------------------------------- /04-lapack-wrapper.f90: -------------------------------------------------------------------------------- 1 | module square_matrix_mod 2 | implicit none 3 | private 4 | 5 | integer, parameter, public :: dp = selected_real_kind(15, 307) 6 | 7 | type, abstract, public :: square_matrix 8 | contains 9 | procedure(getm), deferred :: get_matrix 10 | procedure(gets), deferred :: get_size 11 | procedure, private :: mat_mult 12 | generic :: operator(*) => mat_mult 13 | procedure(solve), deferred :: inv_mat_mult 14 | end type square_matrix 15 | 16 | abstract interface 17 | pure function getm(this) result(m) 18 | import square_matrix 19 | import dp 20 | class(square_matrix), intent(in) :: this 21 | real(dp), dimension(this%get_size(), this%get_size()) :: m 22 | end function getm 23 | 24 | pure function gets(this) result(s) 25 | import square_matrix 26 | class(square_matrix), intent(in) :: this 27 | integer :: s 28 | end function gets 29 | 30 | function solve(this, rhs) result(solution) 31 | ! TODO: Consider returning a derived type with information on 32 | ! error, etc. 33 | import square_matrix 34 | import dp 35 | class(square_matrix), intent(inout) :: this 36 | real(dp), dimension(:), intent(in) :: rhs 37 | real(dp), dimension(size(rhs)) :: solution 38 | end function solve 39 | end interface 40 | 41 | contains 42 | 43 | pure function mat_mult(this, rhs) result(product) 44 | class(square_matrix), intent(in) :: this 45 | real(dp), dimension(:), intent(in) :: rhs 46 | real(dp), dimension(size(rhs)) :: product 47 | real(dp), allocatable, dimension(:,:) :: mat 48 | if (this%get_size() /= size(rhs)) error stop "Matrix and array of different sizes" 49 | product = matmul(this%get_matrix(), rhs) 50 | end function mat_mult 51 | 52 | end module square_matrix_mod 53 | 54 | 55 | module general_square_matrix_mod 56 | use square_matrix_mod 57 | implicit none 58 | private 59 | 60 | real(dp), dimension(:), allocatable :: real_work_array 61 | integer, dimension(:), allocatable :: integer_work_array 62 | 63 | type, extends(square_matrix), public :: general_square_matrix 64 | private 65 | real(dp), dimension(:,:), allocatable :: matrix 66 | real(dp), dimension(:,:), allocatable :: factored_matrix 67 | real(dp), dimension(:), allocatable :: col_scale_factors 68 | real(dp), dimension(:), allocatable :: row_scale_factors 69 | integer, dimension(:), allocatable :: pivots 70 | logical :: factored = .false. 71 | character :: equilibration = "N" 72 | contains 73 | procedure :: get_matrix 74 | procedure :: get_size 75 | procedure :: inv_mat_mult 76 | end type general_square_matrix 77 | 78 | interface general_square_matrix 79 | module procedure constructor 80 | end interface general_square_matrix 81 | 82 | interface 83 | pure subroutine dgesvx(fact, trans, n, nrhs, a, lda, af, ldaf, & 84 | ipiv, equed, r, c, b, ldb, x, ldx, rcond, ferr, berr, work, & 85 | iwork, info) 86 | import dp 87 | character, intent(in) :: fact 88 | character, intent(in) :: trans 89 | integer, intent(in) :: n 90 | integer, intent(in) :: nrhs 91 | real(dp), intent(inout), dimension(lda, n) :: a 92 | integer, intent(in) :: lda 93 | real(dp), intent(inout), dimension(ldaf, n) :: af 94 | integer, intent(in) :: ldaf 95 | integer, intent(inout), dimension(n) :: ipiv 96 | character, intent(inout) :: equed 97 | real(dp), intent(inout), dimension(n) :: r 98 | real(dp), intent(inout), dimension(n) :: c 99 | real(dp), intent(inout), dimension(ldb, nrhs) :: b 100 | integer, intent(in) :: ldb 101 | real(dp), intent(out), dimension(ldx, nrhs) :: x 102 | integer, intent(in) :: ldx 103 | real(dp), intent(out) :: rcond 104 | real(dp), intent(out), dimension(nrhs) :: ferr 105 | real(dp), intent(out), dimension(nrhs) :: berr 106 | real(dp), intent(out), dimension(4*n) :: work 107 | integer, intent(out), dimension(n) :: iwork 108 | integer, intent(out) :: info 109 | end subroutine dgesvx 110 | end interface 111 | 112 | contains 113 | 114 | function constructor(matrix) result(this) 115 | real(dp), dimension(:, :), intent(in) :: matrix 116 | type(general_square_matrix) :: this 117 | integer :: n 118 | n = size(matrix, 1) 119 | if (n /= size(matrix, 2)) then 120 | error stop "Non-square matrix used to build type(general_square_matrix)" 121 | end if 122 | allocate(this%matrix(n, n), source=matrix) 123 | allocate(this%factored_matrix(n, n)) 124 | allocate(this%col_scale_factors(n)) 125 | allocate(this%row_scale_factors(n)) 126 | allocate(this%pivots(n)) 127 | this%col_scale_factors = 1.0_dp 128 | this%row_scale_factors = 1.0_dp 129 | end function constructor 130 | 131 | pure function get_matrix(this) result(matrix) 132 | class(general_square_matrix), intent(in) :: this 133 | real(dp), dimension(this%get_size(), this%get_size()) :: matrix 134 | integer :: i, j 135 | do concurrent (i=1:this%get_size(), j=1:this%get_size()) 136 | matrix(i, j) = this%matrix(i, j) 137 | if (this%equilibration == 'R' .or. this%equilibration == 'B') & 138 | matrix(i, j) = matrix(i,j) / this%row_scale_factors(i) 139 | if (this%equilibration == 'C' .or. this%equilibration == 'B') & 140 | matrix(i, j) = matrix(i,j) / this%col_scale_factors(j) 141 | end do 142 | end function get_matrix 143 | 144 | pure function get_size(this) result(mat_size) 145 | class(general_square_matrix), intent(in) :: this 146 | integer :: mat_size 147 | mat_size = size(this%matrix, 1) 148 | end function get_size 149 | 150 | function inv_mat_mult(this, rhs) result(solution) 151 | class(general_square_matrix), intent(inout) :: this 152 | real(dp), dimension(:), intent(in) :: rhs 153 | real(dp), dimension(size(rhs)) :: solution 154 | 155 | integer :: n, info 156 | real(dp), dimension(size(rhs), 1) :: x, b 157 | real(dp), dimension(1) :: ferr, berr 158 | real(dp) :: rcond 159 | character :: fact 160 | 161 | n = size(rhs) 162 | if (n /= this%get_size()) error stop "Mismatched vector/matrix sizes" 163 | 164 | if (.not. allocated(real_work_array)) then 165 | allocate(real_work_array(4*n)) 166 | allocate(integer_work_array(n)) 167 | else 168 | if (size(real_work_array) < 4*n) then 169 | deallocate(real_work_array) 170 | allocate(real_work_array(4*n)) 171 | end if 172 | if (size(integer_work_array) < n) then 173 | deallocate(integer_work_array) 174 | allocate(integer_work_array(n)) 175 | end if 176 | end if 177 | b(:, 1) = rhs 178 | 179 | if (this%factored) then 180 | fact = 'F' 181 | else 182 | fact = 'E' 183 | end if 184 | call dgesvx(fact, 'N', n, 1, this%matrix, n, this%factored_matrix, & 185 | n, this%pivots, this%equilibration, this%row_scale_factors, & 186 | this%col_scale_factors, b, n, x, n, rcond, ferr, berr, & 187 | real_work_array, integer_work_array, info) 188 | 189 | if (info /= 0) error stop "DGESVX returned with non-zero INFO argument" 190 | this%factored = .true. 191 | solution = x(:,1) 192 | end function inv_mat_mult 193 | 194 | end module general_square_matrix_mod 195 | 196 | 197 | program test_solver 198 | use square_matrix_mod, only: dp 199 | use general_square_matrix_mod, only: general_square_matrix 200 | implicit none 201 | 202 | type(general_square_matrix) :: solver 203 | integer, parameter :: n = 5 204 | real(dp), dimension(n, n) :: matrix 205 | real(dp), dimension(n) :: x_actual, x_solved, b 206 | integer :: i 207 | 208 | matrix(1, 1) = 3.5_dp 209 | matrix(1, 2) = 1._dp 210 | matrix(1, 3) = -5._dp 211 | matrix(1, 4) = 1._dp 212 | matrix(1, 5) = 0._dp 213 | 214 | matrix(2, 1) = -0.5_dp 215 | matrix(2, 2) = 0.03_dp 216 | matrix(2, 3) = 8._dp 217 | matrix(2, 4) = 0._dp 218 | matrix(2, 5) = -7._dp 219 | 220 | matrix(3, 1) = -2.2_dp 221 | matrix(3, 2) = 100._dp 222 | matrix(3, 3) = 0._dp 223 | matrix(3, 4) = -1._dp 224 | matrix(3, 5) = -1._dp 225 | 226 | matrix(4, 1) = 5.5_dp 227 | matrix(4, 2) = 0._dp 228 | matrix(4, 3) = -11._dp 229 | matrix(4, 4) = -82._dp 230 | matrix(4, 5) = 2._dp 231 | 232 | matrix(5, 1) = 0._dp 233 | matrix(5, 2) = 5._dp 234 | matrix(5, 3) = 4._dp 235 | matrix(5, 4) = 3._dp 236 | matrix(5, 5) = -6._dp 237 | 238 | write(*, "(A)") "Solving linear system" 239 | do i = 1, n 240 | write(*, "(5F9.2)") matrix(i, :) 241 | end do 242 | 243 | solver = general_square_matrix(matrix) 244 | 245 | x_actual(1) = 1._dp 246 | x_actual(2) = 2._dp 247 | x_actual(3) = 3._dp 248 | x_actual(4) = 4._dp 249 | x_actual(5) = 5._dp 250 | 251 | b(1) = -5.5_dp 252 | b(2) = -11.44_dp 253 | b(3) = 188.8_dp 254 | b(4) = -345.5_dp 255 | b(5) = 7._dp 256 | 257 | write(*, "(/, A, T25, '[', 5F9.2, ']')") "RHS of linear system is", b 258 | write(*, "(A, T25, '[', 5F9.2, ']')") "Expected solution is", x_actual 259 | 260 | b = solver * x_actual 261 | x_solved = solver%inv_mat_mult(b) 262 | 263 | write(*, "(/, A, T25, '[', 5F9.2, ']')") "Actual solution is", x_solved 264 | write(*, "(A, F8.3)") "Backward Error = ", sqrt(sum((solver * x_solved - b)**2)) 265 | write(*, "(A, F8.3)") "Forward Error = ", sqrt(sum((x_solved - x_actual)**2)) 266 | 267 | end program test_solver 268 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This is free and unencumbered software released into the public domain. 2 | 3 | Anyone is free to copy, modify, publish, use, compile, sell, or 4 | distribute this software, either in source code form or as a compiled 5 | binary, for any purpose, commercial or non-commercial, and by any 6 | means. 7 | 8 | In jurisdictions that recognize copyright laws, the author or authors 9 | of this software dedicate any and all copyright interest in the 10 | software to the public domain. We make this dedication for the benefit 11 | of the public at large and to the detriment of our heirs and 12 | successors. We intend this dedication to be an overt act of 13 | relinquishment in perpetuity of all present and future rights to this 14 | software under copyright law. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 19 | IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR 20 | OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 21 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | 24 | For more information, please refer to 25 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # OOP-Fortran-Examples 2 | 3 | Examples of using the object-oriented features in Fortran, taken from 4 | [my presentation at RSECon 5 | 2019](https://rseconuk2019.sched.com/event/QKqu/2d1-revitalising-legacy-languages-teaching-an-old-dog-new-tricks-object-oriented-programming-in-fortran). 6 | 7 | ## Contents 8 | 9 | - `01-derived-type.f90`: Demonstration of the (non-OOP) derived types 10 | available since Fortran 90 11 | - `02-oop-features.f90`: Demonstration of the OOP features 12 | (encapsulation, inheritance, polymorphism) available since Fortran 13 | 2003 14 | - `03-abstract-types.f90`: An example of using an abstract type to 15 | define an interface (here demonstrating the [Strategy 16 | Pattern](https://en.wikipedia.org/wiki/Strategy_pattern)) 17 | - `04-lapack-wrapper.f90`: An example of using OOP to wrap cumbersome 18 | legacy Fortran routines (in this case, 19 | [dgesvx](http://www.netlib.org/lapack/explore-html/d7/d3b/group__double_g_esolve_ga9d90ccf6e340cacd08b7bbbb502ceb21.html#ga9d90ccf6e340cacd08b7bbbb502ceb21) 20 | from LAPACK) 21 | --------------------------------------------------------------------------------