├── .gitignore ├── LICENSE ├── README.md ├── doc ├── exercises.pdf ├── objects_advanced.pdf ├── objects_intro.pdf ├── pointers_allocatables.pdf ├── tmu_constructors-and-patterns-exercises.pdf └── tmu_constructors-and-patterns.pdf ├── exercises └── linkedlist.f90 ├── experiments ├── events.f90 ├── queue_system.f90 ├── vectorspace.f90 ├── vectorspace_abstract.f90 └── vectorspace_function.f90 └── solutions ├── abstract_framework.f90 ├── moving_average.f90 ├── moving_average_alt.f90 ├── moving_average_shift.f90 ├── readme.txt ├── replicating_objects.f90 ├── thermostat.f90 └── universal_storage.f90 /.gitignore: -------------------------------------------------------------------------------- 1 | # Prerequisites 2 | *.d 3 | 4 | # Compiled Object files 5 | *.slo 6 | *.lo 7 | *.o 8 | *.obj 9 | 10 | # Precompiled Headers 11 | *.gch 12 | *.pch 13 | 14 | # Compiled Dynamic libraries 15 | *.so 16 | *.dylib 17 | *.dll 18 | 19 | # Fortran module files 20 | *.mod 21 | *.smod 22 | 23 | # Compiled Static libraries 24 | *.lai 25 | *.la 26 | *.a 27 | *.lib 28 | 29 | # Executables 30 | *.exe 31 | *.out 32 | *.app 33 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 fortrancon 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # workshop2020 2 | Material for the workshop at FortranCon 2020 3 | -------------------------------------------------------------------------------- /doc/exercises.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fortrancon/workshop2020/4bf1740a7cc40e4cf20209a7dd984825e094e6ba/doc/exercises.pdf -------------------------------------------------------------------------------- /doc/objects_advanced.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fortrancon/workshop2020/4bf1740a7cc40e4cf20209a7dd984825e094e6ba/doc/objects_advanced.pdf -------------------------------------------------------------------------------- /doc/objects_intro.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fortrancon/workshop2020/4bf1740a7cc40e4cf20209a7dd984825e094e6ba/doc/objects_intro.pdf -------------------------------------------------------------------------------- /doc/pointers_allocatables.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fortrancon/workshop2020/4bf1740a7cc40e4cf20209a7dd984825e094e6ba/doc/pointers_allocatables.pdf -------------------------------------------------------------------------------- /doc/tmu_constructors-and-patterns-exercises.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fortrancon/workshop2020/4bf1740a7cc40e4cf20209a7dd984825e094e6ba/doc/tmu_constructors-and-patterns-exercises.pdf -------------------------------------------------------------------------------- /doc/tmu_constructors-and-patterns.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fortrancon/workshop2020/4bf1740a7cc40e4cf20209a7dd984825e094e6ba/doc/tmu_constructors-and-patterns.pdf -------------------------------------------------------------------------------- /exercises/linkedlist.f90: -------------------------------------------------------------------------------- 1 | ! linkedlist.f90 -- 2 | ! Define a simple module for a linked list 3 | ! 4 | ! To be able to add elements at the start of the list 5 | ! (without having to define a special type), we misuse the 6 | ! first element for this purpose. 7 | ! 8 | ! Inserting a new element is a trifle subtle: you need to keep 9 | ! track of where you are in the list. 10 | ! 11 | module linkedlists 12 | implicit none 13 | 14 | integer, parameter :: HEAD = 0 15 | integer, parameter :: TAIL = huge(1) 16 | 17 | type element_data 18 | integer :: value 19 | end type element_data 20 | 21 | type linked_list 22 | type(element_data) :: data 23 | type(linked_list), pointer :: next => null() 24 | contains 25 | procedure :: insert => insert_element 26 | procedure :: get => get_element 27 | procedure :: remove => remove_element 28 | procedure :: print => print_list 29 | end type linked_list 30 | 31 | contains 32 | 33 | ! print_list -- 34 | ! Simply print the stored value to the screen and move to 35 | ! the next element 36 | ! 37 | ! Alternative implementations: 38 | ! - Use recursion 39 | ! - Use a type-bound subroutine to print the contained data 40 | ! 41 | subroutine print_list( this ) 42 | class(linked_list), intent(in), target :: this 43 | 44 | class(linked_list), pointer :: next 45 | integer :: idx 46 | 47 | next => this%next ! Skip the first element - it functions as the "head" 48 | 49 | if ( .not. associated(next) ) then 50 | write(*,*) '(empty list)' 51 | return 52 | endif 53 | 54 | idx = 1 55 | 56 | do while ( associated(next) ) 57 | write(*,*) idx, next%data%value ! Better: a type-specific routine 58 | 59 | next => next%next 60 | idx = idx + 1 61 | enddo 62 | end subroutine print_list 63 | 64 | ! insert_element -- 65 | ! Insert an element to the list at a given numerical position. 66 | ! If the position is zero or negative it is inserted as the 67 | ! first one, if it is beyond the last one, it is appended to 68 | ! the list 69 | ! 70 | ! You can use the parameters HEAD and TAIL to make this 71 | ! explicit 72 | ! 73 | subroutine insert_element( this, pos, element ) 74 | class(linked_list), intent(inout), target :: this 75 | integer, intent(in) :: pos 76 | type(element_data), intent(in), target :: element 77 | 78 | class(linked_list), pointer :: next, prev 79 | class(linked_list), pointer :: new_element 80 | integer :: idx 81 | logical :: found 82 | 83 | next => this%next ! Special treatment for the first element - it functions as the "head" 84 | 85 | if ( .not. associated(next) ) then 86 | allocate( this%next ) 87 | this%next%data = element 88 | return 89 | endif 90 | 91 | idx = 1 92 | found = .false. 93 | next => this 94 | 95 | do while ( associated(next) ) 96 | if ( idx == pos .or. pos < 1 ) then 97 | found = .true. 98 | allocate( new_element ) 99 | new_element%next => next%next 100 | new_element%data = element ! This might require a user-defined assignment 101 | next%next => new_element 102 | exit 103 | endif 104 | 105 | prev => next 106 | next => next%next 107 | idx = idx + 1 108 | enddo 109 | 110 | ! 111 | ! The variable prev is pointing to the last element, so 112 | ! use that to append the new element 113 | ! 114 | if ( .not. found ) then 115 | allocate( prev%next ) 116 | prev%next%data = element 117 | return 118 | endif 119 | 120 | end subroutine insert_element 121 | 122 | ! remove_element -- 123 | ! Remove an element from the list at a given numerical position. 124 | ! If the position is zero or negative the first element is 125 | ! removed, if it is beyond the last one, the last one is removed 126 | ! the list 127 | ! 128 | ! You can use the parameters HEAD and TAIL to make this 129 | ! explicit 130 | ! 131 | subroutine remove_element( this, pos ) 132 | class(linked_list), intent(inout), target :: this 133 | integer, intent(in) :: pos 134 | 135 | class(linked_list), pointer :: next, prev 136 | class(linked_list), pointer :: old_element 137 | integer :: idx 138 | logical :: found 139 | 140 | ! 141 | ! Special treatment if we want to remove the first element 142 | if ( pos <= 1 ) then 143 | if ( associated(this%next) ) then 144 | this%data = this%next%data 145 | this%next => this%next%next 146 | return 147 | endif 148 | endif 149 | 150 | idx = 1 151 | found = .false. 152 | next => this%next 153 | prev => this 154 | 155 | do while ( associated(next) ) 156 | if ( idx == pos .or. .not. associated(next%next) ) then 157 | found = .true. 158 | old_element => next 159 | prev%next => next%next 160 | 161 | deallocate( old_element ) 162 | ! How about deleting the data associated with the element? 163 | exit 164 | endif 165 | 166 | prev => next 167 | next => next%next 168 | idx = idx + 1 169 | enddo 170 | 171 | end subroutine remove_element 172 | 173 | ! get_element -- 174 | ! Get an element from the list at a given numerical position. 175 | ! If the position is zero or negative the first element is 176 | ! returned, if it is beyond the last one, the last one is returned 177 | ! 178 | ! You can use the parameters HEAD and TAIL to make this 179 | ! explicit 180 | ! 181 | ! Note: 182 | ! Retrieving an element from an empty list is not detectable! 183 | ! 184 | function get_element( this, pos ) 185 | class(linked_list), intent(in), target :: this 186 | integer, intent(in) :: pos 187 | type(element_data) :: get_element 188 | 189 | class(linked_list), pointer :: next, prev 190 | integer :: idx 191 | logical :: found 192 | 193 | ! 194 | ! Special treatment for the first element 195 | ! 196 | if ( pos <= 1 ) then 197 | get_element = this%data 198 | return 199 | endif 200 | 201 | idx = 1 202 | found = .false. 203 | next => this%next 204 | prev => this 205 | 206 | do while ( associated(next) ) 207 | if ( idx == pos .or. .not. associated(next%next) ) then 208 | found = .true. 209 | get_element = next%data 210 | exit 211 | endif 212 | 213 | prev => next 214 | next => next%next 215 | idx = idx + 1 216 | enddo 217 | 218 | end function get_element 219 | 220 | end module linkedlists 221 | 222 | ! test_lists 223 | ! Test the linkedlists module 224 | ! 225 | program test_lists 226 | use linkedlists 227 | 228 | implicit none 229 | 230 | type(linked_list) :: list 231 | type(element_data) :: element 232 | 233 | ! 234 | ! Insert a few data: 235 | ! Inserting them at the head should result in the order 3, 2, 1 236 | ! 237 | element%value = 1; call list%insert( HEAD, element ) 238 | element%value = 2; call list%insert( HEAD, element ) 239 | element%value = 3; call list%insert( HEAD, element ) 240 | 241 | write(*,*) 'Expected order: 3, 2, 1' 242 | call list%print 243 | 244 | ! 245 | ! Add a few elements at the end 246 | element%value = 4; call list%insert( TAIL, element ) 247 | element%value = 5; call list%insert( TAIL, element ) 248 | 249 | write(*,*) 'Expected order: 3, 2, 1, 4, 5' 250 | call list%print 251 | 252 | ! 253 | ! Insert an element in the middle 254 | element%value = 6; call list%insert( 4, element ) 255 | 256 | write(*,*) 'Expected order: 3, 2, 1, 6, 4, 5' 257 | call list%print 258 | 259 | ! 260 | ! Remove the elements at position 4 and at the head 261 | ! 262 | call list%remove( 4 ) 263 | call list%remove( HEAD ) 264 | 265 | write(*,*) 'Expected order: 2, 1, 4, 5' 266 | call list%print 267 | 268 | ! 269 | ! Get the second element 270 | ! 271 | write(*,*) 'Element 2: ', list%get(2) 272 | end program test_lists 273 | -------------------------------------------------------------------------------- /experiments/events.f90: -------------------------------------------------------------------------------- 1 | ! events.f90 -- 2 | ! Module for handling events: to be used for "discrete event modelling" 3 | ! 4 | ! The module defines two classes, basic_event and basic_event_stack, that have 5 | ! a number of methods for storing and retrieving events. These classes should 6 | ! be extended for an actual application. As each event must be a polymorphic 7 | ! item, a dedicated derived type has been introduced. 8 | ! 9 | ! TODO: 10 | ! Make a simple extended class for a "real" application. 11 | ! 12 | module events_library 13 | implicit none 14 | 15 | integer, parameter :: no_event_timestamp = -999 16 | 17 | type basic_event 18 | integer :: timestamp 19 | end type basic_event 20 | 21 | type basic_event_store 22 | class(basic_event), allocatable :: event 23 | end type basic_event_store 24 | 25 | type basic_event_stack 26 | type(basic_event_store), dimension(:), allocatable :: list_events 27 | contains 28 | procedure :: push => push_event 29 | generic :: pop => pop_plain, pop_match 30 | procedure :: pop_plain => pop_event_plain 31 | procedure :: pop_match => pop_event_match 32 | procedure :: number => number_events 33 | end type basic_event_stack 34 | 35 | private :: match_all 36 | 37 | contains 38 | 39 | ! number_event -- 40 | ! Return the number of events 41 | ! 42 | ! Arguments: 43 | ! this Event stack to be used 44 | ! 45 | integer function number_events( this ) 46 | class(basic_event_stack), intent(in) :: this 47 | 48 | integer :: i 49 | 50 | number_events = 0 51 | do i = 1,size(this%list_events) 52 | if ( allocated(this%list_events(i)%event) ) then 53 | number_events = number_events + 1 54 | endif 55 | enddo 56 | end function number_events 57 | 58 | ! push_event -- 59 | ! Push a new event on the stack 60 | ! 61 | ! Arguments: 62 | ! this Event stack to be used 63 | ! event Event to be added 64 | ! 65 | ! Note: 66 | ! The timestamp of the event must be non-negative 67 | ! 68 | subroutine push_event( this, event ) 69 | class(basic_event_stack), intent(inout) :: this 70 | class(basic_event), intent(in) :: event 71 | 72 | integer :: i ,idx 73 | 74 | if ( event%timestamp < 0 ) then 75 | stop 'Incorrect timestamp - must be positive' 76 | endif 77 | 78 | ! 79 | ! To do: extend the array if necessary 80 | ! 81 | if ( .not. allocated(this%list_events) ) then 82 | allocate( this%list_events(10000) ) 83 | endif 84 | 85 | ! 86 | ! Find an unused entry 87 | ! 88 | idx = -1 89 | do i = 1,size(this%list_events) 90 | if ( .not. allocated(this%list_events(i)%event) ) then 91 | idx = i 92 | exit 93 | endif 94 | enddo 95 | 96 | if ( idx == -1 ) then 97 | ! Extend the array of events 98 | stop 'Too many events' 99 | endif 100 | 101 | ! 102 | ! Copy the contents of the event into the array of events 103 | ! (this is done implicitly via the defined assignment) 104 | allocate( this%list_events(idx)%event, source = event ) 105 | 106 | end subroutine push_event 107 | 108 | ! pop_event_match -- 109 | ! Pop an event on the stack - the event with the _smallest_ 110 | ! timestamp that matches the criteria is popped 111 | ! 112 | ! Arguments: 113 | ! this Event stack to be used 114 | ! match Matching procedure 115 | ! event Event to be popped 116 | ! 117 | subroutine pop_event_match( this, match, event ) 118 | class(basic_event_stack), intent(inout) :: this 119 | class(basic_event), allocatable, intent(out) :: event 120 | 121 | interface 122 | logical function match( event ) 123 | import basic_event 124 | class(basic_event), intent(in) :: event 125 | end function match 126 | end interface 127 | 128 | integer :: i ,idx, minimal_time 129 | 130 | ! 131 | ! Find the matching entry with the minimal timestamp 132 | ! 133 | idx = -1 134 | minimal_time = huge(1) 135 | do i = 1,size(this%list_events) 136 | if ( .not. allocated(this%list_events(i)%event) ) then 137 | cycle 138 | endif 139 | 140 | if ( match( this%list_events(i)%event ) ) then 141 | if ( minimal_time > this%list_events(i)%event%timestamp ) then 142 | idx = i 143 | minimal_time = this%list_events(i)%event%timestamp 144 | endif 145 | endif 146 | enddo 147 | 148 | ! 149 | ! Pass the event back and remove it from the stack 150 | ! 151 | if ( idx > -1 ) then 152 | if ( allocated(event) ) then 153 | deallocate( event ) 154 | endif 155 | allocate( event, source = this%list_events(idx)%event ) 156 | deallocate( this%list_events(idx)%event ) 157 | else 158 | event%timestamp = no_event_timestamp 159 | endif 160 | end subroutine pop_event_match 161 | 162 | ! pop_event_plain -- 163 | ! Pop an event on the stack - accepting any event 164 | ! 165 | ! Arguments: 166 | ! this Event stack to be used 167 | ! event Event to be popped 168 | ! 169 | subroutine pop_event_plain( this, event ) 170 | class(basic_event_stack), intent(inout) :: this 171 | class(basic_event), allocatable, intent(out) :: event 172 | 173 | call this%pop( match_all, event ) 174 | end subroutine pop_event_plain 175 | 176 | ! match_all -- 177 | ! Just return .true. - accepting any event 178 | ! 179 | ! Arguments: 180 | ! event Event to be examined 181 | ! 182 | logical function match_all( event ) 183 | class(basic_event), intent(in) :: event 184 | 185 | match_all = .true. 186 | end function match_all 187 | 188 | ! valid_event -- 189 | ! Check if the event is a valid event or not 190 | ! 191 | ! Arguments: 192 | ! event Event to be checked 193 | ! 194 | ! Returns: 195 | ! .true. if the timestamp is non-negative, otherwise .false. 196 | ! 197 | logical function valid_event( event ) 198 | class(basic_event), intent(in) :: event 199 | 200 | valid_event = event%timestamp >= 0 201 | end function valid_event 202 | 203 | end module events_library 204 | -------------------------------------------------------------------------------- /experiments/queue_system.f90: -------------------------------------------------------------------------------- 1 | ! queue_system.f90 -- 2 | ! Simulate a queueing system: 3 | ! One queue, three booths at which the client is served 4 | ! The booths handle a client and ask for the next one 5 | ! 6 | ! Clients take some handling time: 7 | ! 33% take 1 minutes 8 | ! 33% take 2 minutes 9 | ! 33% take 5 minutes 10 | ! 11 | module queue_events 12 | use events_library 13 | 14 | implicit none 15 | 16 | type, extends(basic_event) :: queue_event 17 | integer :: arrival_time = -1 ! Time of arrival of the client 18 | integer :: handling_time = -1 ! Time the client requires for handling their request 19 | end type queue_event 20 | 21 | end module queue_events 22 | 23 | program queue_system 24 | use queue_events 25 | implicit none 26 | 27 | type(basic_event_stack) :: list_events 28 | class(queue_event), allocatable :: event 29 | class(basic_event), allocatable :: event_popped 30 | 31 | type booth_data 32 | integer :: clients_handled = 0 33 | integer :: idle_time = 0 34 | integer :: current_time = 0 35 | end type booth_data 36 | 37 | type(booth_data), dimension(3) :: booth 38 | 39 | integer :: i 40 | integer :: j 41 | integer, dimension(1) :: loc 42 | real :: r 43 | integer :: number, average_number 44 | integer :: time, handling_time 45 | integer :: waiting_time 46 | integer :: cnt 47 | 48 | ! 49 | ! Set up the queue: on average N clients per hour 50 | ! Their arrival is arbitrary over the hour 51 | ! There are eight working hours. 52 | ! 53 | average_number = 20 54 | waiting_time = 0 55 | 56 | allocate( event ) 57 | 58 | ! 59 | ! Random numbers are not always so random, unfortunately, use a 60 | ! naive procedure to get some randomness between runs even if a 61 | ! plain "call random_seed" does not provide this functionality. 62 | ! 63 | call system_clock( cnt ) 64 | call random_seed 65 | 66 | do i = 1,8 67 | do j = 1,mod(cnt,1000) 68 | call random_number( r ) 69 | enddo 70 | number = 2.0 * r * average_number 71 | 72 | ! 73 | ! Distribute them over the hour 74 | ! 75 | do j = 1,number 76 | call random_number( r ) 77 | time = (i-1) * 3600 + 60 * r 78 | 79 | call random_number( r ) 80 | if ( r < 1.0/3.0 ) then 81 | handling_time = 60 82 | elseif ( r < 2.0/3.0 ) then 83 | handling_time = 180 84 | else 85 | handling_time = 300 86 | endif 87 | 88 | event%arrival_time = time 89 | event%handling_time = handling_time 90 | 91 | call list_events%push( event ) 92 | enddo 93 | enddo 94 | 95 | ! 96 | ! Now we have three booths, as long as there are clients 97 | ! they need to be handled 98 | ! 99 | number = list_events%number() 100 | 101 | do i = 1,number 102 | time = minval(booth%current_time) 103 | loc = minloc(booth%current_time) 104 | j = loc(1) 105 | 106 | call list_events%pop_plain( event_popped ) ! Get them in time order 107 | 108 | ! 109 | ! Some trickery is required, it seems 110 | ! 111 | select type (event_popped) 112 | class is (queue_event) 113 | !call move_alloc( event, event_popped ) -- strange error message: event_popped shall be allocatable? 114 | if ( allocated(event) ) then 115 | deallocate( event ) 116 | endif 117 | allocate( event, source = event_popped ) 118 | end select 119 | ! 120 | ! We have a client, handle them: 121 | ! - If the client arrived later than the ready time for the booth, 122 | ! the booth was idle. 123 | ! - Otherwise the client had to wait 124 | ! 125 | if ( booth(j)%current_time < event%arrival_time ) then 126 | booth(j)%idle_time = booth(j)%idle_time + (event%arrival_time - booth(j)%current_time) 127 | booth(j)%current_time = event%arrival_time + event%handling_time 128 | else 129 | waiting_time = waiting_time + (booth(j)%current_time - event%arrival_time) 130 | booth(j)%current_time = booth(j)%current_time + event%handling_time 131 | endif 132 | 133 | booth(j)%clients_handled = booth(j)%clients_handled + 1 134 | 135 | ! write(*,*) j, booth(j) 136 | ! 137 | ! if ( i > 4 ) then 138 | ! exit 139 | ! endif 140 | enddo 141 | 142 | ! 143 | ! Output 144 | ! 145 | write(*,'(a,i0)') 'Number of clients: ', number 146 | write(*,'(a,i0)') 'Total waiting time: ', waiting_time 147 | do j = 1,size(booth) 148 | write(*,'(a,i0)') 'Booth ', j 149 | write(*,'(a,i0)') ' Number of clients: ', booth(j)%clients_handled 150 | write(*,'(a,i0)') ' Idle time: ', booth(j)%idle_time 151 | enddo 152 | 153 | end program queue_system 154 | -------------------------------------------------------------------------------- /experiments/vectorspace.f90: -------------------------------------------------------------------------------- 1 | ! vectorspace.f90 -- 2 | ! Define a module for dealing with vector spaces in an abstract sense 3 | ! 4 | ! The basic data type is an abstract vector, with the following 5 | ! operations: 6 | ! "+" - to add two vectors to get a new vector 7 | ! "*" - to multiply a vector with a scalar 8 | ! We can use an array of vectors as a collection: the operation ".in." 9 | ! determines if a given vector is in that collection. 10 | ! 11 | ! Note: 12 | ! The multiplication does not work as I want, because I need a PASS attribute 13 | ! and that conflicts with some restriction. 14 | ! 15 | ! Attempt without abstract type 16 | ! 17 | module vectorspaces 18 | implicit none 19 | 20 | type :: vector 21 | end type vector 22 | 23 | interface operator(+) 24 | module procedure addition 25 | end interface 26 | 27 | interface operator(*) 28 | module procedure multiplication 29 | end interface 30 | 31 | interface operator(.in.) 32 | module procedure membership 33 | end interface 34 | 35 | contains 36 | function addition( a, b ) 37 | class(vector), intent(in) :: a 38 | class(vector), intent(in) :: b 39 | class(vector), allocatable :: addition 40 | 41 | allocate( addition ) 42 | end function addition 43 | 44 | ! Note: the other way around, did not work :( 45 | function multiplication( a, b ) 46 | real, intent(in) :: a 47 | class(vector), intent(in) :: b 48 | class(vector), allocatable :: multiplication 49 | 50 | allocate( multiplication ) 51 | end function multiplication 52 | 53 | function membership( a, b ) 54 | class(vector), intent(in) :: a 55 | class(vector), intent(in), dimension(:) :: b 56 | logical :: membership 57 | 58 | membership = .false. 59 | end function membership 60 | 61 | end module vectorspaces 62 | 63 | ! 64 | ! Test this with an actual implementation 65 | ! 66 | module vectors_3d 67 | use vectorspaces 68 | 69 | ! type, extends(vector) :: vector_3d 70 | type :: vector_3d 71 | real, dimension(3) :: coords 72 | end type 73 | 74 | interface operator(+) 75 | module procedure add_3d 76 | end interface 77 | 78 | interface operator(*) 79 | module procedure multiply_3d 80 | end interface 81 | 82 | interface operator(.in.) 83 | module procedure is_member_3d 84 | end interface 85 | 86 | contains 87 | function add_3d( a, b ) 88 | type(vector_3d), intent(in) :: a 89 | type(vector_3d), intent(in) :: b 90 | type(vector_3d) :: add_3d 91 | 92 | add_3d%coords = a%coords + b%coords 93 | end function add_3d 94 | 95 | function multiply_3d( a, b ) 96 | real, intent(in) :: a 97 | type(vector_3d), intent(in) :: b 98 | type(vector_3d) :: multiply_3d 99 | 100 | multiply_3d%coords = a * b%coords 101 | end function multiply_3d 102 | 103 | logical function is_member_3d( a, b ) 104 | type(vector_3d), intent(in) :: a 105 | type(vector_3d), intent(in), dimension(:) :: b 106 | 107 | integer :: i 108 | 109 | is_member_3d = .false. 110 | 111 | do i = 1,size(b) 112 | if ( all( a%coords == b(i)%coords ) ) then 113 | is_member_3d = .true. 114 | exit 115 | endif 116 | enddo 117 | end function is_member_3d 118 | 119 | ! coords -- 120 | ! To print the resulting vector, use a "getter" 121 | ! 122 | function coords( a ) 123 | type(vector_3d), intent(in) :: a 124 | real, dimension(3) :: coords 125 | 126 | coords = a%coords 127 | end function coords 128 | 129 | end module vectors_3d 130 | 131 | ! Test program for the vector space modules 132 | ! 133 | ! Note: 134 | ! To keep the program small, there is no facility to manipulate a collection 135 | ! of vectors, but you could add that too. 136 | ! 137 | program test_space 138 | use vectors_3d 139 | 140 | implicit none 141 | 142 | type(vector_3d) :: a, b, c 143 | type(vector_3d), dimension(10) :: vectors 144 | 145 | a = vector_3d( [1.0, 1.0, 1.0] ) 146 | b = vector_3d( [2.0, 2.0, 2.0] ) 147 | c = vector_3d( [3.0, 3.0, 3.0] ) 148 | 149 | vectors = vector_3d( [0.0, 0.0, 0.0] ) ! Primitive initialisation 150 | 151 | vectors(1) = a 152 | vectors(2) = b 153 | 154 | write(*,*) 'Is a in the collection? ', a .in. vectors 155 | write(*,*) 'Is c in the collection? ', c .in. vectors 156 | 157 | vectors(3) = a + b 158 | write(*,*) 'Added the sum of a and b - should be equal to c' 159 | write(*,*) 'Is c in the collection? ', c .in. vectors 160 | 161 | write(*,*) 'a + b = ', coords(a + b) 162 | write(*,*) '10 * c = ', coords(10.0 * c) 163 | 164 | end program test_space 165 | -------------------------------------------------------------------------------- /experiments/vectorspace_abstract.f90: -------------------------------------------------------------------------------- 1 | ! vectorspace.f90 -- 2 | ! Define a module for dealing with vector spaces in an abstract sense 3 | ! 4 | ! The basic data type is an abstract vector, with the following 5 | ! operations: 6 | ! "+" - to add two vectors to get a new vector 7 | ! "*" - to multiply a vector with a scalar 8 | ! We can use an array of vectors as a collection: the operation ".in." 9 | ! determines if a given vector is in that collection. 10 | ! 11 | ! Note: 12 | ! The multiplication does not work as I want, because I need a PASS attribute 13 | ! and that conflicts with some restriction. 14 | ! 15 | module vectorspaces 16 | implicit none 17 | 18 | type, abstract :: vector 19 | contains 20 | private 21 | procedure(addition), deferred :: add 22 | ! This does not work, for some reason: 23 | procedure(multiplication), deferred, pass(b) :: multiply ! Note the "pass(b)" attribute! 24 | procedure(membership), deferred :: is_member 25 | generic, public :: operator(+) => add 26 | generic, public :: operator(*) => multiply 27 | generic, public :: operator(.in.) => is_member 28 | end type vector 29 | 30 | abstract interface 31 | function addition( a, b ) 32 | import :: vector 33 | 34 | class(vector), intent(in) :: a, b 35 | class(vector), allocatable :: addition 36 | end function addition 37 | 38 | function multiplication( a, b ) 39 | import :: vector 40 | 41 | real, intent(in) :: a 42 | class(vector), intent(in) :: b 43 | class(vector), allocatable :: multiplication 44 | end function multiplication 45 | 46 | function membership( a, b ) 47 | import :: vector 48 | 49 | class(vector), intent(in) :: a 50 | class(vector), intent(in), dimension(:) :: b 51 | logical :: membership 52 | end function membership 53 | end interface 54 | end module vectorspaces 55 | 56 | ! 57 | ! Test this with an actual implementation 58 | ! 59 | module vectors_3d 60 | use vectorspaces 61 | 62 | type, extends(vector) :: vector_3d 63 | real, dimension(3) :: coords 64 | contains 65 | procedure :: add => add_3d 66 | procedure, pass(b) :: multiply => multiply_3d !<== Note: pass(b) required! 67 | procedure :: is_member => is_member_3d 68 | end type 69 | 70 | ! Define this explicitly 71 | !interface operator(*) 72 | ! module procedure multiply_3d 73 | !end interface 74 | 75 | interface assignment(=) 76 | module procedure assign_vector_3d 77 | end interface 78 | 79 | contains 80 | function add_3d( a, b ) 81 | class(vector_3d), intent(in) :: a 82 | class(vector), intent(in) :: b 83 | class(vector), allocatable :: add_3d 84 | 85 | allocate( add_3d, mold = a ) 86 | 87 | ! 88 | ! Clumsy, but that is a consequence of the strict typing in Fortran 89 | ! 90 | select type (add_3d) 91 | type is (vector_3d) 92 | select type (b) 93 | type is (vector_3d) 94 | add_3d%coords = a%coords + b%coords 95 | class default 96 | add_3d%coords = [0.0, 0.0, 0.0] ! A run-time error is probably better 97 | end select 98 | end select 99 | end function add_3d 100 | 101 | function multiply_3d( a, b ) 102 | real, intent(in) :: a 103 | class(vector_3d), intent(in) :: b 104 | class(vector), allocatable :: multiply_3d 105 | 106 | allocate( multiply_3d, mold = b ) 107 | 108 | select type (multiply_3d) 109 | type is (vector_3d) 110 | multiply_3d%coords = a * b%coords 111 | end select 112 | 113 | end function multiply_3d 114 | 115 | logical function is_member_3d( a, b ) 116 | class(vector_3d), intent(in) :: a 117 | class(vector), intent(in), dimension(:) :: b 118 | 119 | integer :: i 120 | 121 | is_member_3d = .false. 122 | 123 | select type (b) 124 | type is (vector_3d) 125 | do i = 1,size(b) 126 | if ( all( a%coords == b(i)%coords ) ) then 127 | is_member_3d = .true. 128 | exit 129 | endif 130 | enddo 131 | 132 | class default 133 | ! Always return false! 134 | is_member_3d = .false. 135 | end select 136 | end function is_member_3d 137 | 138 | ! coords -- 139 | ! To print the resulting vector, use a "getter" 140 | ! 141 | function coords( a ) 142 | class(vector), intent(in) :: a 143 | real, dimension(3) :: coords 144 | 145 | select type ( a ) 146 | type is (vector_3d) 147 | coords = a%coords 148 | class default 149 | coords = 0.0 150 | end select 151 | end function coords 152 | 153 | ! assign_vector_3d -- 154 | ! Overcome the discrepancy between vector and vector_3d 155 | ! 156 | subroutine assign_vector_3d( a, b ) 157 | class(vector_3d), intent(out) :: a 158 | class(vector), intent(in) :: b 159 | 160 | select type ( b ) 161 | type is (vector_3d) 162 | a%coords = b%coords 163 | class default 164 | a%coords = 0.0 165 | end select 166 | end subroutine assign_vector_3d 167 | 168 | end module vectors_3d 169 | 170 | ! Test program for the vector space modules 171 | ! 172 | ! Note: 173 | ! To keep the program small, there is no facility to manipulate a collection 174 | ! of vectors, but you could add that too. 175 | ! 176 | program test_space 177 | use vectors_3d 178 | 179 | implicit none 180 | 181 | type(vector_3d) :: a, b, c 182 | type(vector_3d), dimension(10) :: vectors 183 | 184 | a = vector_3d( [1.0, 1.0, 1.0] ) 185 | b = vector_3d( [2.0, 2.0, 2.0] ) 186 | c = vector_3d( [3.0, 3.0, 3.0] ) 187 | 188 | vectors = vector_3d( [0.0, 0.0, 0.0] ) ! Primitive initialisation 189 | 190 | vectors(1) = a 191 | vectors(2) = b 192 | 193 | write(*,*) 'Is a in the collection? ', a .in. vectors 194 | write(*,*) 'Is c in the collection? ', c .in. vectors 195 | 196 | vectors(3) = a + b 197 | write(*,*) 'Added the sum of a and b - should be equal to c' 198 | write(*,*) 'Is c in the collection? ', c .in. vectors 199 | 200 | write(*,*) 'a + b = ', coords(a + b) 201 | write(*,*) '10 * c = ', coords(10.0 * c) 202 | 203 | end program test_space 204 | -------------------------------------------------------------------------------- /experiments/vectorspace_function.f90: -------------------------------------------------------------------------------- 1 | ! vectorspace_function.f90 -- 2 | ! Define a module for dealing with vector spaces in an abstract sense 3 | ! and a specific class for adding and multiplying functions. 4 | ! 5 | ! The basic data type is an abstract vector, with the following 6 | ! operations: 7 | ! "+" - to add two vectors to get a new vector 8 | ! "*" - to multiply a vector with a scalar 9 | ! We can use an array of vectors as a collection: the operation ".in." 10 | ! determines if a given vector is in that collection. 11 | ! 12 | ! Note: 13 | ! The multiplication does not work as I want, because I need a PASS attribute 14 | ! and that conflicts with some restriction. 15 | ! 16 | module vectorspaces 17 | implicit none 18 | 19 | type, abstract :: vector 20 | contains 21 | private 22 | procedure(addition), deferred :: add 23 | ! This does not work, for some reason: 24 | procedure(multiplication), deferred, pass(b) :: multiply ! Note the "pass(b)" attribute! 25 | procedure(membership), deferred :: is_member 26 | generic, public :: operator(+) => add 27 | generic, public :: operator(*) => multiply 28 | generic, public :: operator(.in.) => is_member 29 | end type vector 30 | 31 | abstract interface 32 | function addition( a, b ) 33 | import :: vector 34 | 35 | class(vector), intent(in), target :: a, b !<= We need the target attribute here 36 | class(vector), allocatable :: addition 37 | end function addition 38 | 39 | function multiplication( a, b ) 40 | import :: vector 41 | 42 | real, intent(in) :: a 43 | class(vector), intent(in), target :: b 44 | class(vector), allocatable :: multiplication 45 | end function multiplication 46 | 47 | function membership( a, b ) 48 | import :: vector 49 | 50 | class(vector), intent(in) :: a 51 | class(vector), intent(in), dimension(:) :: b 52 | logical :: membership 53 | end function membership 54 | end interface 55 | end module vectorspaces 56 | 57 | ! 58 | ! Test this with an actual implementation 59 | ! 60 | module vectors_function 61 | use vectorspaces 62 | 63 | type, extends(vector) :: vector_function 64 | real :: factor = 0.0 65 | procedure(f_of_x), nopass, pointer :: f => null() 66 | type(vector_function), pointer :: v1 => null() 67 | type(vector_function), pointer :: v2 => null() 68 | contains 69 | procedure :: add => add_functions 70 | procedure, pass(b) :: multiply => multiply_function !<== Note: pass(b) required! 71 | procedure :: is_member => is_member_dummy 72 | procedure :: eval => eval_function 73 | end type 74 | 75 | interface assignment(=) 76 | module procedure assign_vector_function 77 | end interface 78 | 79 | interface 80 | real function f_of_x( x ) 81 | real, intent(in) :: x 82 | end function f_of_x 83 | end interface 84 | 85 | contains 86 | function add_functions( a, b ) 87 | class(vector_function), intent(in), target :: a 88 | class(vector), intent(in), target :: b 89 | class(vector), allocatable :: add_functions 90 | 91 | allocate( add_functions, mold = a ) 92 | 93 | ! 94 | ! Clumsy, but that is a consequence of the strict typing in Fortran 95 | ! 96 | select type (add_functions) 97 | type is (vector_function) 98 | select type (b) 99 | type is (vector_function) 100 | add_functions%v1 => a 101 | add_functions%v2 => b 102 | class default 103 | add_functions%v1 => null() 104 | add_functions%v2 => null() 105 | end select 106 | end select 107 | end function add_functions 108 | 109 | function multiply_function( a, b ) 110 | real, intent(in) :: a 111 | class(vector_function), intent(in), target :: b 112 | class(vector), allocatable :: multiply_function 113 | 114 | allocate( multiply_function, mold = b ) 115 | 116 | select type (multiply_function) 117 | type is (vector_function) 118 | multiply_function%factor = a 119 | multiply_function%v1 => b 120 | multiply_function%v2 => null() 121 | end select 122 | 123 | end function multiply_function 124 | 125 | ! Dummy - it is possible in principle, but you will have to descend the 126 | ! tree of vectors 127 | logical function is_member_dummy( a, b ) 128 | class(vector_function), intent(in) :: a 129 | class(vector), intent(in), dimension(:) :: b 130 | 131 | is_member_dummy = .false. 132 | 133 | end function is_member_dummy 134 | 135 | ! eval_function -- 136 | ! To evaluate the composite function for a particular value of x 137 | ! 138 | recursive real function eval_function( a, x ) 139 | class(vector_function), intent(in) :: a 140 | real :: x 141 | 142 | if ( associated(a%v2) ) then 143 | eval_function = a%v1%eval(x) + a%v2%eval(x) 144 | elseif ( associated(a%v1) ) then 145 | eval_function = a%factor * a%v1%eval(x) 146 | else if ( associated(a%f) ) then 147 | eval_function = a%f(x) 148 | else 149 | eval_function = 0.0 150 | endif 151 | end function eval_function 152 | 153 | ! assign_vector_function -- 154 | ! Overcome the discrepancy between vector and vector_function 155 | ! 156 | ! Note: 157 | ! This is a rather naive implementation - we should actually 158 | ! so a deep copy to make it robust. 159 | ! 160 | subroutine assign_vector_function( a, b ) 161 | class(vector_function), intent(out) :: a 162 | class(vector), intent(in) :: b 163 | 164 | select type ( b ) 165 | type is (vector_function) 166 | a%factor = b%factor 167 | a%v1 => b%v1 168 | a%v2 => b%v2 169 | class default 170 | a%factor = 0.0 171 | a%v1 => null() 172 | a%v2 => null() 173 | end select 174 | end subroutine assign_vector_function 175 | 176 | subroutine setfunc( a, f ) 177 | class(vector_function), intent(inout) :: a 178 | procedure(f_of_x), pointer :: f 179 | 180 | a%f => f 181 | end subroutine setfunc 182 | 183 | end module vectors_function 184 | 185 | ! Test program for the vector space modules 186 | ! 187 | program test_space 188 | use vectors_function 189 | 190 | implicit none 191 | 192 | type(vector_function) :: a, b, c, d 193 | procedure(f_of_x), pointer :: f 194 | 195 | ! A bit roundabout, but f is a private member 196 | f => sine; call setfunc( a, f ) 197 | f => cosine; call setfunc( b, f ) 198 | 199 | c = a + b 200 | d = 10.0 * c 201 | 202 | write(*,*) 'a at x = 1.0: ', a%eval(1.0) 203 | write(*,*) 'b at x = 1.0: ', b%eval(1.0) 204 | write(*,*) 'c at x = 1.0: ', c%eval(1.0) 205 | write(*,*) 'd at x = 1.0: ', d%eval(1.0) 206 | 207 | contains 208 | real function sine( x ) 209 | real, intent(in) :: x 210 | sine = sin(x) 211 | end function sine 212 | real function cosine( x ) 213 | real, intent(in) :: x 214 | cosine = cos(x) 215 | end function cosine 216 | 217 | end program test_space 218 | -------------------------------------------------------------------------------- /solutions/abstract_framework.f90: -------------------------------------------------------------------------------- 1 | ! abstract_framework.f90 -- 2 | ! Define a "framework" for solving a system of ordinary differential equations 3 | ! 4 | ! 5 | module abstract_framework 6 | implicit none 7 | 8 | integer, parameter :: EULER = 1 9 | integer, parameter :: HEUN = 2 10 | 11 | type, abstract :: ode_system_data 12 | ! Nothing in particular 13 | contains 14 | procedure(evaluate_rhs), deferred :: evaluate 15 | end type ode_system_data 16 | 17 | abstract interface 18 | function evaluate_rhs( this, time, x ) 19 | import :: ode_system_data 20 | class(ode_system_data), intent(in) :: this 21 | real, intent(in) :: time 22 | real, dimension(:), intent(in) :: x 23 | real, dimension(size(x)) :: evaluate_rhs 24 | end function evaluate_rhs 25 | end interface 26 | 27 | type framework_data 28 | integer :: chosen_method ! Taking a shortcut 29 | integer :: luout = -999 30 | real :: print_interval = -999.0 31 | class(ode_system_data), allocatable :: ode_system 32 | contains 33 | procedure :: method => method_system 34 | procedure :: define => define_system 35 | procedure :: print_options => print_options_system 36 | procedure :: solve => solve_system 37 | end type framework_data 38 | 39 | contains 40 | 41 | ! method_system -- 42 | ! Select a method for integration 43 | ! 44 | ! Arguments: 45 | ! framework The framework that should hold the system 46 | ! method Selected method ((EULER or HEUN) 47 | ! 48 | ! Note: 49 | ! A bit of laziness, probably more in line with OO if you implement 50 | ! it via a separate class or a procedure pointer. 51 | ! 52 | subroutine method_system( framework, method ) 53 | class(framework_data), intent(inout) :: framework 54 | integer, intent(in) :: method 55 | 56 | select case (method) 57 | case (EULER, HEUN) 58 | framework%chosen_method = method 59 | case default 60 | write(*,*) 'Unknown method: ', method, ' - using EULER' 61 | framework%chosen_method = EULER 62 | end select 63 | 64 | end subroutine method_system 65 | 66 | ! print_options_system -- 67 | ! Set the output options 68 | ! 69 | ! Arguments: 70 | ! framework The framework that should hold the system 71 | ! luout LU-number to write to 72 | ! interval Print interval 73 | ! 74 | subroutine print_options_system( framework, luout, interval ) 75 | class(framework_data), intent(inout) :: framework 76 | integer, intent(in) :: luout 77 | real, intent(in) :: interval 78 | 79 | framework%luout = luout 80 | framework%print_interval = interval 81 | 82 | end subroutine print_options_system 83 | 84 | ! define_system -- 85 | ! Store the object that defines the system of equations 86 | ! 87 | ! Arguments: 88 | ! framework The framework that should hold the system 89 | ! system The ODE system object 90 | ! 91 | subroutine define_system( framework, system ) 92 | class(framework_data), intent(inout) :: framework 93 | class(ode_system_data), intent(in) :: system 94 | 95 | if ( allocated(framework%ode_system) ) then 96 | deallocate( framework%ode_system ) 97 | endif 98 | 99 | allocate( framework%ode_system, source = system ) ! Safest: changes to the ODE system do not affect the framework 100 | 101 | end subroutine define_system 102 | 103 | ! solve_system -- 104 | ! Actually solve the system, return the end result 105 | ! 106 | ! Arguments: 107 | ! framework The framework that should hold the system 108 | ! tbegin Start time 109 | ! tend Stop time 110 | ! dt Time step 111 | ! xbegin X-vector at start 112 | ! xend X-vector at end 113 | ! 114 | ! Note: 115 | ! Too lazy to implemen the Heun method 116 | ! 117 | subroutine solve_system( framework, tbegin, tend, dt, xbegin, xend ) 118 | class(framework_data), intent(inout) :: framework 119 | real, intent(in) :: tbegin, tend, dt 120 | real, dimension(:), intent(in) :: xbegin 121 | real, dimension(:), intent(out) :: xend 122 | 123 | real, dimension(size(xbegin)) :: dx 124 | real :: time, time_print 125 | 126 | if ( framework%chosen_method /= EULER ) then 127 | write(*,*) 'Sorry, only EULER has been implemented' 128 | stop 129 | endif 130 | 131 | time = tbegin 132 | time_print = tbegin 133 | xend = xbegin 134 | 135 | 136 | do while ( time < tend+0.5*dt ) 137 | if ( abs(time - time_print ) < 0.5*dt ) then 138 | write( framework%luout, '(e12.4,5e12.4,/,(12x,5e12.4))' ) time, xend 139 | time_print = time_print + framework%print_interval 140 | endif 141 | 142 | if ( framework%chosen_method == EULER ) then 143 | dx = framework%ode_system%evaluate( time, xend ) 144 | 145 | xend = xend + dt * dx 146 | time = time + dt 147 | endif 148 | enddo 149 | 150 | end subroutine solve_system 151 | 152 | end module abstract_framework 153 | 154 | 155 | ! oscilator -- 156 | ! Oscillator system 157 | ! 158 | module oscillator 159 | use abstract_framework 160 | implicit none 161 | 162 | type, extends(ode_system_data) :: ode_oscillator 163 | real :: k, r 164 | contains 165 | procedure :: evaluate => evaluate_oscillator 166 | end type ode_oscillator 167 | 168 | contains 169 | 170 | ! evaluate_oscillator -- 171 | ! Calculate the rhs for the oscillator system 172 | ! 173 | function evaluate_oscillator( this, time, x ) 174 | class(ode_oscillator), intent(in) :: this 175 | real, intent(in) :: time 176 | real, dimension(:), intent(in) :: x 177 | real, dimension(size(x)) :: evaluate_oscillator 178 | 179 | evaluate_oscillator(1) = x(2) ! Velocity 180 | evaluate_oscillator(2) = - this%k * x(1) - this%r * x(2) ! Acceleration 181 | end function evaluate_oscillator 182 | 183 | end module oscillator 184 | 185 | ! demo_framework -- 186 | ! Demonstrate the framework 187 | ! 188 | program demo_framework 189 | use iso_fortran_env, only: output_unit 190 | use abstract_framework 191 | use oscillator 192 | 193 | implicit none 194 | 195 | type(ode_oscillator) :: damped_oscillator 196 | type(framework_data) :: framework 197 | real, dimension(2) :: xbegin, xend 198 | 199 | ! 200 | ! Define the system and solve it 201 | ! 202 | damped_oscillator%k = 1.0 203 | damped_oscillator%r = 0.2 204 | 205 | call framework%define( damped_oscillator ) 206 | call framework%method( EULER ) 207 | call framework%print_options( output_unit, 0.1 ) 208 | 209 | xbegin = [ 1.0, 0.0 ] 210 | call framework%solve( 0.0, 20.0, 0.01, xbegin, xend ) 211 | 212 | write(*,*) 'Xbegin: ', xbegin 213 | write(*,*) 'Xend: ', xend 214 | end program demo_framework 215 | -------------------------------------------------------------------------------- /solutions/moving_average.f90: -------------------------------------------------------------------------------- 1 | ! moving_average.f90 -- 2 | ! Class for moving averages 3 | ! 4 | ! Straightforward version: 5 | ! Use a "circular" buffer to store the values 6 | ! 7 | module moving_averages 8 | use ieee_arithmetic 9 | 10 | implicit none 11 | 12 | type :: moving_average 13 | integer :: window_size ! Maximum number of data in the window for averaging 14 | integer :: number_data ! Number of data available for the average 15 | integer :: idx ! Index of the last value that was added to the buffer 16 | real, dimension(:), allocatable :: buffer 17 | contains 18 | procedure :: initialise => initialise_ma 19 | procedure :: add => add_ma 20 | procedure :: average => average_ma 21 | end type moving_average 22 | 23 | contains 24 | 25 | ! initialise_ma -- 26 | ! Initialise the object for moving averages 27 | ! 28 | ! Arguments: 29 | ! this Object to be initialised 30 | ! number Window size 31 | ! 32 | subroutine initialise_ma( this, number ) 33 | class(moving_average), intent(inout) :: this 34 | integer, intent(in) :: number 35 | 36 | this%window_size = number 37 | this%number_data = 0 38 | this%idx = 0 39 | 40 | ! 41 | ! Clean up the buffer - do not reuse it for simplicity 42 | ! 43 | if ( allocated( this%buffer ) ) then 44 | deallocate( this%buffer ) 45 | endif 46 | 47 | allocate( this%buffer(number) ) 48 | end subroutine initialise_ma 49 | 50 | ! add_ma -- 51 | ! Add a new value to the object 52 | ! 53 | ! Arguments: 54 | ! this Object to be initialised 55 | ! value Value to be added 56 | ! 57 | subroutine add_ma( this, value ) 58 | class(moving_average), intent(inout) :: this 59 | real, intent(in) :: value 60 | 61 | this%idx = 1 + mod( this%idx, this%window_size ) 62 | this%buffer(this%idx) = value 63 | this%number_data = min( this%number_data+1, this%window_size ) 64 | end subroutine add_ma 65 | 66 | ! average_ma -- 67 | ! Return the average of the current buffer - the moving average 68 | ! 69 | ! Arguments: 70 | ! this Object to be initialised 71 | ! 72 | real function average_ma( this ) 73 | class(moving_average), intent(inout) :: this 74 | 75 | if ( this%number_data > 0 ) then 76 | average_ma = sum( this%buffer(1:this%number_data) ) / this%number_data 77 | else 78 | average_ma = ieee_value( average_ma, ieee_quiet_nan ) 79 | endif 80 | end function average_ma 81 | 82 | end module moving_averages 83 | 84 | ! test_ma 85 | ! Simpel test program 86 | ! 87 | program test_ma 88 | use moving_averages 89 | 90 | implicit none 91 | 92 | type(moving_average) :: ma 93 | integer :: i 94 | real :: value 95 | 96 | ! 97 | ! If all values are the same, then the moving average must be the same 98 | ! 99 | call ma%initialise( 10 ) 100 | 101 | do i = 1,20 102 | value = 1.0 103 | call ma%add( value ) 104 | write(*,*) i, ma%average() 105 | enddo 106 | 107 | ! 108 | ! Now alternating values ... Re-initialise the object 109 | ! 110 | call ma%initialise( 10 ) 111 | 112 | do i = 1,20 113 | value = (-1.0) ** i 114 | call ma%add( value ) 115 | write(*,*) i, ma%average() 116 | enddo 117 | 118 | end program test_ma 119 | -------------------------------------------------------------------------------- /solutions/moving_average_alt.f90: -------------------------------------------------------------------------------- 1 | ! moving_average_alt.f90 -- 2 | ! Class for moving averages 3 | ! 4 | ! Straightforward version: 5 | ! Use a "growing" buffer 6 | ! 7 | module moving_averages_alt 8 | use ieee_arithmetic 9 | 10 | implicit none 11 | 12 | type :: moving_average 13 | integer :: window_size ! Maximum number of data in the window for averaging 14 | real, dimension(:), allocatable :: buffer 15 | contains 16 | procedure :: initialise => initialise_ma 17 | procedure :: add => add_ma 18 | procedure :: average => average_ma 19 | end type moving_average 20 | 21 | contains 22 | 23 | ! initialise_ma -- 24 | ! Initialise the object for moving averages 25 | ! 26 | ! Arguments: 27 | ! this Object to be initialised 28 | ! number Window size 29 | ! 30 | subroutine initialise_ma( this, number ) 31 | class(moving_average), intent(inout) :: this 32 | integer, intent(in) :: number 33 | 34 | this%window_size = number 35 | 36 | ! 37 | ! Clean up the buffer - do not reuse it for simplicity 38 | ! 39 | if ( allocated( this%buffer ) ) then 40 | deallocate( this%buffer ) 41 | endif 42 | 43 | allocate( this%buffer(0) ) 44 | end subroutine initialise_ma 45 | 46 | ! add_ma -- 47 | ! Add a new value to the object 48 | ! 49 | ! Arguments: 50 | ! this Object to be initialised 51 | ! value Value to be added 52 | ! 53 | subroutine add_ma( this, value ) 54 | class(moving_average), intent(inout) :: this 55 | real, intent(in) :: value 56 | 57 | if ( size(this%buffer) < this%window_size ) then 58 | this%buffer = [ this%buffer, value ] 59 | else 60 | this%buffer = [ this%buffer(2:), value ] 61 | endif 62 | end subroutine add_ma 63 | 64 | ! average_ma -- 65 | ! Return the average of the current buffer - the moving average 66 | ! 67 | ! Arguments: 68 | ! this Object to be initialised 69 | ! 70 | real function average_ma( this ) 71 | class(moving_average), intent(inout) :: this 72 | 73 | if ( size(this%buffer) > 0 ) then 74 | average_ma = sum( this%buffer ) / size(this%buffer) 75 | else 76 | average_ma = ieee_value( average_ma, ieee_quiet_nan ) 77 | endif 78 | end function average_ma 79 | 80 | end module moving_averages_alt 81 | 82 | ! test_ma 83 | ! Simpel test program 84 | ! 85 | program test_ma 86 | use moving_averages_alt 87 | 88 | implicit none 89 | 90 | type(moving_average) :: ma 91 | integer :: i 92 | real :: value 93 | 94 | ! 95 | ! If all values are the same, then the moving average must be the same 96 | ! 97 | call ma%initialise( 10 ) 98 | 99 | do i = 1,20 100 | value = 1.0 101 | call ma%add( value ) 102 | write(*,*) i, ma%average() 103 | enddo 104 | 105 | ! 106 | ! Now alternating values ... Re-initialise the object 107 | ! 108 | call ma%initialise( 10 ) 109 | 110 | do i = 1,20 111 | value = (-1.0) ** i 112 | call ma%add( value ) 113 | write(*,*) i, ma%average() 114 | enddo 115 | 116 | end program test_ma 117 | -------------------------------------------------------------------------------- /solutions/moving_average_shift.f90: -------------------------------------------------------------------------------- 1 | ! moving_average_shift.f90 -- 2 | ! Class for moving averages 3 | ! 4 | ! Straightforward version: 5 | ! Use cshift to move the data in the buffer 6 | ! 7 | module moving_averages_shift 8 | use ieee_arithmetic 9 | 10 | implicit none 11 | 12 | type :: moving_average 13 | integer :: window_size ! Maximum number of data in the window for averaging 14 | integer :: number_data ! Number of data available for the average 15 | integer :: idx ! Index of the last value that was added to the buffer 16 | real, dimension(:), allocatable :: buffer 17 | contains 18 | procedure :: initialise => initialise_ma 19 | procedure :: add => add_ma 20 | procedure :: average => average_ma 21 | end type moving_average 22 | 23 | contains 24 | 25 | ! initialise_ma -- 26 | ! Initialise the object for moving averages 27 | ! 28 | ! Arguments: 29 | ! this Object to be initialised 30 | ! number Window size 31 | ! 32 | subroutine initialise_ma( this, number ) 33 | class(moving_average), intent(inout) :: this 34 | integer, intent(in) :: number 35 | 36 | this%window_size = number 37 | this%number_data = 0 38 | this%idx = 0 39 | 40 | ! 41 | ! Clean up the buffer - do not reuse it for simplicity 42 | ! 43 | if ( allocated( this%buffer ) ) then 44 | deallocate( this%buffer ) 45 | endif 46 | 47 | allocate( this%buffer(number) ) 48 | 49 | this%buffer = 0.0 50 | end subroutine initialise_ma 51 | 52 | ! add_ma -- 53 | ! Add a new value to the object 54 | ! 55 | ! Arguments: 56 | ! this Object to be initialised 57 | ! value Value to be added 58 | ! 59 | subroutine add_ma( this, value ) 60 | class(moving_average), intent(inout) :: this 61 | real, intent(in) :: value 62 | 63 | this%buffer = cshift(this%buffer, -1) 64 | this%buffer(1) = value 65 | this%number_data = min( this%number_data+1, this%window_size ) 66 | 67 | end subroutine add_ma 68 | 69 | ! average_ma -- 70 | ! Return the average of the current buffer - the moving average 71 | ! 72 | ! Arguments: 73 | ! this Object to be initialised 74 | ! 75 | real function average_ma( this ) 76 | class(moving_average), intent(inout) :: this 77 | 78 | if ( this%number_data > 0 ) then 79 | average_ma = sum( this%buffer(1:this%number_data) ) / this%number_data 80 | else 81 | average_ma = ieee_value( average_ma, ieee_quiet_nan ) 82 | endif 83 | end function average_ma 84 | 85 | end module moving_averages_shift 86 | 87 | ! test_ma 88 | ! Simpel test program 89 | ! 90 | program test_ma 91 | use moving_averages_shift 92 | 93 | implicit none 94 | 95 | type(moving_average) :: ma 96 | integer :: i 97 | real :: value 98 | 99 | ! 100 | ! If all values are the same, then the moving average must be the same 101 | ! 102 | call ma%initialise( 10 ) 103 | 104 | do i = 1,20 105 | value = 1.0 106 | call ma%add( value ) 107 | write(*,*) i, ma%average() 108 | enddo 109 | 110 | ! 111 | ! Now alternating values ... Re-initialise the object 112 | ! 113 | call ma%initialise( 10 ) 114 | 115 | do i = 1,20 116 | value = (-1.0) ** i 117 | call ma%add( value ) 118 | write(*,*) i, ma%average() 119 | enddo 120 | 121 | end program test_ma 122 | -------------------------------------------------------------------------------- /solutions/readme.txt: -------------------------------------------------------------------------------- 1 | General remarks: 2 | --------------- 3 | 4 | The exercises have been described in the accompanying document 5 | "exercises.pdf". All in all, doing these exercises from scratch may take 6 | a few hours -- the exercises are not, in themselves, complicated, and 7 | the sample solutions given here only take up a few hundred lines of 8 | code, including the comments. It is simply that you have to think about 9 | how to implement what is being asked and then type in the code, 10 | build the program and correct any mistakes. 11 | 12 | 13 | Moving average: 14 | -------------- 15 | 16 | The implementation is straightforward: no attempt to change the window 17 | and retain the existing data. No extended version, but that should be 18 | little more than extending the base type with a few methods. 19 | 20 | Three versions: 21 | - Use a fixed buffer that acts as a circular buffer. Probably the most 22 | efficient version: no data movement, only individual elements 23 | replaced. 24 | 25 | - Alternative version that lets the buffer grow. The "advantage" is that 26 | you need very little additional data - the buffer and the maximum size 27 | is all. 28 | 29 | - Alternative version that shifts the previous values and sets the new 30 | value as the first value of the buffer. No need to keep track of 31 | an insertion point like with the first version. 32 | 33 | If you ask for the moving average without having added any data, then a 34 | NaN is returned. 35 | 36 | 37 | Universal storage: 38 | ----------------- 39 | 40 | The implementation is not very smart: you have to keep track of the 41 | index where an item is stored and at initialisation time you specify the 42 | maximum number of items that can be stored, which cannot be 43 | extended. 44 | 45 | A more important issue is that the retrieval routines are type-specific: 46 | for any type you want to store you need a separate routine, due to the 47 | fact that Fortran has no straightforward generic programming features. 48 | 49 | You could retrieve the data via an unlimited polymorphic variable, but 50 | that must be converted into a specific type at some point. 51 | 52 | 53 | Replicating objects: 54 | ------------------- 55 | 56 | The objects do not have much "behaviour" or attributes -- the 57 | implementation could be more consistent in hiding the attributes in each 58 | object (type item_data) and providing suitable methods for retrieving 59 | and setting them. 60 | 61 | There is no need to allocate them one by one (though that is certainly 62 | an option for implementing this exercise). Instead we use a simple 63 | attribute to see if the item is "alive". 64 | 65 | The method step_simulation is a trifle lengthy, especially the loop to 66 | "spawn" the items, it could be put in a separate routine. 67 | 68 | The ASSOCIATE construct is used to shorten the fairly lengthy expression 69 | to get to the attributes of the items. 70 | 71 | The mortality rate in the example is 0.118 -- a rather arbitrary seeming 72 | number, but it gives a simulation that is very near to the boundary 73 | between a decaying population and an ever-expanding one. Might be 74 | interesting to try and find a mathematical theory for this ... 75 | 76 | 77 | Thermostat: 78 | ---------- 79 | 80 | The sample implementation of the thermostat system is quite 81 | straightforward: 82 | 83 | - Two objects of the type "temperature_data" are used for the outside 84 | temperature and the set temperature for the room. They each use a 85 | specific routine to determine the temperature in question. 86 | 87 | - One object that determines whether the heating should be turned on or 88 | not. It is a very straightforward object, a more sophisticated version 89 | might want to know the time of day and keep track of the 90 | actual temperature in the room etc. to anticipate the required 91 | heating. That means an extension of the interface. 92 | 93 | The simulation loop is very simple: it uses the Euler method for 94 | integrating the differential equation. All coefficients have been 95 | determined with some trial and error to get interesting behaviour. There 96 | was no attempt to make them realistic. 97 | 98 | 99 | Abstract framework: 100 | ------------------ 101 | 102 | There are a few shortcuts in the implementation: 103 | 104 | - Only the Euler method for integration is implemented. 105 | 106 | - It is implemented as a simple case. A more ambitious implementation 107 | would be to use a procedure pointer, pointing to separate routines 108 | or a set of classes, extending from a common class. That is left as 109 | a further exercise. 110 | 111 | The ODE system to be used is in a separate module, as an internal 112 | routine for evaluate_oscillator was not accepted by the gfortran 113 | compiler. 114 | 115 | The implementation does not take care of the case where no print options 116 | are defined or where the framework has not been properly initialised 117 | with an actual ODE system. Its purpose is to demonstrate the power of 118 | object-oriented programming in Fortran, not to provide a ready-made 119 | framework. 120 | -------------------------------------------------------------------------------- /solutions/replicating_objects.f90: -------------------------------------------------------------------------------- 1 | ! replicating_objects.f90 -- 2 | ! Objects that "disappear" (die) and replicate: 3 | ! - an object has a certain chance to survive the time step 4 | ! - if an object is old enough, it splits into two new objects 5 | ! 6 | ! We start the simulation with a number of objects and stop 7 | ! when a maximum is reached or when there are no more objects 8 | ! alive. 9 | ! 10 | ! Objects are characterised by their "age", the number of 11 | ! time steps they have been active and the fact that they 12 | ! are active (alive). We do not need to keep track of them 13 | ! as independent items - we can simply use an array of the 14 | ! right type and associated methods. 15 | ! 16 | ! An overall object keeps track of the simulation. 17 | ! 18 | ! All items have the same probability to survive and will 19 | ! replicate at the same age, so these properties go with 20 | ! simulation object. 21 | ! 22 | module replication 23 | implicit none 24 | 25 | type item_data 26 | logical :: alive ! Whether the item is alive 27 | integer :: age ! The time it has been alive 28 | contains 29 | procedure :: die => inactivate ! Inactivate the item 30 | procedure :: ready_to_spawn => old_enough ! Check if the item is old enough 31 | procedure :: create => reset_item ! Renew an item 32 | end type item_data 33 | 34 | type simulation_data 35 | logical :: full ! Whether the array of items reached full capacity or not 36 | integer :: maxage ! Maximum age for items - at which they will spawn 37 | real :: mortality ! The probability that an item will "die" 38 | type(item_data), dimension(:), allocatable :: item 39 | contains 40 | procedure :: setup => setup_simulation 41 | procedure :: continue => continue_simulation 42 | procedure :: step => step_simulation 43 | procedure :: report => report_simulation 44 | end type simulation_data 45 | 46 | contains 47 | 48 | ! inactivate -- 49 | ! Set the attribute "alive" to .false. and set the age to zero 50 | ! 51 | ! Arguments: 52 | ! this The item in question 53 | ! 54 | subroutine inactivate( this ) 55 | class(item_data), intent(inout) :: this 56 | 57 | this%alive = .false. 58 | this%age = 0 59 | end subroutine inactivate 60 | 61 | ! old_enough -- 62 | ! Determine whether the item is old enough 63 | ! 64 | ! Arguments: 65 | ! this The item in question 66 | ! maxage Maximum age 67 | ! 68 | logical function old_enough( this, maxage ) 69 | class(item_data), intent(in) :: this 70 | integer, intent(in) :: maxage 71 | 72 | old_enough = this%age >= maxage 73 | end function old_enough 74 | 75 | ! reset_item -- 76 | ! Reset the item 77 | ! 78 | ! Arguments: 79 | ! this The item in question 80 | ! 81 | subroutine reset_item( this ) 82 | class(item_data), intent(out) :: this 83 | 84 | this%alive = .true. 85 | this%age = 0 86 | end subroutine reset_item 87 | 88 | ! setup_simulation -- 89 | ! Set up the simulation 90 | ! 91 | ! Arguments: 92 | ! this The simulation object 93 | ! maxnumber Maximum number of items at any one time 94 | ! initial Initial number of items 95 | ! maxage Maximum age for items 96 | ! mortality Mortality rate for items 97 | ! 98 | subroutine setup_simulation( simulation, maxnumber, initial, maxage, mortality ) 99 | class(simulation_data), intent(inout) :: simulation 100 | integer, intent(in) :: maxnumber 101 | integer, intent(in) :: initial 102 | integer, intent(in) :: maxage 103 | real, intent(in) :: mortality 104 | 105 | integer :: i 106 | 107 | simulation%full = .false. 108 | simulation%maxage = maxage 109 | simulation%mortality = mortality 110 | allocate( simulation%item(maxnumber) ) 111 | 112 | do i = 1,maxnumber 113 | call simulation%item(i)%die 114 | enddo 115 | 116 | do i = 1,initial 117 | call simulation%item(i)%create 118 | enddo 119 | end subroutine setup_simulation 120 | 121 | ! continue_simulation -- 122 | ! Can the simulation continue? (Any objects alive? Room for more?) 123 | ! 124 | ! Arguments: 125 | ! this The simulation object 126 | ! maxnumber Maximum number of items at any one time 127 | ! initial Initial number of items 128 | ! maxage Maximum age for items 129 | ! mortality Mortality rate for items 130 | ! 131 | logical function continue_simulation( simulation ) 132 | class(simulation_data), intent(in) :: simulation 133 | 134 | continue_simulation = count( simulation%item%alive ) > 0 .and. .not. simulation%full 135 | end function continue_simulation 136 | 137 | ! step_simulation -- 138 | ! Do a time step 139 | ! 140 | ! Arguments: 141 | ! this The simulation object 142 | ! 143 | subroutine step_simulation( simulation ) 144 | class(simulation_data), intent(inout) :: simulation 145 | 146 | integer :: i, j 147 | logical :: found 148 | real :: p 149 | 150 | do i = 1,size(simulation%item) 151 | associate( item => simulation%item(i), other_items => simulation%item ) 152 | if ( item%alive ) then 153 | item%age = item%age + 1 154 | 155 | if ( item%ready_to_spawn( simulation%maxage ) ) then 156 | call item%create 157 | 158 | ! 159 | ! Find a "dead" item 160 | ! 161 | found = .false. 162 | do j = 1,size(simulation%item) 163 | if ( .not. other_items(j)%alive ) then 164 | call other_items(j)%create 165 | found = .true. 166 | exit 167 | endif 168 | enddo 169 | 170 | ! 171 | ! If no item could be created, stop the simulation 172 | ! 173 | if ( .not. found ) then 174 | simulation%full = .true. 175 | exit 176 | endif 177 | endif 178 | 179 | ! 180 | ! Does the item survive? 181 | ! 182 | call random_number( p ) 183 | 184 | if ( p < simulation%mortality ) then 185 | call item%die 186 | endif 187 | endif 188 | end associate 189 | enddo 190 | end subroutine step_simulation 191 | 192 | ! report_simulation -- 193 | ! Write some statistics 194 | ! 195 | ! Arguments: 196 | ! this The simulation object 197 | ! step Simulation step 198 | ! 199 | subroutine report_simulation( simulation, step ) 200 | class(simulation_data), intent(in) :: simulation 201 | integer, intent(in) :: step 202 | 203 | integer :: number_items, number_new 204 | 205 | number_items = count( simulation%item%alive ) 206 | number_new = count( simulation%item%alive .and. simulation%item%age == 0 ) 207 | 208 | write(*,'(5i5)') step, number_items, number_new 209 | 210 | end subroutine report_simulation 211 | 212 | end module replication 213 | 214 | ! demo -- 215 | ! Demonstrate the program 216 | ! 217 | program demo_replication 218 | use replication 219 | 220 | implicit none 221 | 222 | integer :: i 223 | type(simulation_data) :: simulation 224 | 225 | call simulation%setup( 100, 10, 5, 0.118 ) 226 | 227 | i = 0 228 | do while( simulation%continue() .and. i < 100 ) 229 | i = i + 1 230 | 231 | call simulation%step 232 | call simulation%report( i ) 233 | enddo 234 | end program demo_replication 235 | -------------------------------------------------------------------------------- /solutions/thermostat.f90: -------------------------------------------------------------------------------- 1 | ! thermostat.f90 -- 2 | ! Straightforward implementation of a thermostat system 3 | ! 4 | module thermostat_simulation 5 | implicit none 6 | 7 | ! 8 | ! Class for external temperatures 9 | ! 10 | type temperature_data 11 | procedure(get_temperature), pointer, nopass :: get_temp 12 | contains 13 | procedure :: set => set_procpointer 14 | procedure :: temp => temperature_value 15 | end type temperature_data 16 | 17 | abstract interface 18 | subroutine get_temperature( time, temp ) 19 | implicit none 20 | real, intent(in) :: time ! Time in days 21 | real, intent(out) :: temp ! Set temperature 22 | end subroutine get_temperature 23 | end interface 24 | 25 | ! 26 | ! Class for the heating device 27 | ! 28 | type heating_data 29 | real :: max_flux 30 | contains 31 | procedure :: hflux => heatflux 32 | procedure :: capacity => set_capacity 33 | end type heating_data 34 | 35 | contains 36 | 37 | ! set_procpointer -- 38 | ! Store the pointer to the method to retrieve the set temperature 39 | ! 40 | ! Arguments: 41 | ! this Object for external temperatures 42 | ! proc Name of the subroutine to be used 43 | ! 44 | subroutine set_procpointer( this, proc ) 45 | class(temperature_data), intent(inout) :: this 46 | procedure(get_temperature) :: proc 47 | 48 | this%get_temp => proc 49 | end subroutine set_procpointer 50 | 51 | ! temperature_value -- 52 | ! Retrieve the temperature value as known by the object 53 | ! 54 | ! Arguments: 55 | ! this Object for external temperatures 56 | ! time Time in the simulation 57 | ! 58 | real function temperature_value( this, time ) 59 | class(temperature_data), intent(inout) :: this 60 | real, intent(in) :: time 61 | 62 | call this%get_temp( time, temperature_value ) 63 | end function temperature_value 64 | 65 | ! set_capacity -- 66 | ! Set the capacity for a heating device 67 | ! 68 | ! Arguments: 69 | ! this Heating device 70 | ! capacity Capacity of the device 71 | ! 72 | subroutine set_capacity( this, capacity ) 73 | class(heating_data), intent(inout) :: this 74 | real, intent(in) :: capacity 75 | 76 | this%max_flux = capacity 77 | end subroutine set_capacity 78 | 79 | ! heatflux -- 80 | ! Determine the heat flux 81 | ! 82 | ! Arguments: 83 | ! this Heating device 84 | ! tempdiff Temperature difference 85 | ! 86 | real function heatflux( this, tempdiff ) 87 | class(heating_data), intent(inout) :: this 88 | real, intent(in) :: tempdiff 89 | 90 | heatflux = merge( this%max_flux, 0.0, tempdiff < 0.0 ) 91 | end function heatflux 92 | 93 | end module thermostat_simulation 94 | 95 | 96 | ! demo_thermostat -- 97 | ! Demostration program: 98 | ! - The room temperature to be achieved is a function of the time of day 99 | ! - The outside temperature is a function of the time of year 100 | ! 101 | program demo_thermostat 102 | use thermostat_simulation 103 | 104 | implicit none 105 | 106 | type(temperature_data) :: set_room_temp 107 | type(temperature_data) :: outside_temp 108 | type(heating_data) :: heater 109 | 110 | real :: room_temp, dtemp 111 | real :: dt, time 112 | real :: hexch 113 | 114 | ! 115 | ! Set the methods for retrieving the relevant temperature data 116 | ! 117 | call set_room_temp%set( room_program ) 118 | call outside_temp%set( seasonal_temperature ) 119 | 120 | call heater%capacity( 12.5 ) 121 | 122 | ! 123 | ! Rather arbitrary value for the heat exchange coefficient with 124 | ! outside world. This value means that the room will cool down 125 | ! in about two days (0.5/day => 2 days) 126 | ! 127 | hexch = 0.5 128 | ! 129 | ! Run the simulation ... 130 | ! 131 | room_temp = 0.0 132 | 133 | dt = 0.06 / 24.0 ! six-minutes' time step 134 | time = 0.0 135 | 136 | do while ( time < 20.0 ) 137 | dtemp = hexch * ( outside_temp%temp(time) - room_temp ) + heater%hflux( room_temp - set_room_temp%temp(time) ) 138 | room_temp = room_temp + dt * dtemp 139 | 140 | write(*,*) time, room_temp, set_room_temp%temp(time), outside_temp%temp(time) 141 | 142 | time = time + dt 143 | enddo 144 | 145 | contains 146 | subroutine room_program( time, temp ) 147 | real, intent(in) :: time 148 | real, intent(out) :: temp 149 | 150 | real :: tday 151 | 152 | tday = 24.0 * mod(time, 1.0) ! Time of day 153 | 154 | if ( tday < 7.0 .or. tday > 23.0 ) then 155 | temp = 0.0 ! Effectively no particular temperature set 156 | else 157 | temp = 19.0 ! Keep the room temperature at an agreeable level 158 | endif 159 | end subroutine room_program 160 | 161 | subroutine seasonal_temperature( time, temp ) 162 | real, intent(in) :: time 163 | real, intent(out) :: temp 164 | 165 | real :: tday 166 | 167 | temp = 15.0 - 15.0 * cos( time / 365.0 ) 168 | end subroutine seasonal_temperature 169 | 170 | end program demo_thermostat 171 | -------------------------------------------------------------------------------- /solutions/universal_storage.f90: -------------------------------------------------------------------------------- 1 | ! universal_storage.f90 -- 2 | ! Module for storing data of "any" type 3 | ! 4 | ! Taking a simple approach: there is simply an 5 | ! array of fixed size within which we store the 6 | ! data. 7 | ! 8 | ! You can store the data in any element -- you 9 | ! will have to keep track of the index yourself 10 | ! 11 | ! Notes: 12 | ! - The data that can be stored are *scalars* 13 | ! - The get routines are, unfortunately, type-specific 14 | ! 15 | module universal_storages 16 | implicit none 17 | 18 | type storage_element 19 | class(*), allocatable :: data 20 | end type storage_element 21 | 22 | type universal_storage 23 | type(storage_element), dimension(:), allocatable :: element 24 | contains 25 | procedure :: initialise => initialise_storage 26 | procedure :: add => add_storage 27 | procedure :: get_int => get_storage_int 28 | procedure :: get_real => get_storage_real 29 | generic :: get => get_int, get_real 30 | end type universal_storage 31 | 32 | contains 33 | 34 | ! initialise_storage -- 35 | ! Initialise the storage 36 | ! 37 | ! Arguments: 38 | ! this Storage object to be initialised 39 | ! capacity Number of data that can be stored 40 | ! 41 | subroutine initialise_storage( this, capacity ) 42 | class(universal_storage), intent(inout) :: this 43 | integer, intent(in) :: capacity 44 | 45 | allocate( this%element(capacity) ) 46 | 47 | end subroutine initialise_storage 48 | 49 | ! add_storage -- 50 | ! Add a data item to the storage 51 | ! 52 | ! Arguments: 53 | ! this Storage object 54 | ! idx Index at which to store the item 55 | ! item Data item to be stored 56 | ! 57 | ! Note: 58 | ! Simple check on the index 59 | ! 60 | subroutine add_storage( this, idx, item ) 61 | class(universal_storage), intent(inout) :: this 62 | integer, intent(in) :: idx 63 | class(*), intent(in) :: item 64 | 65 | if ( .not. allocated(this%element) ) then 66 | write(*,*) 'Storage not initialised!' 67 | stop 68 | endif 69 | 70 | if ( idx < 1 .or. idx > size(this%element) ) then 71 | write(*,*) 'Index out of range for the storage!' 72 | stop 73 | endif 74 | 75 | if ( allocated( this%element(idx)%data ) ) then 76 | deallocate( this%element(idx)%data ) 77 | endif 78 | 79 | ! 80 | ! Use sourced allocation: adopt the dynamic type and copy the value 81 | ! 82 | allocate( this%element(idx)%data, source = item ) 83 | 84 | end subroutine add_storage 85 | 86 | ! get_storage_real -- 87 | ! Get a real item from the storage 88 | ! 89 | ! Arguments: 90 | ! this Storage object 91 | ! idx Index at which the item was stored 92 | ! item Retrieved data item 93 | ! success Whether successful or not 94 | ! 95 | ! Note: 96 | ! Simple check on the index 97 | ! 98 | subroutine get_storage_real( this, idx, item, success ) 99 | class(universal_storage), intent(inout) :: this 100 | integer, intent(in) :: idx 101 | real, intent(out) :: item 102 | logical, intent(out) :: success 103 | 104 | if ( .not. allocated(this%element) ) then 105 | write(*,*) 'Storage not initialised!' 106 | stop 107 | endif 108 | 109 | if ( idx < 1 .or. idx > size(this%element) ) then 110 | write(*,*) 'Index out of range for the storage!' 111 | stop 112 | endif 113 | 114 | ! No data item stored at given index 115 | if (.not. allocated( this%element(idx)%data ) ) then 116 | success = .false. 117 | return 118 | endif 119 | 120 | 121 | success = .true. 122 | 123 | select type ( v => this%element(idx)%data ) 124 | type is (real) 125 | item = v 126 | class default 127 | success = .false. ! Wrong type 128 | end select 129 | 130 | end subroutine get_storage_real 131 | 132 | 133 | ! get_storage_int -- 134 | ! Get an integer item from the storage 135 | ! 136 | ! Arguments: 137 | ! this Storage object 138 | ! idx Index at which the item was stored 139 | ! item Retrieved data item 140 | ! success Whether successful or not 141 | ! 142 | ! Note: 143 | ! Simple check on the index 144 | ! 145 | subroutine get_storage_int( this, idx, item, success ) 146 | class(universal_storage), intent(inout) :: this 147 | integer, intent(in) :: idx 148 | integer, intent(out) :: item 149 | logical, intent(out) :: success 150 | 151 | if ( .not. allocated(this%element) ) then 152 | write(*,*) 'Storage not initialised!' 153 | stop 154 | endif 155 | 156 | if ( idx < 1 .or. idx > size(this%element) ) then 157 | write(*,*) 'Index out of range for the storage!' 158 | stop 159 | endif 160 | 161 | ! No data item stored at given index 162 | if (.not. allocated( this%element(idx)%data ) ) then 163 | success = .false. 164 | return 165 | endif 166 | 167 | 168 | success = .true. 169 | 170 | select type ( v => this%element(idx)%data ) 171 | type is (integer) 172 | item = v 173 | class default 174 | success = .false. ! Wrong type 175 | end select 176 | 177 | end subroutine get_storage_int 178 | 179 | end module universal_storages 180 | 181 | ! test_storage 182 | ! Simple test program 183 | ! 184 | program test_storage 185 | use universal_storages 186 | 187 | implicit none 188 | 189 | type(universal_storage) :: storage 190 | integer :: i 191 | integer :: int_value 192 | real :: real_value 193 | logical :: success 194 | 195 | 196 | call storage%initialise( 20 ) 197 | 198 | call storage%add( 1, 123 ) 199 | call storage%add( 2, exp(1.0) ) ! Not the cliche value of pi ;) 200 | 201 | ! 202 | ! We should be able to get an integer value from index 1, 203 | ! but not from any others 204 | ! And similarly for the real value at index 2. 205 | ! 206 | 207 | do i = 1,3 208 | call storage%get( i, int_value, success ) 209 | 210 | if ( success ) then 211 | write(*,*) 'Retrieved: ', int_value, ' - index:', i 212 | else 213 | write(*,*) 'No integer at index', i 214 | endif 215 | enddo 216 | 217 | do i = 1,3 218 | call storage%get( i, real_value, success ) 219 | 220 | if ( success ) then 221 | write(*,*) 'Retrieved: ', real_value, ' - index:', i 222 | else 223 | write(*,*) 'No real at index', i 224 | endif 225 | enddo 226 | 227 | end program test_storage 228 | --------------------------------------------------------------------------------