! fishes.f90 -- ! Ilustration of non-type bound procedure pointers: ! fish with three different life stages ! ! Note: ! initialising the procedure pointers like below is ! a Fortran 2008 feature ! ! Example belonging to "Modern Fortran in Practice" by Arjen Markus ! ! This work is licensed under the Creative Commons Attribution 3.0 Unported License. ! To view a copy of this license, visit http://creativecommons.org/licenses/by/3.0/ ! or send a letter to: ! Creative Commons, 444 Castro Street, Suite 900, Mountain View, California, 94041, USA. ! ! flow_fields -- ! Routines and types for dealing with the flow field ! in the sea ! ! Note: dummy only ! module flow_fields implicit none type flow_field_type ! Nothing integer :: dummy end type flow_field_type end module flow_fields ! food_situations -- ! Routines and types for dealing with the distribution of food ! The type of food that is of interest depends on the age ! of the fish ! ! Note: dummy only ! module food_situations implicit none type food_situation_type ! Nothing integer :: dummy end type food_situation_type end module food_situations ! fishes -- ! Routines and types to simulate the behaviour of fish in ! various stages of their lives. ! ! Note: dummy only ! module fishes use flow_fields use food_situations implicit none type fish_type real :: x, y real :: age procedure(behaving), pointer :: behave => behave_juvenile procedure(update), pointer :: update_position => update_position_flow procedure(tofood), pointer :: swim_to_food => swim_to_food_mature procedure(tomating), pointer :: swim_to_mating_grounds => swim_to_mating_grounds_mating end type fish_type real, parameter :: age_reach_adulthood = 0.5 ! Grown up at age 1/2 real, parameter :: age_reach_mating = 5.0 ! Mating start at age 5 abstract interface subroutine behaving( this, deltt, flow_field, food_situation ) import :: fish_type, flow_field_type, food_situation_type class(fish_type) :: this real :: deltt type(flow_field_type) :: flow_field type(food_situation_type) :: food_situation end subroutine behaving subroutine update( this, deltt, flow_field ) import :: fish_type, flow_field_type class(fish_type) :: this real :: deltt type(flow_field_type) :: flow_field end subroutine update subroutine tofood( this, deltt, food_situation ) import :: fish_type, food_situation_type class(fish_type) :: this real :: deltt type(food_situation_type) :: food_situation end subroutine tofood subroutine tomating( this, deltt ) import :: fish_type class(fish_type) :: this real :: deltt end subroutine tomating end interface contains subroutine behave_juvenile( this, deltt, flow_field, food_situation ) class(fish_type) :: this real :: deltt type(flow_field_type) :: flow_field type(food_situation_type) :: food_situation ! ! No motion of their own ! call this%update_position( deltt, flow_field ) ! ! Update age ! this%age = this%age + deltt if ( this%age >= age_reach_adulthood ) then this%behave => behave_adult endif end subroutine behave_juvenile subroutine behave_adult( this, deltt, flow_field, food_situation ) class(fish_type) :: this real :: deltt type(flow_field_type) :: flow_field type(food_situation_type) :: food_situation ! ! New position: where is the food? ! call this%update_position( deltt, flow_field ) call this%swim_to_food( deltt, food_situation ) ! ! Update age - time to mate? ! this%age = this%age + deltt if ( this%age >= age_reach_mating ) then this%behave => behave_migrate endif end subroutine behave_adult subroutine behave_migrate( this, deltt, flow_field, food_situation ) class(fish_type) :: this real :: deltt type(flow_field_type) :: flow_field type(food_situation_type) :: food_situation ! ! New position: to the mating grounds ! call this%update_position( deltt, flow_field ) call this%swim_to_mating_grounds( deltt ) ! ! Update age - time to mate? ! this%age = this%age + deltt end subroutine behave_migrate subroutine update_position_flow( this, deltt, flow_field ) class(fish_type) :: this real :: deltt type(flow_field_type) :: flow_field write(*,*) 'Go with the flow' end subroutine update_position_flow subroutine swim_to_food_mature( this, deltt, food_situation ) class(fish_type) :: this real :: deltt type(food_situation_type) :: food_situation write(*,*) 'Swim to food' end subroutine swim_to_food_mature subroutine swim_to_mating_grounds_mating( this, deltt ) class(fish_type) :: this real :: deltt write(*,*) 'Swim to mating grounds' end subroutine swim_to_mating_grounds_mating end module fishes ! test_fishes -- ! Program to illustrate the simulation loop ! program test_fishes use fishes implicit none integer, parameter :: number = 1 type(fish_type), dimension(number) :: fish type(flow_field_type) :: flow type(food_situation_type) :: food real :: deltt integer :: i integer :: time ! ! Initialise the information on fish, flow and food: ! fish in a square of 100x100 km ! call random_number( fish%x ) call random_number( fish%y ) fish%x = 100000.0 * fish%x fish%y = 100000.0 * fish%y fish%age = 0.0 deltt = 0.1 do time = 1,100 do i = 1,size(fish) call fish(i)%behave( deltt, flow, food ) enddo enddo end program test_fishes