223031012
/
DAMASK_EICMD
mirror of https://github.com/achalhp/DAMASK_EICMD.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity

added error for to IO to substitute stop statement in kdtree2 

explicitly defined all functions in as either public or private in the modules to have a quick overview on all functions and parameters that are available
This commit is contained in:
Martin Diehl 2012-03-06 14:52:48 +00:00
parent 9b17015b5a
commit d00c3c9e19
6 changed files with 2464 additions and 2366 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

168
code/DAMASK_spectral_interface.f90
View File

@ -1,7 +1,7 @@
! Copyright 2011 Max-Planck-Institut für Eisenforschung GmbH
!
! This file is part of DAMASK,
! the Düsseldorf Advanced MAterial Simulation Kit.
! the Düsseldorf Advanced Material Simulation Kit.
!
! DAMASK is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
@ -16,36 +16,57 @@
! You should have received a copy of the GNU General Public License
! along with DAMASK. If not, see <http://www.gnu.org/licenses/>.
!
!##############################################################
!--------------------------------------------------------------------------------------------------
!* $Id$
!********************************************************************
!--------------------------------------------------------------------------------------------------
!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH
!> @brief Interfacing between the spectral solver and the material subroutines provided
!! by DAMASK
!--------------------------------------------------------------------------------------------------
module DAMASK_interface
MODULE DAMASK_interface
implicit none
private
character(len=64), parameter, public :: FEsolver = 'Spectral' !> Keyword for spectral solver
character(len=5), parameter, public :: inputFileExtension = '.geom' !> File extension for geometry description
character(len=4), parameter, public :: logFileExtension = '.log' !> Dummy variable as the spectral solver has no log
character(len=1024), private :: geometryParameter, &
loadcaseParameter
character(len=64), parameter :: FEsolver = 'Spectral'
character(len=5), parameter :: InputFileExtension = '.geom'
character(len=4), parameter :: LogFileExtension = '.log' !until now, we don't have a log file. But IO.f90 requires it
character(len=1024) :: geometryParameter,loadcaseParameter
CONTAINS
public :: getSolverWorkingDirectoryName, &
getSolverJobName, &
getLoadCase, &
getLoadCaseName, &
getModelName, &
DAMASK_interface_init
private :: rectifyPath, &
makeRelativePath, &
getPathSep
!********************************************************************
! initialize interface module
!
!********************************************************************
subroutine DAMASK_interface_init()
contains
!--------------------------------------------------------------------------------------------------
!> @brief Initializes the solver by interpreting the command line arguments. Also writes
!! information on computation on screen
!--------------------------------------------------------------------------------------------------
subroutine DAMASK_interface_init
use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment)
use prec, only: pInt
implicit none
character(len=1024) commandLine, hostName, userName
integer :: i, start = 0, length=0
integer, dimension(8) :: date_and_time_values ! type default integer
implicit none
character(len=1024) :: commandLine, & !> command line call as string
hostName, & !> name of computer
userName !> name of user calling the executable
integer :: i, &
start = 0,&
length=0
integer, dimension(8) :: dateAndTime ! type default integer
call get_command(commandLine)
call DATE_AND_TIME(VALUES=date_and_time_values)
call date_and_time(values = dateAndTime)
do i = 1,len(commandLine) ! remove capitals
if(64<iachar(commandLine(i:i)) .and. iachar(commandLine(i:i))<91) commandLine(i:i) = &
achar(iachar(commandLine(i:i))+32)
if(64<iachar(commandLine(i:i)) .and. iachar(commandLine(i:i))<91) &
commandLine(i:i) = achar(iachar(commandLine(i:i))+32)
enddo
if(index(commandLine,' -h ',.true.) > 0 .or. index(commandLine,' --help ',.true.) > 0) then ! search for ' -h ' or '--help'
@ -146,12 +167,12 @@ subroutine DAMASK_interface_init()
write(6,*) '<<<+- DAMASK_spectral_interface init -+>>>'
write(6,*) '$Id$'
#include "compilation_info.f90"
write(6,'(a,2(i2.2,a),i4.4)') ' Date: ',date_and_time_values(3),'/',&
date_and_time_values(2),'/',&
date_and_time_values(1)
write(6,'(a,2(i2.2,a),i2.2)') ' Time: ',date_and_time_values(5),':',&
date_and_time_values(6),':',&
date_and_time_values(7)
write(6,'(a,2(i2.2,a),i4.4)') ' Date: ',dateAndTime(3),'/',&
dateAndTime(2),'/',&
dateAndTime(1)
write(6,'(a,2(i2.2,a),i2.2)') ' Time: ',dateAndTime(5),':',&
dateAndTime(6),':',&
dateAndTime(7)
write(6,*) 'Host Name: ', trim(hostName)
write(6,*) 'User Name: ', trim(userName)
write(6,*) 'Path Separator: ', getPathSep()
@ -162,15 +183,13 @@ subroutine DAMASK_interface_init()
end subroutine DAMASK_interface_init
!********************************************************************
! extract working directory from loadcase file
! possibly based on current working dir
!********************************************************************
!--------------------------------------------------------------------------------------------------
!> @brief extract working directory from loadcase file possibly based on current working dir
!--------------------------------------------------------------------------------------------------
function getSolverWorkingDirectoryName()
implicit none
character(len=1024) cwd,getSolverWorkingDirectoryName
character(len=1024) :: cwd, getSolverWorkingDirectoryName
character :: pathSep
pathSep = getPathSep()
@ -186,31 +205,27 @@ function getSolverWorkingDirectoryName()
end function getSolverWorkingDirectoryName
!********************************************************************
! basename of geometry file from command line arguments
!
!********************************************************************
function getSolverJobName()
!--------------------------------------------------------------------------------------------------
!> @brief basename of geometry file from command line arguments
!--------------------------------------------------------------------------------------------------
character(len=1024) function getSolverJobName()
implicit none
character(1024) :: getSolverJobName
getSolverJobName = trim(getModelName())//'_'//trim(getLoadCase())
end function getSolverJobName
!********************************************************************
! basename of geometry file from command line arguments
!
!********************************************************************
function getModelName()
!--------------------------------------------------------------------------------------------------
!> @brief basename of geometry file from command line arguments
!--------------------------------------------------------------------------------------------------
character(len=1024) function getModelName()
use prec, only: pInt
implicit none
character(1024) getModelName, cwd
character(len=1024) :: cwd
integer :: posExt,posSep
character :: pathSep
@ -233,15 +248,13 @@ function getModelName()
end function getModelName
!********************************************************************
! name of load case file exluding extension
!
!********************************************************************
function getLoadCase()
!--------------------------------------------------------------------------------------------------
!> @brief name of load case file exluding extension
!--------------------------------------------------------------------------------------------------
character(len=1024) function getLoadCase()
implicit none
character(1024) :: getLoadCase
integer :: posExt,posSep
character :: pathSep
@ -255,15 +268,13 @@ function getLoadCase()
end function getLoadCase
!********************************************************************
! relative path of loadcase from command line arguments
!
!********************************************************************
function getLoadcaseName()
!--------------------------------------------------------------------------------------------------
!> @brief relative path of loadcase from command line arguments
!--------------------------------------------------------------------------------------------------
character(len=1024) function getLoadcaseName()
implicit none
character(len=1024) :: getLoadcaseName,cwd
character(len=1024) :: cwd
integer :: posExt = 0, posSep
character :: pathSep
@ -285,14 +296,12 @@ function getLoadcaseName()
end function getLoadcaseName
!********************************************************************
! remove ../ and ./ from path
!
!********************************************************************
!--------------------------------------------------------------------------------------------------
!> @brief remove ../ and ./ from path
!--------------------------------------------------------------------------------------------------
function rectifyPath(path)
implicit none
character(len=*) :: path
character(len=len_trim(path)) :: rectifyPath
character :: pathSep
@ -327,16 +336,13 @@ function rectifyPath(path)
end function rectifyPath
!********************************************************************
! relative path from absolute a to absolute b
!
!********************************************************************
function makeRelativePath(a,b)
!--------------------------------------------------------------------------------------------------
!> @brief relative path from absolute a to absolute b
!--------------------------------------------------------------------------------------------------
character(len=1024) function makeRelativePath(a,b)
implicit none
character (len=*) :: a,b
character (len=1024) :: makeRelativePath
character :: pathSep
integer :: i,posLastCommonSlash,remainingSlashes !no pInt
@ -356,15 +362,15 @@ function makeRelativePath(a,b)
end function makeRelativePath
!********************************************************************
! counting / and \ in $PATH System variable
! the character occuring more often is assumed to be the path separator
!********************************************************************
function getPathSep()
!--------------------------------------------------------------------------------------------------
!> @brief counting / and \ in $PATH System variable the character occuring more often is assumed
!! to be the path separator
!--------------------------------------------------------------------------------------------------
character function getPathSep()
use prec, only: pInt
implicit none
character :: getPathSep
character(len=2048) path
integer(pInt) :: backslash = 0_pInt, slash = 0_pInt
integer :: i
@ -383,4 +389,4 @@ function getPathSep()
end function
END MODULE
end module

1011
code/IO.f90
View File

File diff suppressed because it is too large Load Diff

23
code/Makefile
View File

@ -135,8 +135,7 @@ COMPILE_OPTIONS_ifort :=-fpp\
-warn ignore_loc\
-warn alignments\
-warn unused\
-warn errors\
-warn stderrors
-warn errors
endif
#-fpp: preprocessor
@ -152,7 +151,7 @@ endif
# alignments: data that is not naturally aligned
# unused: declared variables that are never used
# errors: warnings are changed to errors
# stderrors: warnings about Fortran standard violations are changed to errors
# stderrors: warnings about Fortran standard violations are changed to errors (STANDARD_CHECK)
#
###################################################################################################
#MORE OPTIONS FOR DEBUGGING DURING COMPILING
@ -182,7 +181,8 @@ endif
###################################################################################################
ifeq "$(FASTBUILD)" "YES"
COMPILE_OPTIONS_gfortran :=-xf95-cpp-input
COMPILE_OPTIONS_gfortran :=-xf95-cpp-input\
-fno-range-check
else
COMPILE_OPTIONS_gfortran :=-xf95-cpp-input\
-ffree-line-length-132\
@ -205,7 +205,8 @@ COMPILE_OPTIONS_gfortran :=-xf95-cpp-input\
-Wunsafe-loop-optimizations\
-Wunused\
-Wall\
-Wextra
-Wextra\
-Wintrinsics-std
endif
#-xf95-cpp-input: preprocessor
@ -231,20 +232,20 @@ endif
# -value:
# -parameter: find usused variables with "parameter" attribute
#-Wextra:
#-Wintrinsics-std: warnings because of "flush" is not longer in the standard, but still an intrinsic fuction of the compilers:
###################################################################################################
#OPTIONS FOR GFORTRAN 4.6
#-Wsuggest-attribute=const:
#-Wsuggest-attribute=noreturn:
#-Wsuggest-attribute=pure:
#-Wreal-q-constant: Warn about real-literal-constants with 'q' exponent-letter
#
#MORE OPTIONS FOR DEBUGGING DURING COMPILING
#-Wline-truncation: too many warnings because we have comments beyond character 132
#-Wintrinsic-std: warnings because of "flush" is not longer in the standard, but still an intrinsic fuction of the compilers:
#-Warray-temporarieswarnings:
# because we have many temporary arrays (performance issue?):
#-Wimplicit-interface
#-pedantic-errors
#-fmodule-private
#-Warray-temporarieswarnings: because we have many temporary arrays (performance issue?):
#-Wimplicit-interface:
#-pedantic-errors:
#-fmodule-private:
#
#OPTIONS FOR DEGUBBING DURING RUNTIME
#-fcheck-bounds: check if an array index is too small (<1) or too large!

95
code/kdtree2.f90
View File

@ -12,12 +12,15 @@
!#######################################################
module kdtree2_priority_queue_module
use prec
use prec, only: pInt, &
pReal
!
! maintain a priority queue (PQ) of data, pairs of 'priority/payload',
! implemented with a binary heap. This is the type, and the 'dis' field
! is the priority.
!
implicit none
private
type kdtree2_result
! a pair of distances, indexes
real(pReal) :: dis = 0.0_pReal
@ -74,11 +77,9 @@ module kdtree2_priority_queue_module
public :: pq_create
public :: pq_delete, pq_insert
public :: pq_extract_max, pq_max, pq_replace_max, pq_maxpri
private
contains
function pq_create(results_in) result(res)
!
! Create a priority queue from ALREADY allocated
@ -93,6 +94,7 @@ contains
! allocate(x(1000),k(1000))
! pq => pq_create(x,k)
!
implicit none
type(kdtree2_result), target:: results_in(:)
type(pq) :: res
!
@ -147,6 +149,7 @@ contains
! heap canonical form. This is performance critical
! and has been tweaked a little to reflect this.
!
implicit none
type(pq),pointer :: a
integer(pInt), intent(in) :: i_in
!
@ -224,26 +227,30 @@ bigloop: do
! on the queue, which should be the first one, if it is
! in heapified form.
!
use IO, only: IO_error
implicit none
type(pq),pointer :: a
type(kdtree2_result),intent(out) :: e
if (a%heap_size .gt. 0) then
e = a%elems(1)
else
write (*,*) 'PQ_MAX: ERROR, heap_size < 1'
stop
call IO_error (500_pInt, ext_msg='PQ_MAX: heap_size < 1')
endif
return
end subroutine pq_max
real(pReal) function pq_maxpri(a)
use IO, only: IO_error
implicit none
type(pq), pointer :: a
if (a%heap_size .gt. 0) then
pq_maxpri = a%elems(1)%dis
else
write (*,*) 'PQ_MAX_PRI: ERROR, heapsize < 1'
stop
call IO_error (500_pInt,ext_msg='PPQ_MAX_PRI: heap_size < 1')
endif
return
end function pq_maxpri
@ -254,6 +261,9 @@ bigloop: do
! element, and remove it from the queue.
! (equivalent to 'pop()' on a stack)
!
use IO, only: IO_error
implicit none
type(pq),pointer :: a
type(kdtree2_result), intent(out) :: e
@ -271,10 +281,8 @@ bigloop: do
call heapify(a,1_pInt)
return
else
write (*,*) 'PQ_EXTRACT_MAX: error, attempted to pop non-positive PQ'
stop
call IO_error (500_pInt,ext_msg='PQ_EXTRACT_MAX: attempted to pop non-positive PQ')
end if
end subroutine pq_extract_max
@ -283,6 +291,7 @@ bigloop: do
! Insert a new element and return the new maximum priority,
! which may or may not be the same as the old maximum priority.
!
implicit none
type(pq),pointer :: a
real(pReal), intent(in) :: dis
integer(pInt), intent(in) :: idx
@ -323,6 +332,7 @@ bigloop: do
end function pq_insert
subroutine pq_adjust_heap(a,i)
implicit none
type(pq), pointer :: a
integer(pInt), intent(in) :: i
!
@ -370,6 +380,7 @@ bigloop: do
! the new maximum priority, which may be larger
! or smaller than the old one.
!
implicit none
type(pq),pointer :: a
real(pReal), intent(in) :: dis
integer(pInt), intent(in) :: idx
@ -438,12 +449,14 @@ bigloop: do
!
! delete item with index 'i'
!
use IO, only: IO_error
implicit none
type(pq),pointer :: a
integer(pInt) :: i
if ((i .lt. 1) .or. (i .gt. a%heap_size)) then
write (*,*) 'PQ_DELETE: error, attempt to remove out of bounds element.'
stop
call IO_error (500_pInt,ext_msg='PQ_DELETE: attempt to remove out of bounds element')
endif
! swap the item to be deleted with the last element
@ -461,6 +474,9 @@ end module kdtree2_priority_queue_module
module kdtree2_module
use prec
use kdtree2_priority_queue_module
implicit none
private
! K-D tree routines in Fortran 90 by Matt Kennel.
! Original program was written in Sather by Steve Omohundro and
! Matt Kennel. Only the Euclidean metric is supported.
@ -583,9 +599,6 @@ module kdtree2_module
integer(pInt), pointer :: ind(:) ! temp pointer to indexes
end type tree_search_record
private
! everything else is private.
type(tree_search_record), save, target :: sr ! A GLOBAL VARIABLE for search
contains
@ -614,6 +627,9 @@ contains
! building takes longer, and extra memory is used.
!
! .. Function Return Cut_value ..
use IO, only: IO_error
implicit none
type (kdtree2), pointer :: mr
integer(pInt), intent(in), optional :: myDim
logical, intent(in), optional :: sort
@ -643,7 +659,7 @@ contains
write (*,*) 'KD_TREE_TRANS: note, that new format is myData(1:D,1:N)'
write (*,*) 'KD_TREE_TRANS: with usually N >> D. If N =approx= D, then a k-d tree'
write (*,*) 'KD_TREE_TRANS: is not an appropriate data structure.'
stop
call IO_error (500_pInt)
end if
call build_tree(mr)
@ -673,6 +689,7 @@ contains
end function kdtree2_create
subroutine build_tree(tp)
implicit none
type (kdtree2), pointer :: tp
! ..
integer(pInt) :: j
@ -687,6 +704,7 @@ contains
recursive function build_tree_for_range(tp,l,u,parent) result (res)
! .. Function Return Cut_value ..
implicit none
type (tree_node), pointer :: res
! ..
! .. Structure Arguments ..
@ -823,8 +841,7 @@ contains
end if
end function build_tree_for_range
integer(pInt) function select_on_coordinate_value(v,ind,c,alpha,li,ui) &
result(res)
integer(pInt) function select_on_coordinate_value(v,ind,c,alpha,li,ui) result(res)
! Move elts of ind around between l and u, so that all points
! <= than alpha (in c cooordinate) are first, and then
! all points > alpha are second.
@ -842,6 +859,7 @@ contains
! The algorithm finishes when the unknown stack is empty.
!
! .. Scalar Arguments ..
implicit none
integer(pInt), intent (In) :: c, li, ui
real(pReal), intent(in) :: alpha
! ..
@ -889,6 +907,7 @@ contains
! element
! is >= those below, <= those above, in the coordinate c.
! .. Scalar Arguments ..
implicit none
integer(pInt), intent (In) :: c, k, li, ui
! ..
integer(pInt) :: i, l, m, s, t, u
@ -923,6 +942,7 @@ contains
! Return lower bound in 'smin', and upper in 'smax',
! ..
! .. Structure Arguments ..
implicit none
type (kdtree2), pointer :: tp
type(interval), intent(out) :: interv
! ..
@ -970,6 +990,7 @@ contains
subroutine kdtree2_destroy(tp)
! Deallocates all memory for the tree, except input data matrix
! .. Structure Arguments ..
implicit none
type (kdtree2), pointer :: tp
! ..
call destroy_node(tp%root)
@ -988,6 +1009,7 @@ contains
contains
recursive subroutine destroy_node(np)
! .. Structure Arguments ..
implicit none
type (tree_node), pointer :: np
! ..
! .. Intrinsic Functions ..
@ -1013,6 +1035,7 @@ contains
! Find the 'nn' vectors in the tree nearest to 'qv' in euclidean norm
! returning their indexes and distances in 'indexes' and 'distances'
! arrays already allocated passed to this subroutine.
implicit none
type (kdtree2), pointer :: tp
real(pReal), target, intent (In) :: qv(:)
integer(pInt), intent (In) :: nn
@ -1056,6 +1079,7 @@ contains
! Find the 'nn' vectors in the tree nearest to point 'idxin',
! with correlation window 'correltime', returing results in
! results(:), which must be pre-allocated upon entry.
implicit none
type (kdtree2), pointer :: tp
integer(pInt), intent (In) :: idxin, correltime, nn
type(kdtree2_result), target :: results(:)
@ -1106,6 +1130,7 @@ contains
! the smallest ball inside norm r^2
!
! Results are NOT sorted unless tree was created with sort option.
implicit none
type (kdtree2), pointer :: tp
real(pReal), target, intent (In) :: qv(:)
real(pReal), intent(in) :: r2
@ -1156,14 +1181,14 @@ contains
return
end subroutine kdtree2_r_nearest
subroutine kdtree2_r_nearest_around_point(tp,idxin,correltime,r2,&
nfound,nalloc,results)
subroutine kdtree2_r_nearest_around_point(tp,idxin,correltime,r2,nfound,nalloc,results)
!
! Like kdtree2_r_nearest, but around a point 'idxin' already existing
! in the data set.
!
! Results are NOT sorted unless tree was created with sort option.
!
implicit none
type (kdtree2), pointer :: tp
integer(pInt), intent (In) :: idxin, correltime, nalloc
real(pReal), intent(in) :: r2
@ -1225,6 +1250,7 @@ contains
function kdtree2_r_count(tp,qv,r2) result(nfound)
! Count the number of neighbors within square distance 'r2'.
implicit none
type (kdtree2), pointer :: tp
real(pReal), target, intent (In) :: qv(:)
real(pReal), intent(in) :: r2
@ -1267,11 +1293,11 @@ contains
return
end function kdtree2_r_count
function kdtree2_r_count_around_point(tp,idxin,correltime,r2) &
result(nfound)
function kdtree2_r_count_around_point(tp,idxin,correltime,r2) result(nfound)
! Count the number of neighbors within square distance 'r2' around
! point 'idxin' with decorrelation time 'correltime'.
!
implicit none
type (kdtree2), pointer :: tp
integer(pInt), intent (In) :: correltime, idxin
real(pReal), intent(in) :: r2
@ -1322,12 +1348,13 @@ contains
!
! make sure we have enough storage for n
!
use IO, only: IO_error
implicit none
integer(pInt), intent(in) :: n
if (int(size(sr%results,1),pInt) .lt. n) then
write (*,*) 'KD_TREE_TRANS: you did not provide enough storage for results(1:n)'
stop
return
call IO_error (500_pInt,ext_msg='KD_TREE_TRANS: not enough storage for results(1:n)')
endif
return
@ -1337,12 +1364,10 @@ contains
! distance between iv[1:n] and qv[1:n]
! .. Function Return Value ..
! re-implemented to improve vectorization.
implicit none
real(pReal) :: res
! ..
! ..
! .. Scalar Arguments ..
integer(pInt) :: d
! ..
! .. Array Arguments ..
real(pReal) :: iv(:),qv(:)
! ..
@ -1358,6 +1383,7 @@ contains
! This version uses a logically complete secondary search of
! "box in bounds", whether the sear
!
implicit none
type (Tree_node), pointer :: node
! ..
type(tree_node),pointer :: ncloser, nfarther
@ -1428,6 +1454,8 @@ contains
real(pReal) function dis2_from_bnd(x,amin,amax) result (res)
implicit none
real(pReal), intent(in) :: x, amin,amax
if (x > amax) then
@ -1452,6 +1480,7 @@ contains
! for all coordinates outside the box. Coordinates inside the box
! contribute nothing to the distance.
!
implicit none
type (tree_node), pointer :: node
type (tree_search_record), pointer :: sr
@ -1482,6 +1511,7 @@ contains
! Look for actual near neighbors in 'node', and update
! the search results on the sr data structure.
!
implicit none
type (tree_node), pointer :: node
!
real(pReal), pointer :: qv(:)
@ -1588,6 +1618,7 @@ contains
! the search results on the sr data structure, i.e.
! save all within a fixed ball.
!
implicit none
type (tree_node), pointer :: node
!
real(pReal), pointer :: qv(:)
@ -1678,6 +1709,7 @@ contains
! only use this subroutine for testing, as it is SLOW! The
! whole point of a k-d tree is to avoid doing what this subroutine
! does.
implicit none
type (kdtree2), pointer :: tp
real(pReal), intent (In) :: qv(:)
integer(pInt), intent (In) :: nn
@ -1718,6 +1750,7 @@ contains
! only use this subroutine for testing, as it is SLOW! The
! whole point of a k-d tree is to avoid doing what this subroutine
! does.
implicit none
type (kdtree2), pointer :: tp
real(pReal), intent (In) :: qv(:)
real(pReal), intent (In) :: r2
@ -1756,6 +1789,7 @@ contains
subroutine kdtree2_sort_results(nfound,results)
! Use after search to sort results(1:nfound) in order of increasing
! distance.
implicit none
integer(pInt), intent(in) :: nfound
type(kdtree2_result), target :: results(:)
!
@ -1775,6 +1809,7 @@ contains
!
! If ind(k) = k upon input, then it will give a sort index upon output.
!
implicit none
integer(pInt),intent(in) :: n
real(pReal), intent(inout) :: a(:)
integer(pInt), intent(inout) :: ind(:)
@ -1833,6 +1868,7 @@ contains
! Sort a(1:n) in ascending order
!
!
implicit none
integer(pInt),intent(in) :: n
type(kdtree2_result),intent(inout) :: a(:)
@ -1885,6 +1921,3 @@ contains
end subroutine heapsort_struct
end module kdtree2_module
!#############################################################################################################################
! END KDTREE2
!#############################################################################################################################

17
code/prec.f90
View File

@ -19,11 +19,11 @@
!##############################################################
!* $Id$
!##############################################################
MODULE prec
module prec
!##############################################################
implicit none
private
! *** Precision of real and integer variables ***
integer, parameter, public :: pReal = selected_real_kind(15,300) ! 15 significant digits, up to 1e+-300
integer, parameter, public :: pInt = selected_int_kind(9) ! up to +- 1e9
@ -43,16 +43,19 @@ real(pReal), parameter, public :: tol_gravityNodePos = 1.0e-100_pReal
#else
real(pReal), parameter, public :: DAMASK_NaN = real(Z'7FF0000000000001', pReal)
#endif
type :: p_vec
type, public :: p_vec
real(pReal), dimension(:), pointer :: p
end type p_vec
CONTAINS
public :: prec_init
contains
subroutine prec_init
use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment)
implicit none
implicit none
!$OMP CRITICAL (write2out)
write(6,*)
write(6,*) '<<<+- prec init -+>>>'
@ -67,6 +70,6 @@ implicit none
write(6,*)
!$OMP END CRITICAL (write2out)
end subroutine
end subroutine prec_init
END MODULE prec
end module prec

16
code/prec_single.f90
View File

@ -19,11 +19,11 @@
!##############################################################
!* $Id$
!##############################################################
MODULE prec
module prec
!##############################################################
implicit none
private
! *** Precision of real and integer variables ***
integer, parameter, public :: pReal = selected_real_kind(6,37) ! 6 significant digits, up to 1e+-37
integer, parameter, public :: pInt = selected_int_kind(9) ! up to +- 1e9
@ -43,14 +43,18 @@ real(pReal), parameter, public :: tol_gravityNodePos = 1.0e-36_pReal
#else
real(pReal), parameter, public :: DAMASK_NaN = real(Z'7F800001', pReal)
#endif
type :: p_vec
type, public :: p_vec
real(pReal), dimension(:), pointer :: p
end type p_vec
CONTAINS
public :: prec_init
contains
subroutine prec_init
use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment)
implicit none
!$OMP CRITICAL (write2out)
@ -67,6 +71,6 @@ implicit none
write(6,*)
!$OMP END CRITICAL (write2out)
end subroutine
end subroutine prec_init
END MODULE prec
end module prec