From 8cf3bf076e020289a54739fff44ab8d426bfe064 Mon Sep 17 00:00:00 2001
From: Martin Beseda <martinbeseda@seznam.cz>
Date: Tue, 10 Jul 2018 16:43:01 +0200
Subject: [PATCH] ENH: Fortran codes removed to the folder 'fortran2008' and
CMakeLists.txt edited accordingly.
---
CMakeLists.txt | 30 +-
build.sh | 9 +-
src/Neuron/NeuronBinary.cpp | 2 +-
src/abstract_base_m.f90 | 25 -
src/connection_m.f90 | 485 ---------
src/connection_m_mem_leak_test.f90 | 37 -
src/container_m.f90 | 110 --
src/data_kinds_4neuro_m.f90 | 9 -
src/net_m.f90 | 295 ------
src/net_m_mem_leak_test.f90 | 29 -
src/neuron_m.f90 | 788 --------------
src/neuron_m_mem_leak_test.f90 | 21 -
src/normal_m.f90 | 1593 ----------------------------
src/time_measurement_m.f90 | 42 -
14 files changed, 11 insertions(+), 3464 deletions(-)
delete mode 100644 src/abstract_base_m.f90
delete mode 100644 src/connection_m.f90
delete mode 100644 src/connection_m_mem_leak_test.f90
delete mode 100644 src/container_m.f90
delete mode 100644 src/data_kinds_4neuro_m.f90
delete mode 100644 src/net_m.f90
delete mode 100644 src/net_m_mem_leak_test.f90
delete mode 100644 src/neuron_m.f90
delete mode 100644 src/neuron_m_mem_leak_test.f90
delete mode 100644 src/normal_m.f90
delete mode 100644 src/time_measurement_m.f90
diff --git a/CMakeLists.txt b/CMakeLists.txt
index aac50d37..e1de6293 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -2,17 +2,6 @@ cmake_minimum_required(VERSION 3.0)
project(4neuro)
-#message ("Before enable language")
-##enable_language(Fortran)
-#if (WIN32)
-# message ("cmake for " ${CMAKE_Fortran_COMPILER})
-# set (CMAKE_FORTRAN_COMPILER ${CMAKE_Fortran_COMPILER})
-# project(4Neuro)
-#else ()
-# project(4Neuro)
-#endif ()
-#message ("Start cmakeList")
-
#-------------------------------#
# Default installation location #
#-------------------------------#
@@ -39,7 +28,6 @@ set(CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} -Wall" )
#--------------------#
# Automatic settings #
#--------------------#
-#get_filename_component (Fortran_COMPILER_NAME ${CMAKE_Fortran_COMPILER} NAME)
# Processing user variables
if (WITH_TIME_PROFILING)
@@ -53,31 +41,29 @@ if (WIN32)
endif()
# Write compiler variables to the file - to pass them to test script
-#file(WRITE compilers.env "export FC=${CMAKE_Fortran_COMPILER}\n")
file(APPEND compilers.env "export CXX=${CMAKE_CXX_COMPILER}\n")
file(APPEND compilers.env "export CC=${CMAKE_C_COMPILER}\n")
-
-
-
#----------------#
# User variables #
#----------------#
set(SRC_DIR src)
-set(BUILD_DIR build)
-set(LIB_DIR lib)
+set(PROJECT_BINARY_DIR build)
#--------------------#
# Building libraries #
#--------------------#
-#link_directories("${BUILD_DIR}/${LIB_DIR}")
-include_directories("${BUILD_DIR}/${LIB_DIR}")
-add_subdirectory("${SRC_DIR}" "${LIB_DIR}")
+
+set(CMAKE_LIBRARY_OUTPUT_DIRECTORY lib)
+set(CMAKE_ARCHIVE_OUTPUT_DIRECTORY lib)
+set(CMAKE_RUNTIME_OUTPUT_DIRECTORY bin)
+
+add_subdirectory(${SRC_DIR} ${PROJECT_BINARY_DIR})
+
message ("Current directory:" ${PWD})
message ("SRC_DIR: " ${SRC_DIR})
message ("BUILD_DIR:" ${BUILD_DIR})
-message ("LIB_DIR: " ${LIB_DIR})
if (WIN32)
message ("Windows")
diff --git a/build.sh b/build.sh
index eb55b7d7..e2a987b3 100755
--- a/build.sh
+++ b/build.sh
@@ -68,12 +68,7 @@ case `uname -s` in
esac
#-------------------------------------------------------------------------
-echo "Creating folder 'build'...";
-mkdir -p build/lib;
-echo "Folder 'build' was created'";
-
-cd build;
-#cmake -G "MSYS Makefiles" -DCMAKE_Fortran_COMPILER=${FORTRAN_COMPILER} -DCMAKE_BUILD_TYPE=${BUILD_TYPE} -DWITH_TIME_PROFILING:BOOLEAN=${WITH_TIME_PROFILING} ..
-cmake -G "${MAKEFILE_TYPE}" -DCMAKE_BUILD_TYPE=${BUILD_TYPE} -DWITH_TIME_PROFILING:BOOLEAN=${WITH_TIME_PROFILING} ..
+rm -rf build;
+cmake -G "${MAKEFILE_TYPE}" -DCMAKE_BUILD_TYPE=${BUILD_TYPE} -DWITH_TIME_PROFILING:BOOLEAN=${WITH_TIME_PROFILING} .
make VERBOSE=1 && echo "Build complete." || exit -1;
#make install;
diff --git a/src/Neuron/NeuronBinary.cpp b/src/Neuron/NeuronBinary.cpp
index 14f58484..3b7da99c 100644
--- a/src/Neuron/NeuronBinary.cpp
+++ b/src/Neuron/NeuronBinary.cpp
@@ -5,7 +5,7 @@
#include "NeuronBinary.h"
NeuronBinary::NeuronBinary(double threshold) {
-
+
this->n_activation_function_parameters = 2;
this->activation_function_parameters = new double[1];
this->activation_function_parameters[0] = threshold;
diff --git a/src/abstract_base_m.f90 b/src/abstract_base_m.f90
deleted file mode 100644
index 81849449..00000000
--- a/src/abstract_base_m.f90
+++ /dev/null
@@ -1,25 +0,0 @@
-!> Module containing a class abstract_base_t, which is a parental
-!! class for all other classes in 4neuro. It makes creating a
-!! common container for all classes possible.
-!!
-!! @author Martin Beseda
-!! @date 2018
-module abstract_base_m
-
- implicit none
-
- public
-
- !------------------!-----------------------------------------
- ! Type definitions !
- !------------------!
-
- !-----------------------!------------------------------------
- ! class abstract_base_t !
- !-----------------------!
-
- !> Abstract class covering all the other classes in 4neuro
- type, abstract :: abstract_base_t
- end type
-
-end module abstract_base_m
diff --git a/src/connection_m.f90 b/src/connection_m.f90
deleted file mode 100644
index ea43cbda..00000000
--- a/src/connection_m.f90
+++ /dev/null
@@ -1,485 +0,0 @@
-!> Module containing classes representing connections (synapses)
-!! in neural networks.
-!!
-!! It uses 'neuron_m' and 'time_measurement_m' modules.
-!!
-!! @author Martin Beseda
-!! @author Martin Mrovec
-!! @date 2017
-!! @todo Rewrite pass_signal method of interval_connection_t
-module connection_m
- use neuron_m
- use time_measurement_m
- use normal_m
- use container_m
-
- implicit none
-
- public
-
- !------------------!------------------------------------------------------------------------
- ! Type definitions !
- !------------------!
-
- !> Represents a connection between two neurons.
- type, extends(abstract_base_t) :: connection_t
- !TODO properties are public because of problems with reading from binary
- !file - solve in a better way
-
- class(neuron_t), pointer :: input_neuron !< Pointer to an input neuron
- class(neuron_t), pointer :: output_neuron !< Pointer to an output neuron
- real(kind=real_4neuro) :: weight !< Weight of the connection
-
- contains
-
- !> Initializes the common connection_t class components
- !! 'input_neuron', 'output_neuron' and 'weight'.
- !! I.e. serves similarly to an abstract constructor.
- !! @param[in] input_neuron Pointer to the input neuron (instance of neuron_t)
- !! @param[in] output_neuron Pointer to the output neuron (instance of neuron_t)
- !! @param[in] weight Weight of the connection (real number)
- procedure, private :: init_components => connection_init_components_impl
-
- !> Nullifies pointers to input and output neurons, so they
- !! don't get destroyed when the connection_t instance is
- !! deallocated.
- procedure, private :: nullify_pointers => nullify_pointers_impl
-
- !> Adds a given value to the current weight of the
- !! connection.
- !! @param[in] added_value Number (real) to be added to the current weight
- procedure :: adjust_weight => adjust_weight_impl
-
- !> Getter for the private 'input_neuron' component
- !! @return Pointer to the input neuron (type neuron_t, pointer)
- procedure :: get_input_neuron => get_input_neuron_impl
-
- !> Getter for the private 'output_neuron' component
- !! @return Pointer to the output neuron (type neuron_t, pointer)
- procedure :: get_output_neuron => get_output_neuron_impl
-
- !> Getter for the private 'weight' component
- !! @return Weight of the connection (type real)
- procedure :: get_weight => get_weight_impl
-
- !> Passes (assigns) the product (input neuron state * weight)
- !! to an output neuron.
- procedure :: pass_signal => pass_signal_impl
-
- !> Implementation of write function enabling the storage of
- !! allocatable arrays.
- procedure :: write_sample => write_connection_sample
-
- !> Implementation of read function enabling to read
- !! the whole instance of net_t stored as binary file.
- procedure :: read_sample => read_connection_sample
-
- generic :: write(unformatted) => write_sample
- generic :: read(unformatted) => read_sample
-
- !> Scalar desctructor for single instances of the class connection_t
- final :: destroy_connection
-
- !> Array desctructor for arrays of instances of the class connection_t
- final :: destroy_connection_array
-
- end type connection_t
-
- interface connection_t
- !> Constructor of connection_t class
- !! @param[in] input_neuron Pointer to the input neuron (instance of neuron_t)
- !! @param[in] output_neuron Pointer to the output neuron (instance of neuron_t)
- !! @return Pointer to the instance of the class connection_t
- module procedure :: new_connection_2
-
- !> Constructor of connection_t class
- !! @param[in] input_neuron Pointer to the input neuron (instance of neuron_t)
- !! @param[in] output_neuron Pointer to the output neuron (instance of neuron_t)
- !! @param[in] weight Weight of the connection (real number)
- !! @return Pointer to the instance of the class connection_t
- module procedure :: new_connection_3
- end interface connection_t
-
- !> Represents a connection between two neurons.
- !! Able to pass a signal from an input neuron to
- !! an output one.
- type, extends(connection_t) :: interval_connection_t
- contains
-
- !> Passes (assigns) the product
- !! input neuron state * weight)
- !! to an output neuron.
- !! @todo Rewrite implementation to "interval"
- procedure :: pass_signal => pass_signal_interval_impl
-
- end type interval_connection_t
-
- interface interval_connection_t
- !> Constructor of interval_connection_t class
- !! @param[in] input_neuron Pointer to the input neuron (instance of neuron_t)
- !! @param[in] output_neuron Pointer to the output neuron (instance of neuron_t)
- !! @return Pointer to the instance of the class interval_connection_t
- module procedure :: new_interval_connection_2
-
- !> Constructor of interval_connection_t class
- !! @param[in] input_neuron Pointer to the input neuron (instance of neuron_t)
- !! @param[in] output_neuron Pointer to the output neuron (instance of neuron_t)
- !! @param[in] weight Weight of the connection (real number)
- !! @return Pointer to the instance of the class interval_connection_t
- module procedure :: new_interval_connection_3
- end interface interval_connection_t
-
- contains
- !------------------------!------------------------------------------------------------------
- ! Method implementations !
- ! -----------------------!
-
- !--------------------!
- ! class connection_t !
- !--------------------!
-
- !--------------!----------------------------------------------------------------------------
- ! Constructors !
- !--------------!
-
- !> Constructor of connection_t class
- !! @param[in] input_neuron Pointer to the input neuron (instance of neuron_t)
- !! @param[in] output_neuron Pointer to the output neuron (instance of neuron_t)
- !! @return An instance of the class connection_t
- function new_connection_2(input_neuron, output_neuron) result(new_obj)
- class(neuron_t), pointer, intent(in) :: input_neuron
- class(neuron_t), pointer, intent(in) :: output_neuron
- real(kind=real_4neuro) :: weight
- type(connection_t) :: new_obj
- integer(kind=4) :: values(8) !< values(8) is used as seed
-
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- ! Generate pseudorandom number from Gaussian distribution
- ! as connection weight
- call date_and_time(values=values)
- weight = r4_normal_01(values(8))
-
- call new_obj%init_components(input_neuron, output_neuron, weight)
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'new_connection_2')
-#endif
- end function new_connection_2
-
- !> Constructor of connection_t class
- !! @param[in] input_neuron Pointer to the input neuron (instance of neuron_t)
- !! @param[in] output_neuron Pointer to the output neuron (instance of neuron_t)
- !! @param[in] weight Weight of the connection (real number)
- !! @return An instance of the class connection_t
- function new_connection_3(input_neuron, output_neuron, weight) result(new_obj)
- class(neuron_t), pointer, intent(in) :: input_neuron
- class(neuron_t), pointer, intent(in) :: output_neuron
- real(kind=real_4neuro), intent(in) :: weight
- type(connection_t) :: new_obj
-
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- call new_obj%init_components(input_neuron, output_neuron, weight)
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'new_connection_3')
-#endif
- end function new_connection_3
-
- !-------------!--------------------------------------------------------------------------
- ! Destructors !
- !-------------!
-
- !> Scalar desctructor for single instances of the class connection_t
- subroutine destroy_connection(this)
- type(connection_t), intent(inout) :: this
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- call this%nullify_pointers()
-#ifdef TIME_PROFILING
- call time_profiling_start(start_time, 'destroy_connection')
-#endif
- end subroutine destroy_connection
-
- !> Array desctructor for arrays of instances of the class connection_t
- subroutine destroy_connection_array(this)
- type(connection_t), intent(inout) :: this(:)
- integer(kind=integer_4neuro) :: i
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- do i = 1, size(this)
- call this(i)%nullify_pointers()
- end do
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'destroy_connection_array')
-#endif
- end subroutine destroy_connection_array
-
- !-------------------!-------------------------------------------------------------------
- ! Getters & Setters !
- !-------------------!
-
- !> Getter for the private 'input_neuron' component
- !! @return Pointer to the input neuron (type class(*), pointer)
- function get_input_neuron_impl(this) result (input_neuron)
- class(connection_t), target, intent(in) :: this
- class(*), pointer :: input_neuron
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- input_neuron => this%input_neuron
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time,'get_input_neuron_impl')
-#endif
- end function get_input_neuron_impl
-
- !> Getter for the private 'output_neuron' component
- !! @return Pointer to the output neuron (type class(*), pointer)
- function get_output_neuron_impl(this) result (output_neuron)
- class(connection_t), target, intent(in) :: this
- class(*), pointer :: output_neuron
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- output_neuron => this%output_neuron
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'get_output_neuron_impl')
-#endif
- end function get_output_neuron_impl
-
- !> Getter for the private 'weight' component
- !! @return Weight of the connection (type real)
- function get_weight_impl(this) result (weight)
- class(connection_t), intent(in) :: this
- real(kind=real_4neuro) :: weight
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- weight = this%weight
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'get_weight_impl')
-#endif
- end function get_weight_impl
-
-
- !----------------!-------------------------------------------------------------------------
- ! Common methods !
- !----------------!
-
- !> Initializes the common connection_t class components
- !! 'input_neuron', 'output_neuron' and 'weight'.
- !! I.e. serves similarly to an abstract constructor.
- !! @param[in] input_neuron Pointer to the input neuron (instance of neuron_t)
- !! @param[in] output_neuron Pointer to the output neuron (instance of neuron_t)
- !! @param[in] weight Weight of the connection (real number)
- subroutine connection_init_components_impl(this, input_neuron, output_neuron, weight)
- class(connection_t), intent(inout) :: this
- class(neuron_t), pointer, intent(in) :: input_neuron
- class(neuron_t), pointer, intent(in) :: output_neuron
- real(kind=real_4neuro), intent(in) :: weight
-
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
-
- this%input_neuron => input_neuron
- this%output_neuron => output_neuron
- this%weight = weight
-
-#ifdef TIME_PROFILING
- call connection_time_profiling_stop(start_time, 'connection_init_components_impl')
-#endif
- end subroutine connection_init_components_impl
-
- !> Nullifies pointers to input and output neurons, so they
- !! don't get destroyed when the connection_t instance is
- !! deallocated.
- subroutine nullify_pointers_impl(this)
- class(connection_t), intent(inout) :: this
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- nullify(this%input_neuron)
- nullify(this%output_neuron)
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'nullify_pointers_impl')
-#endif
- end subroutine nullify_pointers_impl
-
- !> Adds a given value to the current weight of the
- !! connection.
- !! @param[in] added_value Number (real) to be added to the current weight
- subroutine adjust_weight_impl(this, added_value)
- class(connection_t), intent(inout) :: this
- real(kind=real_4neuro), intent(in) :: added_value
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- this%weight = this%weight + added_value
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'adjust_weight_impl')
-#endif
- end subroutine adjust_weight_impl
-
- !> Passes (assigns) the product
- !! input neuron state * weight)
- !! to an output neuron.
- subroutine pass_signal_impl(this)
- class(connection_t), intent(in) :: this
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- call this%output_neuron%adjust_potential(this%input_neuron%get_state() * this%weight)
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'pass_signal_impl')
-#endif
- end subroutine pass_signal_impl
-
- !> Implementation of write function enabling the storage of
- !! allocatable arrays.
- !! @param[in] unit Unit (handler) where the file is written
- !! @param[out] iostat Diagnostic value "returned" by the subroutine
- !! @param[inout] iomsg Explaining note about error
- subroutine write_connection_sample(this, unit, iostat, iomsg)
- class(connection_t), target, intent(in) :: this
- integer, intent(in) :: unit
- integer, intent(out) :: iostat
- character(*), intent(inout) :: iomsg
- integer :: i !< Counter
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- ! Write a record giving sizes for the allocation
- !write(unit, iostat=iostat, iomsg=iomsg) SIZE(this%input_neuron), &
- ! SIZE(this%output_neuron)
-
- write(unit, iostat=iostat, iomsg=iomsg) container_t(this%input_neuron), &
- container_t(this%output_neuron), &
- container_t(this%weight)
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'write_connection_sample')
-#endif
- end subroutine write_connection_sample
-
- ! Unformatted reading for the sample derived type
- subroutine read_connection_sample(this, unit, iostat, iomsg)
- class(connection_t), intent(inout) :: this
- integer, intent(in) :: unit
- integer, intent(out) :: iostat
- character(*), intent(inout) :: iomsg
- integer :: i
- class(container_t), allocatable :: inp_n, out_n
- !integer :: s1, s2, s3, s4 !< Sizes of stored allocatable properties
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- ! We first have a record telling us the sizes of components
- !read(unit, iostat=iostat, iomsg=iomsg) s1, s2, s3, s4
-
- ! So we do the allocation
- !allocate(this%neuron_arr(s1), &
- ! this%input_neuron_arr(s2), &
- ! this%output_neuron_arr(s3), &
- ! this%connection_arr(s4))
-
- ! And then finally the reading.
- read(unit, iostat=iostat, iomsg=iomsg) inp_n, &
- out_n, &
- this%weight
-
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'read_connection_sample')
-#endif
- end subroutine read_connection_sample
-
- !-----------------------------!
- ! class interval_connection_t !
- !-----------------------------!
-
- !--------------!------------------------------------------------------------------------
- ! Constructors !
- !--------------!
-
- !> Constructor of interval_connection_t class
- !! @param[in] input_neuron Pointer to the input neuron (instance of neuron_t)
- !! @param[in] output_neuron Pointer to the output neuron (instance of neuron_t)
- !! @return An instance of the class interval_connection_t
- function new_interval_connection_2(input_neuron, output_neuron) result(new_obj)
- class(neuron_t), pointer, intent(in) :: input_neuron
- class(neuron_t), pointer, intent(in) :: output_neuron
- real(kind=real_4neuro) :: weight
- type(interval_connection_t) :: new_obj
- integer(kind=4) :: values(8)
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- call date_and_time(values=values)
- weight = r4_normal_01(values(8))
-
- call new_obj%init_components(input_neuron, output_neuron, weight)
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'new_interval_connection_2')
-#endif
- end function new_interval_connection_2
-
- !> Constructor of interval_connection_t class
- !! @param[in] input_neuron Pointer to the input neuron (instance of neuron_t)
- !! @param[in] output_neuron Pointer to the output neuron (instance of neuron_t)
- !! @param[in] weight Weight of the connection (real number)
- !! @return An instance of the class interval_connection_t
- function new_interval_connection_3(input_neuron, output_neuron, weight) result(new_obj)
- class(neuron_t), pointer, intent(in) :: input_neuron
- class(neuron_t), pointer, intent(in) :: output_neuron
- real(kind=real_4neuro), intent(in) :: weight
- type(interval_connection_t) :: new_obj
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- call new_obj%init_components(input_neuron, output_neuron, weight)
-
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'new_interval_connection_3')
-#endif
- end function new_interval_connection_3
-
- !----------------!---------------------------------------------------------------------
- ! Common methods !
- !----------------!
-
- !> Passes (assigns) the product
- !! input neuron state * weight)
- !! to an output neuron.
- !! @todo Rewrite implementation to "interval"
- subroutine pass_signal_interval_impl(this)
- class(interval_connection_t), intent(in) :: this
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- !todo dopsat metodu pro interval
- call this%output_neuron%adjust_potential(this%input_neuron%get_state() * this%weight)
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'pass_signal_interval_impl')
-#endif
- end subroutine pass_signal_interval_impl
-
-end module connection_m
-
diff --git a/src/connection_m_mem_leak_test.f90 b/src/connection_m_mem_leak_test.f90
deleted file mode 100644
index 2c32b941..00000000
--- a/src/connection_m_mem_leak_test.f90
+++ /dev/null
@@ -1,37 +0,0 @@
-program connection_mem_leak_test
- use connection_m
- use neuron_m
- use normal_m
- use data_kinds_4neuro_m
-
- type(mock_neuron_t), target :: n1, n2
- class(neuron_t), pointer :: n1_p, n2_p
- class(connection_t), allocatable :: n_t
- type(connection_t) :: con1, con2
-
- print *, '+---------------------------------------------------------+'
- print *, '| STARTING MEMORY LEAK TESTING OF THE MODULE CONNECTION_M |'
- print *, '+---------------------------------------------------------+'
-
- print *, 'Creating instances of the class neuron_t...'
- n1 = mock_neuron_t()
- n2 = mock_neuron_t()
-
- n1_p => n1
- n2_p => n2
-
- print *, 'Creating an instance of the class interval_connection_t with 2-parameters constructor...'
- con2 = connection_t(input_neuron=n1_p, output_neuron=n2_p)
-
- print *, 'Creating an instance of the class interval_connection_t with 3-parameters constructor...'
- con1 = connection_t(input_neuron=n1_p, output_neuron=n2_p, weight=real(5.25, real_4neuro))
-
- open(123,file='connection.test', form='unformatted')
- write(123) con1
- close(123)
-
- !open(123,file='connection.test', form='unformatted')
- ! read(123) n_t
- !close(123)
-
-end program connection_mem_leak_test
diff --git a/src/container_m.f90 b/src/container_m.f90
deleted file mode 100644
index 54f15ee2..00000000
--- a/src/container_m.f90
+++ /dev/null
@@ -1,110 +0,0 @@
-!> Module containing declaration of a container type 'container_t'.
-!! This class "wraps" pointers, so it's possible to store them
-!! into arrays.
-!!
-!! @author Martin Beseda
-!! @date 2018
-module container_m
- use abstract_base_m
- use data_kinds_4neuro_m
-
- implicit none
-
- public
-
- !> Represents a container for a single container_t pointer
- type :: container_t
- ! Variable content is public to make usage of this class with one
- ! specific purpose as simple as possible.
-
- class(*), pointer, public :: content
-
- contains
- !> Scalar desctructor for single instances of the class container_t
- final :: destroy_container
-
- !> Array desctructor for arrays of instances of the class container_t
- final :: destroy_container_array
-
- end type container_t
-
- interface container_t
- !> Constructor of container_t class
- !! @return Instance of the class container_t with nullified content
- module procedure :: new_container_empty
-
- !> Constructor of container_t class
- !! @param[in] content_in container to be contained (pointer)
- !! @return Pointer to the instance of the class container_t with assigned content
- module procedure :: new_container_assigned
- end interface container_t
-
-contains
- !--------------!------------------------------------------------------------------------
- ! Constructors !
- !--------------!
-
- !> Constructor of container_t class
- !! @return Instance of the class container_t with nullified content
- function new_container_empty() result(new_obj)
- type(container_t) :: new_obj
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- new_obj%content => null()
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'new_container_empty')
-#endif
- end function new_container_empty
-
- !> Constructor of container_t class
- !! @param[in] content_in connection to be contained (pointer)
- !! @return Pointer to the instance of the class connection_t with assigned content
- function new_container_assigned(content_in) result(new_obj)
- class(abstract_base_t), pointer, intent(in) :: content_in
- type(container_t) :: new_obj
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- new_obj%content => content_in
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'new_container_assigned')
-#endif
- end function new_container_assigned
-
- !--------------!------------------------------------------------------------------------
- ! Destructors !
- !--------------!
- !> Scalar desctructor for single instances of the class container_t
- subroutine destroy_container(this)
- type(container_t), intent(inout) :: this
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- nullify(this%content)
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'destroy_container')
-#endif
- end subroutine destroy_container
-
- !> Array desctructor for arrays of instances of the class container_t
- subroutine destroy_container_array(this)
- type(container_t), intent(inout) :: this(:)
- integer(kind=integer_4neuro) :: i
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- do i = 1, size(this)
- nullify(this(i)%content)
- end do
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'destroy_container_array')
-#endif
- end subroutine destroy_container_array
-
-end module container_m
-
diff --git a/src/data_kinds_4neuro_m.f90 b/src/data_kinds_4neuro_m.f90
deleted file mode 100644
index 4d69c5af..00000000
--- a/src/data_kinds_4neuro_m.f90
+++ /dev/null
@@ -1,9 +0,0 @@
-#define SINGLE 4
-#define DOUBLE 8
-
-# define PREC DOUBLE
-
-module data_kinds_4neuro_m
- integer, parameter :: integer_4neuro = PREC
- integer, parameter :: real_4neuro = PREC
-end module data_kinds_4neuro_m
diff --git a/src/net_m.f90 b/src/net_m.f90
deleted file mode 100644
index e5fa54ff..00000000
--- a/src/net_m.f90
+++ /dev/null
@@ -1,295 +0,0 @@
-!> Module containing classes representing the whole
-!! neural network.
-!!
-!! It uses 'neuron_m' module.
-!!
-!! @author Martin Beseda
-!! @date 2018
-module net_m
- use data_kinds_4neuro_m
- use time_measurement_m
- use neuron_m
- use connection_m
- use container_m
-
- implicit none
-
- public
-
- !-------------!------------------------------------------------------------------------------
- ! class net_t !
- !-------------!
-
- type :: container
- class(*), pointer :: content
- end type
-
- !> Class representing a general network
- type :: net_t
- private
-
- character(:), allocatable :: net_type !< Type of the net
- integer(kind=integer_4neuro) :: num_of_neurons !< Number of neurons in the net
- character(:), allocatable :: training_method !< Used training method
-
- class(container_t), allocatable :: neuron_arr(:) !< Array containing all neurons
- integer(kind=integer_4neuro), allocatable :: input_neuron_arr(:) !< Array of input neuron indices
- integer(kind=integer_4neuro), allocatable :: output_neuron_arr(:) !< Array of output neuron indices
- class(connection_t), allocatable :: connection_arr(:) !< Array of all connections
-
- contains
- !> Prints information about the network to the standard output.
- procedure :: print_info => print_info_impl
-
- !> Saves the network instance to the Fortran binary file
- procedure :: save_net_bin => save_net_bin_impl
-
- !> Implementation of write function enabling the storage of
- !! allocatable arrays.
- procedure :: write_sample => write_sample_impl
-
- !> Implementation of read function enabling to read
- !! the whole instance of net_t stored as binary file.
- procedure :: read_sample => read_sample_impl
-
- generic :: write(unformatted) => write_sample
- generic :: read(unformatted) => read_sample
- end type net_t
-
- interface net_t
- !> Constructor of net_t class
- !! Loads complete info about network from file
- !! @param[in] filepath Path to the file with network configuration
- !! @return An instance of the class net_t
- module procedure :: new_net_1
- end interface net_t
-
-
- !------------------!---------------------------------------------------------------------
- ! class mock_net_t !
- !------------------!
-
- !> Mock net_t class
- type, extends(net_t) :: mock_net_t
- end type mock_net_t
-
- interface mock_net_t
- !> Non-parametric constructor of mock_net_t class
- !! @return An instance of the class mock_net_t
- module procedure :: new_mock_net
- end interface mock_net_t
-
-contains
- !------------------------!---------------------------------------------------------------
- ! Method implementations !
- !------------------------!
-
- !-------------!--------------------------------------------------------------------------
- ! class net_t !
- !-------------!
-
- !--------------!-------------------------------------------------------------------------
- ! Constructors !
- !--------------!
-
- !> Constructor of net_t class
- !! Loads complete info about network from Fortran binary file
- !! @param[in] filepath Path to the JSON file with network configuration
- !! @return An instance of the class net_t
- function new_net_1(filepath) result(new_obj)
- character(len=*), intent(in) :: filepath
- type(net_t) :: new_obj
- character(len=50) :: str !TODO udelat dynamicky, ne s fixni delkou
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- open(unit=11, file=filepath, form="unformatted", access="stream")
- read(11) new_obj
- close(11)
-
- print *,new_obj%net_type
-
- !TODO dopsat
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'new_net')
-#endif
- end function new_net_1
-
- !> Prints information about the network to the standard output.
- subroutine print_info_impl(this)
- class(net_t), intent(in) :: this
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- write(*,*) '+--------------+'
- write(*,*) '| Network info |'
- write(*,*) '+--------------+'
- write(*,*) 'Type: ', this%net_type
- write(*,*) 'Number of neurons: ', this%num_of_neurons
- !TODO dopsat
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'print_info_impl')
-#endif
- end subroutine print_info_impl
-
- !----------------!-----------------------------------------------------------------------
- ! Common methods !
- !----------------!
-
- !> Saves the network instance to the Fortran binary file
- !! @param[in] filename Name of the file, where the net will be saved into
- subroutine save_net_bin_impl(this, filename)
- class(net_t), intent(in) :: this !< Instance of the class 'net_t'
- character(len=*), intent(in) :: filename
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- open(unit=11, file=filename, form="unformatted", access='stream', position='append')
- write(11) this
- close(unit=11)
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'save_net_bin_impl')
-#endif
- end subroutine save_net_bin_impl
-
- !> Implementation of write function enabling the storage of
- !! allocatable arrays.
- !! @param[in] unit Unit (handler) where the file is written
- !! @param[out] iostat Diagnostic value "returned" by the subroutine
- !! @param[inout] iomsg Explaining note about error
- subroutine write_sample_impl(this, unit, iostat, iomsg)
- class(net_t), intent(in) :: this
- integer, intent(in) :: unit
- integer, intent(out) :: iostat
- character(*), intent(inout) :: iomsg
- integer :: i !< Counter
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- ! Write a record giving sizes for the allocation
- write(unit, iostat=iostat, iomsg=iomsg) SIZE(this%neuron_arr), &
- SIZE(this%input_neuron_arr), &
- SIZE(this%output_neuron_arr), &
- SIZE(this%connection_arr)
-
- select type(tmp => this%neuron_arr)
- type is(container_t)
- select type(tmp2 => this%connection_arr)
- type is(connection_t)
- write(unit, iostat=iostat, iomsg=iomsg) (tmp(i)%content%get_id(), &
- tmp(i)%get_potential(), &
- tmp(i)%get_state(), &
- i=1,SIZE(this%neuron_arr)), &
- this%input_neuron_arr, &
- this%output_neuron_arr, &
- (tmp2(i)%get_input_neuron(), &
- tmp2(i)%get_output_neuron(), &
- tmp2(i)%get_weight(), &
- i=1,SIZE(this%connection_arr))
- end select
- end select
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'write_net_sample')
-#endif
- end subroutine write_sample_impl
-
- ! Unformatted reading for the sample derived type
- subroutine read_sample_impl(this, unit, iostat, iomsg)
- class(net_t), intent(inout) :: this
- integer, intent(in) :: unit
- integer, intent(out) :: iostat
- character(*), intent(inout) :: iomsg
- integer :: i
- integer :: s1, s2, s3, s4 !< Sizes of stored allocatable properties
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- ! We first have a record telling us the sizes of components
- read(unit, iostat=iostat, iomsg=iomsg) s1, s2, s3, s4
-
- ! So we do the allocation
- allocate(this%neuron_arr(s1), &
- this%input_neuron_arr(s2), &
- this%output_neuron_arr(s3), &
- this%connection_arr(s4))
-
- ! And then finally the reading.
- select type(tmp => this%neuron_arr)
- type is(container_t)
- select type(tmp2 => this%connection_arr)
- type is(connection_t)
- read(unit, iostat=iostat, iomsg=iomsg) (tmp(i)%id, &
- tmp(i)%potential, &
- tmp(i)%state, &
- i=1, SIZE(this%neuron_arr)), &
- this%input_neuron_arr, &
- this%output_neuron_arr, &
- (tmp2(i)%input_neuron, &
- tmp2(i)%output_neuron, &
- tmp2(i)%weight, &
- i=1, SIZE(this%connection_arr))
- end select
- end select
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'read_net_sample')
-#endif
- end subroutine read_sample_impl
-
- !------------------!---------------------------------------------------------------------
- ! class mock_net_t !
- !------------------!
-
- !--------------!-------------------------------------------------------------------------
- ! Constructors !
- !--------------!
-
- !> Contructor of mock_net_t class
- !! @return An instance of the class mock_net_t
- function new_mock_net() result(new_obj)
- type(mock_net_t) :: new_obj
- integer :: i !< Counter
- class(neuron_t), pointer :: n_p1, n_p2
- class(neuron_t), pointer :: n_p(:)
- type(mock_neuron_t), target :: n_tmp
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- new_obj%net_type = 'MOCK NETWORK'
- new_obj%num_of_neurons = 5
- new_obj%training_method = 'MOCK TRAINING'
-
- ! Init object
- allocate(container_t :: new_obj%neuron_arr(5))
- select type(tmp => new_obj%neuron_arr)
- type is (container_t)
- do i=1,5
- n_tmp = mock_neuron_t()
- tmp(i) = container_t(n_tmp)
- end do
- end select
-
- new_obj%input_neuron_arr = (/1, 2/)
- new_obj%output_neuron_arr = (/ 5 /)
-
- allocate(connection_t :: new_obj%connection_arr(4))
-! n_p => new_obj%neuron_arr
-! new_obj%connection_arr(1) = connection_t(n_p(1), n_p(3))
-
-! connection_arr_tmp(2)%content => connection_t(neuron_arr_tmp(2)%content, neuron_arr_tmp(4))
-! connection_arr_tmp(3)%content => connection_t(neuron_arr_tmp(3)%content, neuron_arr_tmp(5))
-! connection_arr_tmp(4)%content => connection_t(neuron_arr_tmp(4)%content, neuron_arr_tmp(5))
-
-
- !TODO dopsat init zbylych polozek
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'new_mock_net')
-#endif
-
- end function new_mock_net
-end module net_m
diff --git a/src/net_m_mem_leak_test.f90 b/src/net_m_mem_leak_test.f90
deleted file mode 100644
index 442e219f..00000000
--- a/src/net_m_mem_leak_test.f90
+++ /dev/null
@@ -1,29 +0,0 @@
-program net_mem_leak_test
- use data_kinds_4neuro_m
- use net_m
-
- class(net_t), allocatable :: net1, net2
-
- print *, '+--------------------------------------------------+'
- print *, '| STARTING MEMORY LEAK TESTING OF THE MODULE NET_M |'
- print *, '+--------------------------------------------------+'
-
- print *, 'Creating instances of the class net_t...'
-
- allocate(net1)
-
- select type(tmp => net1)
- type is (mock_net_t)
- tmp = mock_net_t()
- end select
-
- call net1%print_info()
-
- call net1%save_net_bin("stored_net.dat")
-
- !allocate(net2)
- !net2 = net_t("stored_net.dat")
-
- !call net2%print_info()
-
-end program net_mem_leak_test
diff --git a/src/neuron_m.f90 b/src/neuron_m.f90
deleted file mode 100644
index bbe17e1c..00000000
--- a/src/neuron_m.f90
+++ /dev/null
@@ -1,788 +0,0 @@
-!> Module containing classes representing neurons
-!! in neural networks.
-!!
-!! It uses 'time_measurement_m' and 'normal_m' modules.
-!!
-!! @author Martin Beseda
-!! @author Martin Mrovec
-!! @date 2017
-module neuron_m
- use time_measurement_m
- use normal_m
- use data_kinds_4neuro_m
- use abstract_base_m
-
- implicit none
-
- public
-
- !----------------!------------------------------------------------------------------------------
- ! class neuron_t !
- !----------------!
-
- !> Abstract class representing a general neuron
- type, abstract, extends(abstract_base_t) :: neuron_t
- !TODO properties are public because of problems with reading from binary file - find another way
-
- real(kind=real_4neuro) :: potential !< Neuron inner potential
- real(kind=real_4neuro) :: state !< State of the neuron (0/1 for binary n. etc.)
- integer(kind=integer_4neuro) :: id !< Neuron ID
-
- contains
- !> Initalizes the common neuron_t classes components
- !! ('potential' to 0, 'state' to 0)
- procedure, private :: init_components => neuron_init_components_impl
-
- !> Adds the input signal value to the current potential
- !! @param[in] input_signal Input value
- procedure :: adjust_potential => adjust_potential_impl
-
- !> Performs the activation function and stores the result into the 'state' component
- procedure(activate_int), private, deferred :: activate
-
- !> Getter to the 'potential' component
- !! @return Value of the neuron's potential (real number)
- procedure :: get_potential => get_potential_impl
-
- !> Getter to the 'state' component
- !! @return Value of the current neuron's state
- procedure :: get_state => get_state_impl
-
- !> Getter to the 'id' component
- !! @return Neuron ID
- procedure :: get_id => get_id_impl
-
- !> Setter to the 'potential' component
- procedure :: set_potential => set_potential_impl
-
- !> Setter to the 'state' component
- procedure :: set_state => set_state_impl
-
- !> Setter to the 'id' component
- procedure :: set_id => set_id_impl
-
- !> Implementation of write function enabling the storage of
- !! allocatable arrays.
- procedure :: write_sample => write_neuron_sample
-
- !> Implementation of read function enabling to read
- !! the whole instance of net_t stored as binary file.
- procedure :: read_sample => read_neuron_sample
-
- generic :: write(unformatted) => write_sample
- generic :: read(unformatted) => read_sample
- end type neuron_t
-
- abstract interface
- subroutine activate_int(this)
- !> Interface for the deferred (i.e. abstract) method 'activate' of the clas neuron_t
-
- import neuron_t
-
- class(neuron_t), intent(inout) :: this
- end subroutine activate_int
- end interface
-
- !---------------------!------------------------------------------------------------------------
- ! class mock_neuron_t !
- !---------------------!
-
- !> Mock neuron_t class
- type, extends(neuron_t) :: mock_neuron_t
- contains
-
- !> Mock method, does nothing - it's only purpose is to override the deffered one
- procedure :: activate => mock_activate_impl
-
- !> Getter to the 'potential' component
- !! @return Number 5.0
- procedure :: get_potential => mock_get_potential_impl
-
- !> Getter to the 'state' component
- !! @return Number 15.0
- procedure :: get_state => mock_get_state_impl
- end type mock_neuron_t
-
- interface mock_neuron_t
- !> Constructor of mock_neuron_t class
- !! @return Returns an instance of the class mock_neuron_t
- module procedure :: new_mock_neuron
- end interface mock_neuron_t
-
- !-----------------------!----------------------------------------------------------------------
- ! class binary_neuron_t !
- !-----------------------!
-
- !> Binary neuron class - uses unit-step as the activation function
- type, extends(neuron_t) :: binary_neuron_t
- private
-
- real(kind=real_4neuro) :: threshold !< When neuron potential exceeds this value, neuron becomes excited
-
- contains
-
- !> Activation function - transforms potential into the output state value
- !! AND assigns it into the 'state' component
- !!
- !! Unit-step function - (returns 1 for potential > threshold, otherwise returns 0)
- procedure, private :: activate => unit_step_activate_impl
-
- end type binary_neuron_t
-
- interface binary_neuron_t
- !> Non-parametric constructor of binary_neuron_t class (threshold
- !! will be initialized by a random number from Gaussian distribution)
- !! @return An instance of the class binary_neuron_t
- module procedure :: new_binary_neuron
-
- !> Parametric constructor of binary_neuron_t class
- !! @param[in] threshold Threshold for the unit-step activation function
- !! @return An instance of the class binary_neuron_t
- module procedure :: new_binary_neuron_1
- end interface binary_neuron_t
-
- !-----------------------!----------------------------------------------------------------------
- ! class linear_neuron_t !
- !-----------------------!
-
- !> Linear neuron class - uses activation function in the form f(x)=a*x + b,
- !! 'x' being the neuron's potential
- type, extends(neuron_t) :: linear_neuron_t
- private
-
- !! Coefficients for the linear activation function in format 'f(x)=a*x + b'
- real(kind=real_4neuro) :: a_coef !< The coefficient 'a' in the activation function f(x)=a*x + b
- real(kind=real_4neuro) :: b_coef !< The coefficient 'b' in the activation function f(x)=a*x + b
-
- contains
-
- !> Activation function - f(x)=a*x + b
- procedure, private :: activate => identity_potential_activate_impl
- end type linear_neuron_t
-
- interface linear_neuron_t
- !> Non-parametric constructor of linear_neuron_t class - a coef. is 1, b coef. is 0
- !! @return An instance of the class linear_neuron_t
- module procedure :: new_linear_neuron
-
- !> Constructor of linear_neuron_t class
- !! @param[in] a_coef a coef. of the linear activation function
- !! @param[in] b_coef b coef. of the linear activation fucntion
- !! @return An instance of the class linear_neuron_t
- module procedure :: new_linear_neuron_2
- end interface linear_neuron_t
-
- !-------------------------!--------------------------------------------------------------------
- ! class logistic_neuron_t !
- !-------------------------!
-
- !> Logistic neuron class - uses generalised logistic function as an activation function
- !! in the form f(x) = (1 + e^(-x))^(-alpha),
- !! 'x' being the neuron potential here
- type, extends(neuron_t) :: logistic_neuron_t
- private
-
- real(kind=real_4neuro) :: alpha_coef !< The alpha coefficient used in the activation function
-
- contains
-
- !> Activation function - generalised logistic f.
- procedure, private :: activate => logistic_activate_impl
- end type logistic_neuron_t
-
- interface logistic_neuron_t
- !> Non-parametric constructor of logistic_neuron_t class
- !! Alpha coefficient is set to 1
- !! @return An instance of the class logistic_neuron_t
- module procedure :: new_logistic_neuron
-
- !> Constructor of the logistic_neuron_t class
- !! @param[in] alpha_coef Alpha coefficient in the logistic activation function
- !! @return An instance of the class logistic_neuron_t
- module procedure :: new_logistic_neuron_1
- end interface logistic_neuron_t
-
- !---------------------!------------------------------------------------------------------------
- ! class tanh_neuron_t !
- !---------------------!
-
- !> Hyperbolic tangent neuron class - uses f(x) = (e^x - e^(-x))/(e^x + e^(-x)) as
- !! an activation function, 'x' being the neuron potential.
- type, extends(neuron_t) :: tanh_neuron_t
- contains
-
- !> Activation function - hyperbolic tangent
- procedure, private :: activate => hyperbolic_tangent_activate_impl
- end type tanh_neuron_t
-
- interface tanh_neuron_t
- !> Constructor for an instance of the class tanh_neuron_t
- module procedure :: new_tanh_neuron
- end interface tanh_neuron_t
-
- !> Arcus tangents neuron class - uses f(x)=tan^(-1)(x) as an
- !! activation function, 'x' being the neuron potential
- type, extends(neuron_t) :: arctan_neuron_t
- contains
-
- !> Activation function - arcus tangens
- procedure, private :: activate => arcus_tangens_activate_impl
- end type arctan_neuron_t
-
- interface arctan_neuron_t
- !> Constructor for an instance of the class arctan_neuron_t
- module procedure :: new_arctan_neuron
- end interface arctan_neuron_t
-
- contains
- !------------------------!---------------------------------------------------------------------
- ! Method implementations !
- !------------------------!
-
- !----------------!
- ! class neuron_t !
- !----------------!
-
- !-------------------!--------------------------------------------------------------------------
- ! Getters & Setters !
- !-------------------!
-
- !> Getter to the 'potential' component
- !! @return Value of the neuron's potential (real number)
- function get_potential_impl(this) result(potential)
- class(neuron_t), intent(in) :: this
- real(kind=real_4neuro) :: potential
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- potential = this%potential
-
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'get_potential_impl')
-#endif
- end function get_potential_impl
-
- !> Getter to the 'state' component
- !! @return Value of the current neuron's state
- function get_state_impl(this) result(state)
- class(neuron_t), intent(in) :: this
- real(kind=real_4neuro) :: state
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- state = this%state
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'get_state_impl')
-#endif
- end function get_state_impl
-
- !> Getter to the 'id' component
- !! @return Neuron ID
- function get_id_impl(this) result(id)
- class(neuron_t), intent(in) :: this
- integer(kind=integer_4neuro) :: id
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- id = this%id
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'get_id_impl')
-#endif
- end function get_id_impl
-
- !> Setter to the 'potential' component
- !! @param[in] potential The value of potential to be set
- subroutine set_potential_impl(this, potential)
- class(neuron_t), intent(inout) :: this
- real(kind=real_4neuro), intent(in) :: potential
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- this%potential = potential
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'set_potential_impl')
-#endif
- end subroutine set_potential_impl
-
- !> Setter to the 'state' component
- !! @param[in] state The state to be set
- subroutine set_state_impl(this, state)
- class(neuron_t), intent(inout) :: this
- real(kind=real_4neuro), intent(in) :: state
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- this%state = state
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'set_state_impl')
-#endif
- end subroutine set_state_impl
-
- !> Setter to the 'id' component
- !! @param[in] id The ID of neuron to be set
- subroutine set_id_impl(this, id)
- class(neuron_t), intent(inout) :: this
- integer(kind=integer_4neuro), intent(in) :: id
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- this%id = id
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'set_id_impl')
-#endif
- end subroutine set_id_impl
-
-
- !----------------!-----------------------------------------------------------------------------
- ! Common methods !
- !----------------!
-
- !> Initalizes the common neuron_t classes components
- !! ('potential' to 0, 'state' to 0)
- subroutine neuron_init_components_impl(this)
- class(neuron_t), intent(inout) :: this
- integer(kind=integer_4neuro) :: values(8) !< values(8) used as a seed
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- this%potential = 0
- this%state = 0 !TODO maybe init with values from normal distribution
- this%id = 1 !TODO modify - should be index in the whole set of neurons
-
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'neuron_init_components_impl')
-#endif
-
- end subroutine neuron_init_components_impl
-
- !> Adds the input signal value to the current potential
- !! @param[in] input_signal Input value
- subroutine adjust_potential_impl(this, input_signal)
- class(neuron_t), intent(inout) :: this
- real(kind=real_4neuro), intent(in) :: input_signal
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- this%potential = this%potential + input_signal
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'adjust_potential_impl')
-#endif
- end subroutine adjust_potential_impl
-
- !> Implementation of write function enabling the storage of
- !! allocatable arrays.
- !! @param[in] unit Unit (handler) where the file is written
- !! @param[out] iostat Diagnostic value "returned" by the subroutine
- !! @param[inout] iomsg Explaining note about error
- subroutine write_neuron_sample(this, unit, iostat, iomsg)
- class(neuron_t), intent(in) :: this
- integer, intent(in) :: unit
- integer, intent(out) :: iostat
- character(*), intent(inout) :: iomsg
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- write(unit, iostat=iostat, iomsg=iomsg) this%potential, &
- this%state, &
- this%id
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'write_neuron_sample')
-#endif
- end subroutine write_neuron_sample
-
- ! Unformatted reading for the sample derived type
- subroutine read_neuron_sample(this, unit, iostat, iomsg)
- class(neuron_t), intent(inout) :: this
- integer, intent(in) :: unit
- integer, intent(out) :: iostat
- character(*), intent(inout) :: iomsg
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- ! And then finally the reading.
- read(unit, iostat=iostat, iomsg=iomsg) this%potential, &
- this%state, &
- this%id
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'read_neuron_sample')
-#endif
- end subroutine read_neuron_sample
-
- !---------------------!
- ! class mock_neuron_t !
- !---------------------!
-
- !----------------!----------------------------------------------------------------------------
- ! Common methods !
- !----------------!
-
- !> Mock method, does nothing - it's only purpose is to override the deffered one
- subroutine mock_activate_impl(this)
- class(mock_neuron_t), intent(inout) :: this
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
-
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'mock_activate_impl')
-#endif
- end subroutine
-
- !--------------!------------------------------------------------------------------------------
- ! Constructors !
- !--------------!
-
- !> Constructor of mock_neuron_t class
- !! @return Returns an instance of the class mock_neuron_t
- function new_mock_neuron() result(new_obj)
- type(mock_neuron_t) :: new_obj
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- call new_obj%init_components()
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'new_mock_neuron')
-#endif
- end function new_mock_neuron
-
- !---------!-----------------------------------------------------------------------------------
- ! Getters !
- !---------!
-
- !> Getter to the 'potential' component
- !! @return Number 5.0
- function mock_get_potential_impl(this) result(return_value)
- class(mock_neuron_t), intent(in) :: this
- real(kind=real_4neuro) :: return_value
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- return_value = this%potential
-
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'mock_get_potential_impl')
-#endif
- end function mock_get_potential_impl
-
- !> Getter to the 'state' component
- !! @return Number 15.0
- function mock_get_state_impl(this) result(return_value)
- class(mock_neuron_t), intent(in) :: this
- real(kind=real_4neuro) :: return_value
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- return_value = 15.0
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'mock_get_state_impl')
-#endif
- end function mock_get_state_impl
-
- !-----------------------!
- ! class binary_neuron_t !
- !-----------------------!
-
- !--------------!-----------------------------------------------------------------------------
- ! Constructors !
- !--------------!
-
- !> Non-parametric constructor of binary_neuron_t class (threshold
- !! will be initialized by a random number from Gaussian distribution)
- !! @return An instance of the class binary_neuron_t
- function new_binary_neuron() result(new_obj)
- type(binary_neuron_t) :: new_obj
- integer(kind=4) :: values(8)
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- call new_obj%init_components()
-
- ! Get current time and use milliseconds (values(8))
- ! as a seed
- call date_and_time(values=values)
-
- ! Generate random number from Gaussian distribution
- ! and use it to initialize the component 'threshold'
- new_obj%threshold = r4_normal_01(values(8))
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'new_binary_neuron')
-#endif
- end function new_binary_neuron
-
- !> Constructor of binary_neuron_t class
- !! @param[in] threshold Threshold used by unit-step activation function
- !! @return An instance of the class binary_neuron_t
- function new_binary_neuron_1(threshold) result(new_obj)
- real(kind=real_4neuro), intent(in) :: threshold
- type(binary_neuron_t) :: new_obj
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- call new_obj%init_components()
- new_obj%threshold = threshold
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'new_binary_neuron_1')
-#endif
- end function new_binary_neuron_1
-
- !----------------!---------------------------------------------------------------------------
- ! Common methods !
- !----------------!
-
- !> Activation function - transforms potential into the output state value
- !! AND assigns it into the 'state' component
- !!
- !! Unit-step function - (returns 1 for potential > threshold, otherwise returns 0)
- subroutine unit_step_activate_impl(this)
- class(binary_neuron_t), intent(inout) :: this
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
-
- if(this%potential > this%threshold) then
- this%state = 1
- else
- this%state = 0
- end if
-
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'unit_step_activate_impl')
-#endif
- end subroutine unit_step_activate_impl
-
- !-----------------------!
- ! class linear_neuron_t !
- !-----------------------!
-
- !--------------!-----------------------------------------------------------------------------
- ! Constructors !
- !--------------!
-
- !> Non-parametric constructor of linear_neuron_t class - a coef. is 1, b coef. is 0
- !! @return An instance of the class linear_neuron_t
- function new_linear_neuron() result(new_obj)
- type(linear_neuron_t) :: new_obj
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- call new_obj%init_components()
-
- new_obj%a_coef = 1
- new_obj%b_coef = 0
-
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'new_linear_neuron')
-#endif
- end function new_linear_neuron
-
- !> Constructor of linear_neuron_t class
- !! @param[in] a_coef a coef. of the linear activation function
- !! @param[in] b_coef b coef. of the linear activation fucntion
- !! @return An instance of the class linear_neuron_t
- function new_linear_neuron_2(a_coef, b_coef) result(new_obj)
- real(kind=real_4neuro), intent(in) :: a_coef
- real(kind=real_4neuro), intent(in) :: b_coef
-
- type(linear_neuron_t) :: new_obj
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- call new_obj%init_components()
-
- new_obj%a_coef = a_coef
- new_obj%b_coef = b_coef
-
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'new_linear_neuron_2')
-#endif
- end function new_linear_neuron_2
-
- !----------------!---------------------------------------------------------------------------
- ! Common methods !
- !----------------!
-
- !> Activation function - just returns the neuron's potential value
- subroutine identity_potential_activate_impl(this)
- class(linear_neuron_t), intent(inout) :: this
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
-
- this%state = this%potential
-
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'identity_potential_activate_impl')
-#endif
- end subroutine identity_potential_activate_impl
-
- !-------------------------!
- ! class logistic_neuron_t !
- !-------------------------!
-
- !--------------!-----------------------------------------------------------------------------
- ! Constructors !
- !--------------!
-
- !> Non-parametric constructor of logistic_neuron_t class
- !! Alpha coefficient is set to 1
- !! @return An instance of the class logistic_neuron_t
- function new_logistic_neuron() result(new_obj)
- type(logistic_neuron_t) :: new_obj
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- call new_obj%init_components()
- new_obj%alpha_coef = 1
-
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'new_logistic_neuron')
-#endif
- end function new_logistic_neuron
-
- !> Constructor of the logistic_neuron_t class
- !! @param[in] alpha_coef Alpha coefficient in the logistic activation function
- !! @return An instance of the class logistic_neuron_t
- function new_logistic_neuron_1(alpha_coef) result(new_obj)
- real(kind=real_4neuro), intent(in) :: alpha_coef
- type(logistic_neuron_t) :: new_obj
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- call new_obj%init_components()
- new_obj%alpha_coef = alpha_coef
-
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'new_logistic_neuron_1')
-#endif
- end function new_logistic_neuron_1
-
- !----------------!---------------------------------------------------------------------------
- ! Common methods !
- !----------------!
-
- !> Activation function - logistic function
- subroutine logistic_activate_impl(this)
- class(logistic_neuron_t), intent(inout) :: this
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- this%state = (1.0 + exp(-1*this%potential))**(-1*this%alpha_coef)
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'logistic_activate_impl')
-#endif
- end subroutine logistic_activate_impl
-
- !---------------------!
- ! class tanh_neuron_t !
- !---------------------!
-
- !--------------!------------------------------------------------------------------------------
- ! Constructors !
- !--------------!
-
- !> Constructor for an instance of the class tanh_neuron_t
- function new_tanh_neuron() result(new_obj)
- type(tanh_neuron_t) :: new_obj
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- call new_obj%init_components()
-
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'new_tanh_neuron')
-#endif
- end function new_tanh_neuron
-
- !----------------!----------------------------------------------------------------------------
- ! Common methods !
- !----------------!
-
- !> Activation function - hyperbolic tangent
- subroutine hyperbolic_tangent_activate_impl(this)
- class(tanh_neuron_t), intent(inout) :: this
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
-
-#if PREC == DOUBLE
- this%state = dtanh(this%potential)
-#else
- this%state = tanh(this%potential)
-#endif
-
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'hyperbolic_tangent_activate_impl')
-#endif
- end subroutine hyperbolic_tangent_activate_impl
-
- !-----------------------!
- ! class arctan_neuron_t !
- !-----------------------!
-
- !--------------!------------------------------------------------------------------------------
- ! Constructors !
- !--------------!
-
- !> Constructor for an instance of the class arctan_neuron_t
- function new_arctan_neuron() result(new_obj)
- type(arctan_neuron_t) :: new_obj
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
- call new_obj%init_components()
-
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'new_arctan_neuron')
-#endif
- end function new_arctan_neuron
-
- !----------------!----------------------------------------------------------------------------
- ! Common methods !
- !----------------!
-
- !> Activation function - arcus tangens
- subroutine arcus_tangens_activate_impl(this)
- class(arctan_neuron_t), intent(inout) :: this
-#ifdef TIME_PROFILING
- real :: start_time
- call time_profiling_start(start_time)
-#endif
-
-#if PREC == DOUBLE
- this%state = datan(this%potential)
-#else
- this%state = atan(this%potential)
-#endif
-
-#ifdef TIME_PROFILING
- call time_profiling_stop(start_time, 'arcus_tangens_activate_impl')
-#endif
- end subroutine arcus_tangens_activate_impl
-
-end module neuron_m
diff --git a/src/neuron_m_mem_leak_test.f90 b/src/neuron_m_mem_leak_test.f90
deleted file mode 100644
index 2558f801..00000000
--- a/src/neuron_m_mem_leak_test.f90
+++ /dev/null
@@ -1,21 +0,0 @@
-program neuron_m_mem_leak_test
- use neuron_m
-
- implicit none
-
- type(linear_neuron_t) :: ln
- type(linear_neuron_t), allocatable :: ln2
- ln = linear_neuron_t()
-
- allocate(ln2)
-
- open(123,file='neuron.test', form='unformatted')
- write(123) ln
- close(123)
-
- open(123,file='neuron.test', form='unformatted')
- read(123) ln2
- close(123)
-
- write(*,*) ln2%get_potential(), ln2%get_state(), ln2%get_id()
-end program neuron_m_mem_leak_test
diff --git a/src/normal_m.f90 b/src/normal_m.f90
deleted file mode 100644
index 58d72adc..00000000
--- a/src/normal_m.f90
+++ /dev/null
@@ -1,1593 +0,0 @@
-!> Module wrapper for the external NORMAL library
-module normal_m
- implicit none
-
- public
-
- contains
-
- function c4_normal_01 ( seed )
-
- !*****************************************************************************80
- !
- !! C4_NORMAL_01 returns a unit pseudonormal C4.
- !
- ! Licensing:
- !
- ! This code is distributed under the GNU LGPL license.
- !
- ! Modified:
- !
- ! 31 May 2007
- !
- ! Author:
- !
- ! John Burkardt
- !
- ! Parameters:
- !
- ! Input/output, integer ( kind = 4 ) SEED, a seed for the random
- ! number generator.
- !
- ! Output, complex ( kind = 4 ) C4_NORMAL_01, a unit pseudonormal value.
- !
- implicit none
-
- complex ( kind = 4 ) c4_normal_01
- real ( kind = 4 ), parameter :: r4_pi = 3.141592653589793E+00
- !real ( kind = 4 ) r4_uniform_01
- integer ( kind = 4 ) seed
- real ( kind = 4 ) v1
- real ( kind = 4 ) v2
- real ( kind = 4 ) x_c
- real ( kind = 4 ) x_r
-
- v1 = r4_uniform_01 ( seed )
- v2 = r4_uniform_01 ( seed )
-
- x_r = sqrt ( - 2.0E+00 * log ( v1 ) ) * cos ( 2.0E+00 * r4_pi * v2 )
- x_c = sqrt ( - 2.0E+00 * log ( v1 ) ) * sin ( 2.0E+00 * r4_pi * v2 )
-
- c4_normal_01 = cmplx ( x_r, x_c )
-
- return
- end
- function c8_normal_01 ( seed )
-
- !*****************************************************************************80
- !
- !! C8_NORMAL_01 returns a unit pseudonormal C8.
- !
- ! Licensing:
- !
- ! This code is distributed under the GNU LGPL license.
- !
- ! Modified:
- !
- ! 31 May 2007
- !
- ! Author:
- !
- ! John Burkardt
- !
- ! Parameters:
- !
- ! Input, integer ( kind = 4 ) SEED, a seed for the random number
- ! generator.
- !
- ! Output, complex ( kind = 8 ) C8_NORMAL_01, a sample of the PDF.
- !
- ! Output, integer ( kind = 4 ) SEED, a seed for the random number
- ! generator.
- !
- implicit none
-
- complex ( kind = 8 ) c8_normal_01
- real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00
- !real ( kind = 8 ) r8_uniform_01
- integer ( kind = 4 ) seed
- real ( kind = 8 ) v1
- real ( kind = 8 ) v2
- real ( kind = 8 ) x_c
- real ( kind = 8 ) x_r
-
- v1 = r8_uniform_01 ( seed )
- v2 = r8_uniform_01 ( seed )
-
- x_r = sqrt ( - 2.0D+00 * log ( v1 ) ) * cos ( 2.0D+00 * r8_pi * v2 )
- x_c = sqrt ( - 2.0D+00 * log ( v1 ) ) * sin ( 2.0D+00 * r8_pi * v2 )
-
- c8_normal_01 = cmplx ( x_r, x_c, kind = 8 )
-
- return
- end
- function i4_normal_ab ( a, b, seed )
-
- !*****************************************************************************80
- !
- !! I4_NORMAL_AB returns a scaled pseudonormal I4.
- !
- ! Discussion:
- !
- ! The normal probability distribution function (PDF) is sampled,
- ! with mean A and standard deviation B.
- !
- ! The result is then rounded to the nearest integer.
- !
- ! Licensing:
- !
- ! This code is distributed under the GNU LGPL license.
- !
- ! Modified:
- !
- ! 06 August 2013
- !
- ! Author:
- !
- ! John Burkardt
- !
- ! Parameters:
- !
- ! Input, real ( kind = 4 ) A, the mean of the PDF.
- !
- ! Input, real ( kind = 4 ) B, the standard deviation of the PDF.
- !
- ! Input/output, integer ( kind = 4 ) SEED, a seed for the
- ! random number generator.
- !
- ! Output, integer ( kind = 4 ) I4_NORMAL_AB, a sample of the normal PDF.
- !
- implicit none
-
- real ( kind = 4 ) a
- real ( kind = 4 ) b
- integer ( kind = 4 ) i4_normal_ab
- real ( kind = 4 ) r1
- real ( kind = 4 ) r2
- real ( kind = 4 ), parameter :: r4_pi = 3.141592653589793E+00
- !real ( kind = 4 ) r4_uniform_01
- integer ( kind = 4 ) seed
- real ( kind = 4 ) x
-
- r1 = r4_uniform_01 ( seed )
- r2 = r4_uniform_01 ( seed )
- x = sqrt ( - 2.0E+00 * log ( r1 ) ) * cos ( 2.0E+00 * r4_pi * r2 )
-
- i4_normal_ab = nint ( a + b * x )
-
- return
- end
- function i8_normal_ab ( a, b, seed )
-
- !*****************************************************************************80
- !
- !! I8_NORMAL_AB returns a scaled pseudonormal I8.
- !
- ! Discussion:
- !
- ! The normal probability distribution function (PDF) is sampled,
- ! with mean A and standard deviation B.
- !
- ! The result is then rounded to the nearest integer.
- !
- ! Licensing:
- !
- ! This code is distributed under the GNU LGPL license.
- !
- ! Modified:
- !
- ! 06 August 2013
- !
- ! Author:
- !
- ! John Burkardt
- !
- ! Parameters:
- !
- ! Input, real ( kind = 8 ) A, the mean of the PDF.
- !
- ! Input, real ( kind = 8 ) B, the standard deviation of the PDF.
- !
- ! Input/output, integer ( kind = 8 ) SEED, a seed for the
- ! random number generator.
- !
- ! Output, integer ( kind = 8 ) I8_NORMAL_AB, a sample of the normal PDF.
- !
- implicit none
-
- real ( kind = 8 ) a
- real ( kind = 8 ) b
- integer ( kind = 8 ) i8_normal_ab
- real ( kind = 8 ) r1
- real ( kind = 8 ) r2
- real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00
- !real ( kind = 8 ) r8_uniform_01
- integer ( kind = 4 ) seed
- real ( kind = 8 ) x
-
- r1 = r8_uniform_01 ( seed )
- r2 = r8_uniform_01 ( seed )
- x = sqrt ( - 2.0D+00 * log ( r1 ) ) * cos ( 2.0D+00 * r8_pi * r2 )
-
- i8_normal_ab = nint ( a + b * x )
-
- return
- end
- function r4_normal_01 ( seed )
-
- !*****************************************************************************80
- !
- !! R4_NORMAL_01 returns a unit pseudonormal R4.
- !
- ! Discussion:
- !
- ! The standard normal probability distribution function (PDF) has
- ! mean 0 and standard deviation 1.
- !
- ! Licensing:
- !
- ! This code is distributed under the GNU LGPL license.
- !
- ! Modified:
- !
- ! 06 August 2013
- !
- ! Author:
- !
- ! John Burkardt
- !
- ! Parameters:
- !
- ! Input/output, integer ( kind = 4 ) SEED, a seed for the random
- ! number generator.
- !
- ! Output, real ( kind = 4 ) R4_NORMAL_01, a sample of the standard
- ! normal PDF.
- !
- implicit none
-
- real ( kind = 4 ) r1
- real ( kind = 4 ) r2
- real ( kind = 4 ) r4_normal_01
- real ( kind = 4 ), parameter :: r4_pi = 3.141592653589793E+00
- !real ( kind = 4 ) r4_uniform_01
- integer ( kind = 4 ) seed
- real ( kind = 4 ) x
-
- r1 = r4_uniform_01 ( seed )
- r2 = r4_uniform_01 ( seed )
- x = sqrt ( - 2.0E+00 * log ( r1 ) ) * cos ( 2.0E+00 * r4_pi * r2 )
-
- r4_normal_01 = x
-
- return
- end
- function r4_normal_ab ( a, b, seed )
-
- !*****************************************************************************80
- !
- !! R4_NORMAL_AB returns a scaled pseudonormal R4.
- !
- ! Discussion:
- !
- ! The normal probability distribution function (PDF) is sampled,
- ! with mean A and standard deviation B.
- !
- ! Licensing:
- !
- ! This code is distributed under the GNU LGPL license.
- !
- ! Modified:
- !
- ! 06 August 2013
- !
- ! Author:
- !
- ! John Burkardt
- !
- ! Parameters:
- !
- ! Input, real ( kind = 4 ) A, the mean of the PDF.
- !
- ! Input, real ( kind = 4 ) B, the standard deviation of the PDF.
- !
- ! Input/output, integer ( kind = 4 ) SEED, a seed for the random
- ! number generator.
- !
- ! Output, real ( kind = 4 ) R4_NORMAL_AB, a sample of the normal PDF.
- !
- implicit none
-
- real ( kind = 4 ) a
- real ( kind = 4 ) b
- real ( kind = 4 ) r1
- real ( kind = 4 ) r2
- real ( kind = 4 ) r4_normal_ab
- real ( kind = 4 ), parameter :: r4_pi = 3.141592653589793E+00
- !real ( kind = 4 ) r4_uniform_01
- integer ( kind = 4 ) seed
- real ( kind = 4 ) x
-
- r1 = r4_uniform_01 ( seed )
- r2 = r4_uniform_01 ( seed )
- x = sqrt ( - 2.0E+00 * log ( r1 ) ) * cos ( 2.0E+00 * r4_pi * r2 )
-
- r4_normal_ab = a + b * x
-
- return
- end
- function r4_uniform_01 ( seed )
-
- !*****************************************************************************80
- !
- !! R4_UNIFORM_01 returns a unit pseudorandom R4.
- !
- ! Discussion:
- !
- ! An R4 is a real ( kind = 4 ) value.
- !
- ! This routine implements the recursion
- !
- ! seed = 16807 * seed mod ( 2^31 - 1 )
- ! r4_uniform_01 = seed / ( 2^31 - 1 )
- !
- ! The integer arithmetic never requires more than 32 bits,
- ! including a sign bit.
- !
- ! If the initial seed is 12345, then the first three computations are
- !
- ! Input Output R4_UNIFORM_01
- ! SEED SEED
- !
- ! 12345 207482415 0.096616
- ! 207482415 1790989824 0.833995
- ! 1790989824 2035175616 0.947702
- !
- ! Licensing:
- !
- ! This code is distributed under the GNU LGPL license.
- !
- ! Modified:
- !
- ! 31 May 2007
- !
- ! Author:
- !
- ! John Burkardt
- !
- ! Reference:
- !
- ! Paul Bratley, Bennett Fox, Linus Schrage,
- ! A Guide to Simulation,
- ! Second Edition,
- ! Springer, 1987,
- ! ISBN: 0387964673,
- ! LC: QA76.9.C65.B73.
- !
- ! Bennett Fox,
- ! Algorithm 647:
- ! Implementation and Relative Efficiency of Quasirandom
- ! Sequence Generators,
- ! ACM Transactions on Mathematical Software,
- ! Volume 12, Number 4, December 1986, pages 362-376.
- !
- ! Pierre L'Ecuyer,
- ! Random Number Generation,
- ! in Handbook of Simulation,
- ! edited by Jerry Banks,
- ! Wiley, 1998,
- ! ISBN: 0471134031,
- ! LC: T57.62.H37.
- !
- ! Peter Lewis, Allen Goodman, James Miller,
- ! A Pseudo-Random Number Generator for the System/360,
- ! IBM Systems Journal,
- ! Volume 8, Number 2, 1969, pages 136-143.
- !
- ! Parameters:
- !
- ! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
- ! should NOT be 0. On output, SEED has been updated.
- !
- ! Output, real ( kind = 4 ) R4_UNIFORM_01, a new pseudorandom variate,
- ! strictly between 0 and 1.
- !
- implicit none
-
- integer ( kind = 4 ), parameter :: i4_huge = 2147483647
- integer ( kind = 4 ) k
- integer ( kind = 4 ) seed
- real ( kind = 4 ) r4_uniform_01
-
- if ( seed == 0 ) then
- write ( *, '(a)' ) ' '
- write ( *, '(a)' ) 'R4_UNIFORM_01 - Fatal error!'
- write ( *, '(a)' ) ' Input value of SEED = 0.'
- stop 1
- end if
-
- k = seed / 127773
-
- seed = 16807 * ( seed - k * 127773 ) - k * 2836
-
- if ( seed < 0 ) then
- seed = seed + i4_huge
- end if
-
- r4_uniform_01 = real ( seed, kind = 4 ) * 4.656612875E-10
-
- return
- end
- subroutine r4vec_uniform_01 ( n, seed, r )
-
- !*****************************************************************************80
- !
- !! R4VEC_UNIFORM_01 returns a unit pseudorandom R4VEC.
- !
- ! Discussion:
- !
- ! An R4VEC is an array of real ( kind = 4 ) values.
- !
- ! Licensing:
- !
- ! This code is distributed under the GNU LGPL license.
- !
- ! Modified:
- !
- ! 31 May 2007
- !
- ! Author:
- !
- ! John Burkardt
- !
- ! Reference:
- !
- ! Paul Bratley, Bennett Fox, Linus Schrage,
- ! A Guide to Simulation,
- ! Second Edition,
- ! Springer, 1987,
- ! ISBN: 0387964673,
- ! LC: QA76.9.C65.B73.
- !
- ! Bennett Fox,
- ! Algorithm 647:
- ! Implementation and Relative Efficiency of Quasirandom
- ! Sequence Generators,
- ! ACM Transactions on Mathematical Software,
- ! Volume 12, Number 4, December 1986, pages 362-376.
- !
- ! Pierre L'Ecuyer,
- ! Random Number Generation,
- ! in Handbook of Simulation,
- ! edited by Jerry Banks,
- ! Wiley, 1998,
- ! ISBN: 0471134031,
- ! LC: T57.62.H37.
- !
- ! Peter Lewis, Allen Goodman, James Miller,
- ! A Pseudo-Random Number Generator for the System/360,
- ! IBM Systems Journal,
- ! Volume 8, Number 2, 1969, pages 136-143.
- !
- ! Parameters:
- !
- ! Input, integer ( kind = 4 ) N, the number of entries in the vector.
- !
- ! Input/output, integer ( kind = 4 ) SEED, the "seed" value,
- ! which should NOT be 0.
- ! On output, SEED has been updated.
- !
- ! Output, real ( kind = 4 ) R(N), the vector of pseudorandom values.
- !
- implicit none
-
- integer ( kind = 4 ) n
-
- integer ( kind = 4 ) i
- integer ( kind = 4 ), parameter :: i4_huge = 2147483647
- integer ( kind = 4 ) k
- integer ( kind = 4 ) seed
- real ( kind = 4 ) r(n)
-
- if ( seed == 0 ) then
- write ( *, '(a)' ) ' '
- write ( *, '(a)' ) 'R4VEC_UNIFORM_01 - Fatal error!'
- write ( *, '(a)' ) ' Input value of SEED = 0.'
- stop 1
- end if
-
- do i = 1, n
-
- k = seed / 127773
-
- seed = 16807 * ( seed - k * 127773 ) - k * 2836
-
- if ( seed < 0 ) then
- seed = seed + i4_huge
- end if
-
- r(i) = real ( seed, kind = 4 ) * 4.656612875E-10
-
- end do
-
- return
- end
- subroutine r4vec_normal_ab ( n, a, b, seed, x )
-
- !*****************************************************************************80
- !
- !! R4VEC_NORMAL_AB returns a scaled pseudonormal R4VEC.
- !
- ! Discussion:
- !
- ! The standard normal probability distribution function (PDF) has
- ! mean 0 and standard deviation 1.
- !
- ! An R4VEC is a vector of R4's.
- !
- ! Licensing:
- !
- ! This code is distributed under the GNU LGPL license.
- !
- ! Modified:
- !
- ! 06 August 2013
- !
- ! Author:
- !
- ! John Burkardt
- !
- ! Parameters:
- !
- ! Input, integer ( kind = 4 ) N, the number of values desired.
- !
- ! Input, real ( kind = 4 ) A, B, the mean and standard deviation.
- !
- ! Input/output, integer ( kind = 4 ) SEED, a seed for the random
- ! number generator.
- !
- ! Output, real ( kind = 4 ) X(N), a sample of the standard normal PDF.
- !
- ! Local parameters:
- !
- ! Local, real ( kind = 4 ) R(N+1), is used to store some uniform
- ! random values. Its dimension is N+1, but really it is only needed
- ! to be the smallest even number greater than or equal to N.
- !
- ! Local, integer ( kind = 4 ) X_LO_INDEX, X_HI_INDEX, records the range
- ! of entries of X that we need to compute.
- !
- implicit none
-
- integer ( kind = 4 ) n
-
- real ( kind = 4 ) a
- real ( kind = 4 ) b
- integer ( kind = 4 ) m
- real ( kind = 4 ) r(n+1)
- real ( kind = 4 ), parameter :: r4_pi = 3.141592653589793E+00
- !real ( kind = 4 ) r4_uniform_01
- integer ( kind = 4 ) seed
- real ( kind = 4 ) x(n)
- integer ( kind = 4 ) x_hi_index
- integer ( kind = 4 ) x_lo_index
- !
- ! Record the range of X we need to fill in.
- !
- x_lo_index = 1
- x_hi_index = n
- !
- ! If we need just one new value, do that here to avoid null arrays.
- !
- if ( x_hi_index - x_lo_index + 1 == 1 ) then
-
- r(1) = r4_uniform_01 ( seed )
-
- if ( r(1) == 0.0E+00 ) then
- write ( *, '(a)' ) ' '
- write ( *, '(a)' ) 'R4VEC_NORMAL_AB - Fatal error!'
- write ( *, '(a)' ) ' R4_UNIFORM_01 returned a value of 0.'
- stop 1
- end if
-
- r(2) = r4_uniform_01 ( seed )
-
- x(x_hi_index) = &
- sqrt ( - 2.0E+00 * log ( r(1) ) ) * cos ( 2.0E+00 * r4_pi * r(2) )
- !
- ! If we require an even number of values, that's easy.
- !
- else if ( mod ( x_hi_index - x_lo_index, 2 ) == 1 ) then
-
- m = ( x_hi_index - x_lo_index + 1 ) / 2
-
- call r4vec_uniform_01 ( 2*m, seed, r )
-
- x(x_lo_index:x_hi_index-1:2) = &
- sqrt ( - 2.0E+00 * log ( r(1:2*m-1:2) ) ) &
- * cos ( 2.0E+00 * r4_pi * r(2:2*m:2) )
-
- x(x_lo_index+1:x_hi_index:2) = &
- sqrt ( - 2.0E+00 * log ( r(1:2*m-1:2) ) ) &
- * sin ( 2.0E+00 * r4_pi * r(2:2*m:2) )
- !
- ! If we require an odd number of values, we generate an even number,
- ! and handle the last pair specially, storing one in X(N), and
- ! saving the other for later.
- !
- else
-
- x_hi_index = x_hi_index - 1
-
- m = ( x_hi_index - x_lo_index + 1 ) / 2 + 1
-
- call r4vec_uniform_01 ( 2*m, seed, r )
-
- x(x_lo_index:x_hi_index-1:2) = &
- sqrt ( - 2.0E+00 * log ( r(1:2*m-3:2) ) ) &
- * cos ( 2.0E+00 * r4_pi * r(2:2*m-2:2) )
-
- x(x_lo_index+1:x_hi_index:2) = &
- sqrt ( - 2.0E+00 * log ( r(1:2*m-3:2) ) ) &
- * sin ( 2.0E+00 * r4_pi * r(2:2*m-2:2) )
-
- x(n) = sqrt ( - 2.0E+00 * log ( r(2*m-1) ) ) &
- * cos ( 2.0E+00 * r4_pi * r(2*m) )
-
- end if
-
- x(1:n) = a + b * x(1:n)
-
- return
- end
- function r8_normal_01 ( seed )
-
- !*****************************************************************************80
- !
- !! R8_NORMAL_01 returns a unit pseudonormal R8.
- !
- ! Discussion:
- !
- ! The standard normal probability distribution function (PDF) has
- ! mean 0 and standard deviation 1.
- !
- ! Licensing:
- !
- ! This code is distributed under the GNU LGPL license.
- !
- ! Modified:
- !
- ! 06 August 2013
- !
- ! Author:
- !
- ! John Burkardt
- !
- ! Parameters:
- !
- ! Input/output, integer ( kind = 4 ) SEED, a seed for the random
- ! number generator.
- !
- ! Output, real ( kind = 8 ) R8_NORMAL_01, a normally distributed
- ! random value.
- !
- implicit none
-
- real ( kind = 8 ) r1
- real ( kind = 8 ) r2
- real ( kind = 8 ) r8_normal_01
- real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00
- !real ( kind = 8 ) r8_uniform_01
- integer ( kind = 4 ) seed
- real ( kind = 8 ) x
-
- r1 = r8_uniform_01 ( seed )
- r2 = r8_uniform_01 ( seed )
- x = sqrt ( - 2.0D+00 * log ( r1 ) ) * cos ( 2.0D+00 * r8_pi * r2 )
-
- r8_normal_01 = x
-
- return
- end
- function r8_normal_ab ( a, b, seed )
-
- !*****************************************************************************80
- !
- !! R8_NORMAL_AB returns a scaled pseudonormal R8.
- !
- ! Discussion:
- !
- ! The normal probability distribution function (PDF) is sampled,
- ! with mean A and standard deviation B.
- !
- ! Licensing:
- !
- ! This code is distributed under the GNU LGPL license.
- !
- ! Modified:
- !
- ! 06 August 2013
- !
- ! Author:
- !
- ! John Burkardt
- !
- ! Parameters:
- !
- ! Input, real ( kind = 8 ) A, the mean of the PDF.
- !
- ! Input, real ( kind = 8 ) B, the standard deviation of the PDF.
- !
- ! Input/output, integer ( kind = 4 ) SEED, a seed for the random
- ! number generator.
- !
- ! Output, real ( kind = 8 ) R8_NORMAL_AB, a sample of the normal PDF.
- !
- implicit none
-
- real ( kind = 8 ) a
- real ( kind = 8 ) b
- real ( kind = 8 ) r1
- real ( kind = 8 ) r2
- real ( kind = 8 ) r8_normal_ab
- real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00
- !real ( kind = 8 ) r8_uniform_01
- integer ( kind = 4 ) seed
- real ( kind = 8 ) x
-
- r1 = r8_uniform_01 ( seed )
- r2 = r8_uniform_01 ( seed )
- x = sqrt ( - 2.0D+00 * log ( r1 ) ) * cos ( 2.0D+00 * r8_pi * r2 )
-
- r8_normal_ab = a + b * x
-
- return
- end
- function r8_uniform_01 ( seed )
-
- !*****************************************************************************80
- !
- !! R8_UNIFORM_01 returns a unit pseudorandom R8.
- !
- ! Discussion:
- !
- ! This routine implements the recursion
- !
- ! seed = 16807 * seed mod ( 2^31 - 1 )
- ! r8_uniform_01 = seed / ( 2^31 - 1 )
- !
- ! The integer arithmetic never requires more than 32 bits,
- ! including a sign bit.
- !
- ! If the initial seed is 12345, then the first three computations are
- !
- ! Input Output R8_UNIFORM_01
- ! SEED SEED
- !
- ! 12345 207482415 0.096616
- ! 207482415 1790989824 0.833995
- ! 1790989824 2035175616 0.947702
- !
- ! Licensing:
- !
- ! This code is distributed under the GNU LGPL license.
- !
- ! Modified:
- !
- ! 31 May 2007
- !
- ! Author:
- !
- ! John Burkardt
- !
- ! Reference:
- !
- ! Paul Bratley, Bennett Fox, Linus Schrage,
- ! A Guide to Simulation,
- ! Second Edition,
- ! Springer, 1987,
- ! ISBN: 0387964673,
- ! LC: QA76.9.C65.B73.
- !
- ! Bennett Fox,
- ! Algorithm 647:
- ! Implementation and Relative Efficiency of Quasirandom
- ! Sequence Generators,
- ! ACM Transactions on Mathematical Software,
- ! Volume 12, Number 4, December 1986, pages 362-376.
- !
- ! Pierre L'Ecuyer,
- ! Random Number Generation,
- ! in Handbook of Simulation,
- ! edited by Jerry Banks,
- ! Wiley, 1998,
- ! ISBN: 0471134031,
- ! LC: T57.62.H37.
- !
- ! Peter Lewis, Allen Goodman, James Miller,
- ! A Pseudo-Random Number Generator for the System/360,
- ! IBM Systems Journal,
- ! Volume 8, 1969, pages 136-143.
- !
- ! Parameters:
- !
- ! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
- ! should NOT be 0.
- ! On output, SEED has been updated.
- !
- ! Output, real ( kind = 8 ) R8_UNIFORM_01, a new pseudorandom variate,
- ! strictly between 0 and 1.
- !
- implicit none
-
- integer ( kind = 4 ) k
- real ( kind = 8 ) r8_uniform_01
- integer ( kind = 4 ) seed
-
- k = seed / 127773
-
- seed = 16807 * ( seed - k * 127773 ) - k * 2836
-
- if ( seed < 0 ) then
- seed = seed + 2147483647
- end if
- !
- ! Although SEED can be represented exactly as a 32 bit integer,
- ! it generally cannot be represented exactly as a 32 bit real number!
- !
- r8_uniform_01 = real ( seed, kind = 8 ) * 4.656612875D-10
-
- return
- end
- subroutine r8mat_normal_01 ( m, n, seed, r )
-
- !*****************************************************************************80
- !
- !! R8MAT_NORMAL_01 returns a unit pseudonormal R8MAT.
- !
- ! Licensing:
- !
- ! This code is distributed under the GNU LGPL license.
- !
- ! Modified:
- !
- ! 12 November 2010
- !
- ! Author:
- !
- ! John Burkardt
- !
- ! Reference:
- !
- ! Paul Bratley, Bennett Fox, Linus Schrage,
- ! A Guide to Simulation,
- ! Second Edition,
- ! Springer, 1987,
- ! ISBN: 0387964673,
- ! LC: QA76.9.C65.B73.
- !
- ! Bennett Fox,
- ! Algorithm 647:
- ! Implementation and Relative Efficiency of Quasirandom
- ! Sequence Generators,
- ! ACM Transactions on Mathematical Software,
- ! Volume 12, Number 4, December 1986, pages 362-376.
- !
- ! Pierre L'Ecuyer,
- ! Random Number Generation,
- ! in Handbook of Simulation,
- ! edited by Jerry Banks,
- ! Wiley, 1998,
- ! ISBN: 0471134031,
- ! LC: T57.62.H37.
- !
- ! Peter Lewis, Allen Goodman, James Miller,
- ! A Pseudo-Random Number Generator for the System/360,
- ! IBM Systems Journal,
- ! Volume 8, 1969, pages 136-143.
- !
- ! Parameters:
- !
- ! Input, integer ( kind = 4 ) M, N, the number of rows and columns
- ! in the array.
- !
- ! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
- ! should NOT be 0. On output, SEED has been updated.
- !
- ! Output, real ( kind = 8 ) R(M,N), the array of pseudonormal values.
- !
- implicit none
-
- integer ( kind = 4 ) m
- integer ( kind = 4 ) n
-
- integer ( kind = 4 ) seed
- real ( kind = 8 ) r(m,n)
-
- call r8vec_normal_01 ( m * n, seed, r )
-
- return
- end
- subroutine r8mat_normal_ab ( m, n, a, b, seed, r )
-
- !*****************************************************************************80
- !
- !! R8MAT_NORMAL_AB returns a scaled pseudonormal R8MAT.
- !
- ! Licensing:
- !
- ! This code is distributed under the GNU LGPL license.
- !
- ! Modified:
- !
- ! 06 August 2013
- !
- ! Author:
- !
- ! John Burkardt
- !
- ! Reference:
- !
- ! Paul Bratley, Bennett Fox, Linus Schrage,
- ! A Guide to Simulation,
- ! Second Edition,
- ! Springer, 1987,
- ! ISBN: 0387964673,
- ! LC: QA76.9.C65.B73.
- !
- ! Bennett Fox,
- ! Algorithm 647:
- ! Implementation and Relative Efficiency of Quasirandom
- ! Sequence Generators,
- ! ACM Transactions on Mathematical Software,
- ! Volume 12, Number 4, December 1986, pages 362-376.
- !
- ! Pierre L'Ecuyer,
- ! Random Number Generation,
- ! in Handbook of Simulation,
- ! edited by Jerry Banks,
- ! Wiley, 1998,
- ! ISBN: 0471134031,
- ! LC: T57.62.H37.
- !
- ! Peter Lewis, Allen Goodman, James Miller,
- ! A Pseudo-Random Number Generator for the System/360,
- ! IBM Systems Journal,
- ! Volume 8, 1969, pages 136-143.
- !
- ! Parameters:
- !
- ! Input, integer ( kind = 4 ) M, N, the number of rows and columns
- ! in the array.
- !
- ! Input, real ( kind = 8 ) A, B, the mean and standard deviation.
- !
- ! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
- ! should NOT be 0. On output, SEED has been updated.
- !
- ! Output, real ( kind = 8 ) R(M,N), the array of pseudonormal values.
- !
- implicit none
-
- integer ( kind = 4 ) m
- integer ( kind = 4 ) n
-
- real ( kind = 8 ) a
- real ( kind = 8 ) b
- integer ( kind = 4 ) seed
- real ( kind = 8 ) r(m,n)
-
- call r8vec_normal_ab ( m * n, a, b, seed, r )
-
- return
- end
- subroutine r8mat_print ( m, n, a, title )
-
- !*****************************************************************************80
- !
- !! R8MAT_PRINT prints an R8MAT.
- !
- ! Discussion:
- !
- ! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
- !
- ! Licensing:
- !
- ! This code is distributed under the GNU LGPL license.
- !
- ! Modified:
- !
- ! 12 September 2004
- !
- ! Author:
- !
- ! John Burkardt
- !
- ! Parameters:
- !
- ! Input, integer ( kind = 4 ) M, the number of rows in A.
- !
- ! Input, integer ( kind = 4 ) N, the number of columns in A.
- !
- ! Input, real ( kind = 8 ) A(M,N), the matrix.
- !
- ! Input, character ( len = * ) TITLE, a title.
- !
- implicit none
-
- integer ( kind = 4 ) m
- integer ( kind = 4 ) n
-
- real ( kind = 8 ) a(m,n)
- character ( len = * ) title
-
- call r8mat_print_some ( m, n, a, 1, 1, m, n, title )
-
- return
- end
- subroutine r8mat_print_some ( m, n, a, ilo, jlo, ihi, jhi, title )
-
- !*****************************************************************************80
- !
- !! R8MAT_PRINT_SOME prints some of an R8MAT.
- !
- ! Discussion:
- !
- ! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
- !
- ! Licensing:
- !
- ! This code is distributed under the GNU LGPL license.
- !
- ! Modified:
- !
- ! 10 September 2009
- !
- ! Author:
- !
- ! John Burkardt
- !
- ! Parameters:
- !
- ! Input, integer ( kind = 4 ) M, N, the number of rows and columns.
- !
- ! Input, real ( kind = 8 ) A(M,N), an M by N matrix to be printed.
- !
- ! Input, integer ( kind = 4 ) ILO, JLO, the first row and column to print.
- !
- ! Input, integer ( kind = 4 ) IHI, JHI, the last row and column to print.
- !
- ! Input, character ( len = * ) TITLE, a title.
- !
- implicit none
-
- integer ( kind = 4 ), parameter :: incx = 5
- integer ( kind = 4 ) m
- integer ( kind = 4 ) n
-
- real ( kind = 8 ) a(m,n)
- character ( len = 14 ) ctemp(incx)
- integer ( kind = 4 ) i
- integer ( kind = 4 ) i2hi
- integer ( kind = 4 ) i2lo
- integer ( kind = 4 ) ihi
- integer ( kind = 4 ) ilo
- integer ( kind = 4 ) inc
- integer ( kind = 4 ) j
- integer ( kind = 4 ) j2
- integer ( kind = 4 ) j2hi
- integer ( kind = 4 ) j2lo
- integer ( kind = 4 ) jhi
- integer ( kind = 4 ) jlo
- character ( len = * ) title
-
- write ( *, '(a)' ) ' '
- write ( *, '(a)' ) trim ( title )
-
- if ( m <= 0 .or. n <= 0 ) then
- write ( *, '(a)' ) ' '
- write ( *, '(a)' ) ' (None)'
- return
- end if
-
- do j2lo = max ( jlo, 1 ), min ( jhi, n ), incx
-
- j2hi = j2lo + incx - 1
- j2hi = min ( j2hi, n )
- j2hi = min ( j2hi, jhi )
-
- inc = j2hi + 1 - j2lo
-
- write ( *, '(a)' ) ' '
-
- do j = j2lo, j2hi
- j2 = j + 1 - j2lo
- write ( ctemp(j2), '(i8,6x)' ) j
- end do
-
- write ( *, '('' Col '',5a14)' ) ctemp(1:inc)
- write ( *, '(a)' ) ' Row'
- write ( *, '(a)' ) ' '
-
- i2lo = max ( ilo, 1 )
- i2hi = min ( ihi, m )
-
- do i = i2lo, i2hi
-
- do j2 = 1, inc
-
- j = j2lo - 1 + j2
-
- if ( a(i,j) == real ( int ( a(i,j) ), kind = 8 ) ) then
- write ( ctemp(j2), '(f8.0,6x)' ) a(i,j)
- else
- write ( ctemp(j2), '(g14.6)' ) a(i,j)
- end if
-
- end do
-
- write ( *, '(i5,a,5a14)' ) i, ':', ( ctemp(j), j = 1, inc )
-
- end do
-
- end do
-
- return
- end
- subroutine r8vec_normal_01 ( n, seed, x )
-
- !*****************************************************************************80
- !
- !! R8VEC_NORMAL_01 returns a unit pseudonormal R8VEC.
- !
- ! Discussion:
- !
- ! An R8VEC is an array of double precision real values.
- !
- ! The standard normal probability distribution function (PDF) has
- ! mean 0 and standard deviation 1.
- !
- ! Licensing:
- !
- ! This code is distributed under the GNU LGPL license.
- !
- ! Modified:
- !
- ! 18 May 2014
- !
- ! Author:
- !
- ! John Burkardt
- !
- ! Parameters:
- !
- ! Input, integer ( kind = 4 ) N, the number of values desired.
- !
- ! Input/output, integer ( kind = 4 ) SEED, a seed for the random
- ! number generator.
- !
- ! Output, real ( kind = 8 ) X(N), a sample of the standard normal PDF.
- !
- ! Local parameters:
- !
- ! Local, real ( kind = 8 ) R(N+1), is used to store some uniform
- ! random values. Its dimension is N+1, but really it is only needed
- ! to be the smallest even number greater than or equal to N.
- !
- ! Local, integer ( kind = 4 ) X_LO_INDEX, X_HI_INDEX, records the range
- ! of entries of X that we need to compute
- !
- implicit none
-
- integer ( kind = 4 ) n
-
- integer ( kind = 4 ) m
- real ( kind = 8 ) r(n+1)
- real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00
- !real ( kind = 8 ) r8_uniform_01
- integer ( kind = 4 ) seed
- real ( kind = 8 ) x(n)
- integer ( kind = 4 ) x_hi_index
- integer ( kind = 4 ) x_lo_index
- !
- ! Record the range of X we need to fill in.
- !
- x_lo_index = 1
- x_hi_index = n
- !
- ! If we need just one new value, do that here to avoid null arrays.
- !
- if ( x_hi_index - x_lo_index + 1 == 1 ) then
-
- r(1) = r8_uniform_01 ( seed )
-
- if ( r(1) == 0.0D+00 ) then
- write ( *, '(a)' ) ' '
- write ( *, '(a)' ) 'R8VEC_NORMAL_01 - Fatal error!'
- write ( *, '(a)' ) ' R8_UNIFORM_01 returned a value of 0.'
- stop 1
- end if
-
- r(2) = r8_uniform_01 ( seed )
-
- x(x_hi_index) = &
- sqrt ( - 2.0D+00 * log ( r(1) ) ) * cos ( 2.0D+00 * r8_pi * r(2) )
- !
- ! If we require an even number of values, that's easy.
- !
- else if ( mod ( x_hi_index - x_lo_index, 2 ) == 1 ) then
-
- m = ( x_hi_index - x_lo_index + 1 ) / 2
-
- call r8vec_uniform_01 ( 2*m, seed, r )
-
- x(x_lo_index:x_hi_index-1:2) = &
- sqrt ( - 2.0D+00 * log ( r(1:2*m-1:2) ) ) &
- * cos ( 2.0D+00 * r8_pi * r(2:2*m:2) )
-
- x(x_lo_index+1:x_hi_index:2) = &
- sqrt ( - 2.0D+00 * log ( r(1:2*m-1:2) ) ) &
- * sin ( 2.0D+00 * r8_pi * r(2:2*m:2) )
- !
- ! If we require an odd number of values, we generate an even number,
- ! and handle the last pair specially, storing one in X(N), and
- ! saving the other for later.
- !
- else
-
- x_hi_index = x_hi_index - 1
-
- m = ( x_hi_index - x_lo_index + 1 ) / 2 + 1
-
- call r8vec_uniform_01 ( 2*m, seed, r )
-
- x(x_lo_index:x_hi_index-1:2) = &
- sqrt ( - 2.0D+00 * log ( r(1:2*m-3:2) ) ) &
- * cos ( 2.0D+00 * r8_pi * r(2:2*m-2:2) )
-
- x(x_lo_index+1:x_hi_index:2) = &
- sqrt ( - 2.0D+00 * log ( r(1:2*m-3:2) ) ) &
- * sin ( 2.0D+00 * r8_pi * r(2:2*m-2:2) )
-
- x(n) = sqrt ( - 2.0D+00 * log ( r(2*m-1) ) ) &
- * cos ( 2.0D+00 * r8_pi * r(2*m) )
-
- end if
-
- return
- end
- subroutine r8vec_normal_ab ( n, a, b, seed, x )
-
- !*****************************************************************************80
- !
- !! R8VEC_NORMAL_AB returns a scaled pseudonormal R8VEC.
- !
- ! Discussion:
- !
- ! The standard normal probability distribution function (PDF) has
- ! mean 0 and standard deviation 1.
- !
- ! Licensing:
- !
- ! This code is distributed under the GNU LGPL license.
- !
- ! Modified:
- !
- ! 06 August 2013
- !
- ! Author:
- !
- ! John Burkardt
- !
- ! Parameters:
- !
- ! Input, integer ( kind = 4 ) N, the number of values desired.
- !
- ! Input, real ( kind = 8 ) A, B, the mean and standard deviation.
- !
- ! Input/output, integer ( kind = 4 ) SEED, a seed for the random
- ! number generator.
- !
- ! Output, real ( kind = 8 ) X(N), a sample of the standard normal PDF.
- !
- ! Local parameters:
- !
- ! Local, real ( kind = 8 ) R(N+1), is used to store some uniform
- ! random values. Its dimension is N+1, but really it is only needed
- ! to be the smallest even number greater than or equal to N.
- !
- ! Local, integer ( kind = 4 ) X_LO_INDEX, X_HI_INDEX, records the range
- ! of entries of X that we need to compute.
- !
- implicit none
-
- integer ( kind = 4 ) n
-
- real ( kind = 8 ) a
- real ( kind = 8 ) b
- integer ( kind = 4 ) m
- real ( kind = 8 ) r(n+1)
- real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00
- !real ( kind = 8 ) r8_uniform_01
- integer ( kind = 4 ) seed
- real ( kind = 8 ) x(n)
- integer ( kind = 4 ) x_hi_index
- integer ( kind = 4 ) x_lo_index
- !
- ! Record the range of X we need to fill in.
- !
- x_lo_index = 1
- x_hi_index = n
- !
- ! If we need just one new value, do that here to avoid null arrays.
- !
- if ( x_hi_index - x_lo_index + 1 == 1 ) then
-
- r(1) = r8_uniform_01 ( seed )
-
- if ( r(1) == 0.0D+00 ) then
- write ( *, '(a)' ) ' '
- write ( *, '(a)' ) 'R8VEC_NORMAL_AB - Fatal error!'
- write ( *, '(a)' ) ' R8_UNIFORM_01 returned a value of 0.'
- stop 1
- end if
-
- r(2) = r8_uniform_01 ( seed )
-
- x(x_hi_index) = &
- sqrt ( - 2.0D+00 * log ( r(1) ) ) * cos ( 2.0D+00 * r8_pi * r(2) )
- !
- ! If we require an even number of values, that's easy.
- !
- else if ( mod ( x_hi_index - x_lo_index, 2 ) == 1 ) then
-
- m = ( x_hi_index - x_lo_index + 1 ) / 2
-
- call r8vec_uniform_01 ( 2*m, seed, r )
-
- x(x_lo_index:x_hi_index-1:2) = &
- sqrt ( - 2.0D+00 * log ( r(1:2*m-1:2) ) ) &
- * cos ( 2.0D+00 * r8_pi * r(2:2*m:2) )
-
- x(x_lo_index+1:x_hi_index:2) = &
- sqrt ( - 2.0D+00 * log ( r(1:2*m-1:2) ) ) &
- * sin ( 2.0D+00 * r8_pi * r(2:2*m:2) )
- !
- ! If we require an odd number of values, we generate an even number,
- ! and handle the last pair specially, storing one in X(N), and
- ! saving the other for later.
- !
- else
-
- x_hi_index = x_hi_index - 1
-
- m = ( x_hi_index - x_lo_index + 1 ) / 2 + 1
-
- call r8vec_uniform_01 ( 2*m, seed, r )
-
- x(x_lo_index:x_hi_index-1:2) = &
- sqrt ( - 2.0D+00 * log ( r(1:2*m-3:2) ) ) &
- * cos ( 2.0D+00 * r8_pi * r(2:2*m-2:2) )
-
- x(x_lo_index+1:x_hi_index:2) = &
- sqrt ( - 2.0D+00 * log ( r(1:2*m-3:2) ) ) &
- * sin ( 2.0D+00 * r8_pi * r(2:2*m-2:2) )
-
- x(n) = sqrt ( - 2.0D+00 * log ( r(2*m-1) ) ) &
- * cos ( 2.0D+00 * r8_pi * r(2*m) )
-
- end if
-
- x(1:n) = a + b * x(1:n)
-
- return
- end
- subroutine r8vec_print ( n, a, title )
-
- !*****************************************************************************80
- !
- !! R8VEC_PRINT prints an R8VEC.
- !
- ! Discussion:
- !
- ! An R8VEC is a vector of R8's.
- !
- ! Licensing:
- !
- ! This code is distributed under the GNU LGPL license.
- !
- ! Modified:
- !
- ! 22 August 2000
- !
- ! Author:
- !
- ! John Burkardt
- !
- ! Parameters:
- !
- ! Input, integer ( kind = 4 ) N, the number of components of the vector.
- !
- ! Input, real ( kind = 8 ) A(N), the vector to be printed.
- !
- ! Input, character ( len = * ) TITLE, a title.
- !
- implicit none
-
- integer ( kind = 4 ) n
-
- real ( kind = 8 ) a(n)
- integer ( kind = 4 ) i
- character ( len = * ) title
-
- write ( *, '(a)' ) ' '
- write ( *, '(a)' ) trim ( title )
- write ( *, '(a)' ) ' '
-
- do i = 1, n
- write ( *, '(2x,i8,a,1x,g16.8)' ) i, ':', a(i)
- end do
-
- return
- end
- subroutine r8vec_uniform_01 ( n, seed, r )
-
- !*****************************************************************************80
- !
- !! R8VEC_UNIFORM_01 returns a unit pseudorandom R8VEC.
- !
- ! Licensing:
- !
- ! This code is distributed under the GNU LGPL license.
- !
- ! Modified:
- !
- ! 31 May 2007
- !
- ! Author:
- !
- ! John Burkardt
- !
- ! Reference:
- !
- ! Paul Bratley, Bennett Fox, Linus Schrage,
- ! A Guide to Simulation,
- ! Second Edition,
- ! Springer, 1987,
- ! ISBN: 0387964673,
- ! LC: QA76.9.C65.B73.
- !
- ! Bennett Fox,
- ! Algorithm 647:
- ! Implementation and Relative Efficiency of Quasirandom
- ! Sequence Generators,
- ! ACM Transactions on Mathematical Software,
- ! Volume 12, Number 4, December 1986, pages 362-376.
- !
- ! Pierre L'Ecuyer,
- ! Random Number Generation,
- ! in Handbook of Simulation,
- ! edited by Jerry Banks,
- ! Wiley, 1998,
- ! ISBN: 0471134031,
- ! LC: T57.62.H37.
- !
- ! Peter Lewis, Allen Goodman, James Miller,
- ! A Pseudo-Random Number Generator for the System/360,
- ! IBM Systems Journal,
- ! Volume 8, 1969, pages 136-143.
- !
- ! Parameters:
- !
- ! Input, integer ( kind = 4 ) N, the number of entries in the vector.
- !
- ! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
- ! should NOT be 0. On output, SEED has been updated.
- !
- ! Output, real ( kind = 8 ) R(N), the vector of pseudorandom values.
- !
- implicit none
-
- integer ( kind = 4 ) n
-
- integer ( kind = 4 ) i
- integer ( kind = 4 ) k
- integer ( kind = 4 ) seed
- real ( kind = 8 ) r(n)
-
- do i = 1, n
-
- k = seed / 127773
-
- seed = 16807 * ( seed - k * 127773 ) - k * 2836
-
- if ( seed < 0 ) then
- seed = seed + 2147483647
- end if
-
- r(i) = real ( seed, kind = 8 ) * 4.656612875D-10
-
- end do
-
- return
- end
- subroutine timestamp ( )
-
- !*****************************************************************************80
- !
- !! TIMESTAMP prints the current YMDHMS date as a time stamp.
- !
- ! Example:
- !
- ! 31 May 2001 9:45:54.872 AM
- !
- ! Licensing:
- !
- ! This code is distributed under the GNU LGPL license.
- !
- ! Modified:
- !
- ! 18 May 2013
- !
- ! Author:
- !
- ! John Burkardt
- !
- ! Parameters:
- !
- ! None
- !
- implicit none
-
- character ( len = 8 ) ampm
- integer ( kind = 4 ) d
- integer ( kind = 4 ) h
- integer ( kind = 4 ) m
- integer ( kind = 4 ) mm
- character ( len = 9 ), parameter, dimension(12) :: month = (/ &
- 'January ', 'February ', 'March ', 'April ', &
- 'May ', 'June ', 'July ', 'August ', &
- 'September', 'October ', 'November ', 'December ' /)
- integer ( kind = 4 ) n
- integer ( kind = 4 ) s
- integer ( kind = 4 ) values(8)
- integer ( kind = 4 ) y
-
- call date_and_time ( values = values )
-
- y = values(1)
- m = values(2)
- d = values(3)
- h = values(5)
- n = values(6)
- s = values(7)
- mm = values(8)
-
- if ( h < 12 ) then
- ampm = 'AM'
- else if ( h == 12 ) then
- if ( n == 0 .and. s == 0 ) then
- ampm = 'Noon'
- else
- ampm = 'PM'
- end if
- else
- h = h - 12
- if ( h < 12 ) then
- ampm = 'PM'
- else if ( h == 12 ) then
- if ( n == 0 .and. s == 0 ) then
- ampm = 'Midnight'
- else
- ampm = 'AM'
- end if
- end if
- end if
-
- write ( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
- d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm )
-
- return
- end
-
-end module normal_m
diff --git a/src/time_measurement_m.f90 b/src/time_measurement_m.f90
deleted file mode 100644
index 43d01ce8..00000000
--- a/src/time_measurement_m.f90
+++ /dev/null
@@ -1,42 +0,0 @@
-!> Module containing function for time measurement, mostly
-!! for the time profiling regime
-!!
-!! @author Martin Beseda
-!! @date 2017
-module time_measurement_m
- use data_kinds_4neuro_m
-
- implicit none
-
- public
-
- contains
-
- !> Subroutine for starting time profiling
- !! @param[out] start_time Parameter, where current time will be saved (real number)
- subroutine time_profiling_start(start_time)
- real(kind=real_4neuro), intent(inout) :: start_time
-
- call cpu_time(start_time)
- end subroutine time_profiling_start
-
- !> Subroutine for stopping time profiling and
- !! printing the result.
- !!
- !! @param[in] start_time Parameter containing starting time (real number)
- !! @param[in] region_name Name of the measured region (string)
- subroutine time_profiling_stop(start_time, region_name)
- real(kind=real_4neuro), intent(in) :: start_time
- character(len=*) :: region_name
- real :: stop_time
- character(len=35) :: s
-
- s = '| TIME PROFILING | Function '
-
- call cpu_time(stop_time)
- write(*, "(A)") '+----------------+'
- write(*, "(A,A,A,E15.7,A)") s,region_name,'() was running for ',stop_time-start_time,'s.'
- write(*, "(A)") '+----------------+'
- end subroutine time_profiling_stop
-
-end module time_measurement_m
--
GitLab