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 ! Copyright 2011 Max-Planck-Institut für Eisenforschung GmbH
! !
! This file is part of DAMASK, ! 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 ! DAMASK is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by ! 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 ! You should have received a copy of the GNU General Public License
! along with DAMASK. If not, see <http://www.gnu.org/licenses/>. ! along with DAMASK. If not, see <http://www.gnu.org/licenses/>.
! !
!############################################################## !--------------------------------------------------------------------------------------------------
!* $Id$ !* $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 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' public :: getSolverWorkingDirectoryName, &
character(len=5), parameter :: InputFileExtension = '.geom' getSolverJobName, &
character(len=4), parameter :: LogFileExtension = '.log' !until now, we don't have a log file. But IO.f90 requires it getLoadCase, &
character(len=1024) :: geometryParameter,loadcaseParameter getLoadCaseName, &
CONTAINS getModelName, &
DAMASK_interface_init
private :: rectifyPath, &
makeRelativePath, &
getPathSep
!******************************************************************** contains
! initialize interface module
! !--------------------------------------------------------------------------------------------------
!******************************************************************** !> @brief Initializes the solver by interpreting the command line arguments. Also writes
subroutine DAMASK_interface_init() !! 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, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment)
use prec, only: pInt use prec, only: pInt
implicit none
character(len=1024) commandLine, hostName, userName implicit none
integer :: i, start = 0, length=0 character(len=1024) :: commandLine, & !> command line call as string
integer, dimension(8) :: date_and_time_values ! type default integer 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 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 do i = 1,len(commandLine) ! remove capitals
if(64<iachar(commandLine(i:i)) .and. iachar(commandLine(i:i))<91) commandLine(i:i) = & if(64<iachar(commandLine(i:i)) .and. iachar(commandLine(i:i))<91) &
achar(iachar(commandLine(i:i))+32) commandLine(i:i) = achar(iachar(commandLine(i:i))+32)
enddo enddo
if(index(commandLine,' -h ',.true.) > 0 .or. index(commandLine,' --help ',.true.) > 0) then ! search for ' -h ' or '--help' 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,*) '<<<+- DAMASK_spectral_interface init -+>>>'
write(6,*) '$Id$' write(6,*) '$Id$'
#include "compilation_info.f90" #include "compilation_info.f90"
write(6,'(a,2(i2.2,a),i4.4)') ' Date: ',date_and_time_values(3),'/',& write(6,'(a,2(i2.2,a),i4.4)') ' Date: ',dateAndTime(3),'/',&
date_and_time_values(2),'/',& dateAndTime(2),'/',&
date_and_time_values(1) dateAndTime(1)
write(6,'(a,2(i2.2,a),i2.2)') ' Time: ',date_and_time_values(5),':',& write(6,'(a,2(i2.2,a),i2.2)') ' Time: ',dateAndTime(5),':',&
date_and_time_values(6),':',& dateAndTime(6),':',&
date_and_time_values(7) dateAndTime(7)
write(6,*) 'Host Name: ', trim(hostName) write(6,*) 'Host Name: ', trim(hostName)
write(6,*) 'User Name: ', trim(userName) write(6,*) 'User Name: ', trim(userName)
write(6,*) 'Path Separator: ', getPathSep() write(6,*) 'Path Separator: ', getPathSep()
@ -162,15 +183,13 @@ subroutine DAMASK_interface_init()
end subroutine DAMASK_interface_init end subroutine DAMASK_interface_init
!******************************************************************** !--------------------------------------------------------------------------------------------------
! extract working directory from loadcase file !> @brief extract working directory from loadcase file possibly based on current working dir
! possibly based on current working dir !--------------------------------------------------------------------------------------------------
!********************************************************************
function getSolverWorkingDirectoryName() function getSolverWorkingDirectoryName()
implicit none implicit none
character(len=1024) :: cwd, getSolverWorkingDirectoryName
character(len=1024) cwd,getSolverWorkingDirectoryName
character :: pathSep character :: pathSep
pathSep = getPathSep() pathSep = getPathSep()
@ -186,31 +205,27 @@ function getSolverWorkingDirectoryName()
end function getSolverWorkingDirectoryName end function getSolverWorkingDirectoryName
!********************************************************************
! basename of geometry file from command line arguments !--------------------------------------------------------------------------------------------------
! !> @brief basename of geometry file from command line arguments
!******************************************************************** !--------------------------------------------------------------------------------------------------
function getSolverJobName() character(len=1024) function getSolverJobName()
implicit none implicit none
character(1024) :: getSolverJobName
getSolverJobName = trim(getModelName())//'_'//trim(getLoadCase()) getSolverJobName = trim(getModelName())//'_'//trim(getLoadCase())
end function getSolverJobName end function getSolverJobName
!********************************************************************
! basename of geometry file from command line arguments !--------------------------------------------------------------------------------------------------
! !> @brief basename of geometry file from command line arguments
!******************************************************************** !--------------------------------------------------------------------------------------------------
function getModelName() character(len=1024) function getModelName()
use prec, only: pInt use prec, only: pInt
implicit none implicit none
character(len=1024) :: cwd
character(1024) getModelName, cwd
integer :: posExt,posSep integer :: posExt,posSep
character :: pathSep character :: pathSep
@ -233,15 +248,13 @@ function getModelName()
end function getModelName end function getModelName
!********************************************************************
! name of load case file exluding extension !--------------------------------------------------------------------------------------------------
! !> @brief name of load case file exluding extension
!******************************************************************** !--------------------------------------------------------------------------------------------------
function getLoadCase() character(len=1024) function getLoadCase()
implicit none implicit none
character(1024) :: getLoadCase
integer :: posExt,posSep integer :: posExt,posSep
character :: pathSep character :: pathSep
@ -255,15 +268,13 @@ function getLoadCase()
end function getLoadCase end function getLoadCase
!******************************************************************** !--------------------------------------------------------------------------------------------------
! relative path of loadcase from command line arguments !> @brief relative path of loadcase from command line arguments
! !--------------------------------------------------------------------------------------------------
!******************************************************************** character(len=1024) function getLoadcaseName()
function getLoadcaseName()
implicit none implicit none
character(len=1024) :: cwd
character(len=1024) :: getLoadcaseName,cwd
integer :: posExt = 0, posSep integer :: posExt = 0, posSep
character :: pathSep character :: pathSep
@ -285,14 +296,12 @@ function getLoadcaseName()
end function getLoadcaseName end function getLoadcaseName
!******************************************************************** !--------------------------------------------------------------------------------------------------
! remove ../ and ./ from path !> @brief remove ../ and ./ from path
! !--------------------------------------------------------------------------------------------------
!********************************************************************
function rectifyPath(path) function rectifyPath(path)
implicit none implicit none
character(len=*) :: path character(len=*) :: path
character(len=len_trim(path)) :: rectifyPath character(len=len_trim(path)) :: rectifyPath
character :: pathSep character :: pathSep
@ -327,16 +336,13 @@ function rectifyPath(path)
end function rectifyPath end function rectifyPath
!******************************************************************** !--------------------------------------------------------------------------------------------------
! relative path from absolute a to absolute b !> @brief relative path from absolute a to absolute b
! !--------------------------------------------------------------------------------------------------
!******************************************************************** character(len=1024) function makeRelativePath(a,b)
function makeRelativePath(a,b)
implicit none implicit none
character (len=*) :: a,b character (len=*) :: a,b
character (len=1024) :: makeRelativePath
character :: pathSep character :: pathSep
integer :: i,posLastCommonSlash,remainingSlashes !no pInt integer :: i,posLastCommonSlash,remainingSlashes !no pInt
@ -356,15 +362,15 @@ function makeRelativePath(a,b)
end function makeRelativePath end function makeRelativePath
!******************************************************************** !--------------------------------------------------------------------------------------------------
! counting / and \ in $PATH System variable !> @brief counting / and \ in $PATH System variable the character occuring more often is assumed
! the character occuring more often is assumed to be the path separator !! to be the path separator
!******************************************************************** !--------------------------------------------------------------------------------------------------
function getPathSep() character function getPathSep()
use prec, only: pInt use prec, only: pInt
implicit none implicit none
character :: getPathSep
character(len=2048) path character(len=2048) path
integer(pInt) :: backslash = 0_pInt, slash = 0_pInt integer(pInt) :: backslash = 0_pInt, slash = 0_pInt
integer :: i integer :: i
@ -383,4 +389,4 @@ function getPathSep()
end function 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 ignore_loc\
-warn alignments\ -warn alignments\
-warn unused\ -warn unused\
-warn errors\ -warn errors
-warn stderrors
endif endif
#-fpp: preprocessor #-fpp: preprocessor
@ -152,7 +151,7 @@ endif
# alignments: data that is not naturally aligned # alignments: data that is not naturally aligned
# unused: declared variables that are never used # unused: declared variables that are never used
# errors: warnings are changed to errors # 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 #MORE OPTIONS FOR DEBUGGING DURING COMPILING
@ -182,7 +181,8 @@ endif
################################################################################################### ###################################################################################################
ifeq "$(FASTBUILD)" "YES" ifeq "$(FASTBUILD)" "YES"
COMPILE_OPTIONS_gfortran :=-xf95-cpp-input COMPILE_OPTIONS_gfortran :=-xf95-cpp-input\
-fno-range-check
else else
COMPILE_OPTIONS_gfortran :=-xf95-cpp-input\ COMPILE_OPTIONS_gfortran :=-xf95-cpp-input\
-ffree-line-length-132\ -ffree-line-length-132\
@ -205,7 +205,8 @@ COMPILE_OPTIONS_gfortran :=-xf95-cpp-input\
-Wunsafe-loop-optimizations\ -Wunsafe-loop-optimizations\
-Wunused\ -Wunused\
-Wall\ -Wall\
-Wextra -Wextra\
-Wintrinsics-std
endif endif
#-xf95-cpp-input: preprocessor #-xf95-cpp-input: preprocessor
@ -231,20 +232,20 @@ endif
# -value: # -value:
# -parameter: find usused variables with "parameter" attribute # -parameter: find usused variables with "parameter" attribute
#-Wextra: #-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 #OPTIONS FOR GFORTRAN 4.6
#-Wsuggest-attribute=const: #-Wsuggest-attribute=const:
#-Wsuggest-attribute=noreturn: #-Wsuggest-attribute=noreturn:
#-Wsuggest-attribute=pure: #-Wsuggest-attribute=pure:
#-Wreal-q-constant: Warn about real-literal-constants with 'q' exponent-letter #-Wreal-q-constant: Warn about real-literal-constants with 'q' exponent-letter
#
#MORE OPTIONS FOR DEBUGGING DURING COMPILING #MORE OPTIONS FOR DEBUGGING DURING COMPILING
#-Wline-truncation: too many warnings because we have comments beyond character 132 #-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?):
#-Warray-temporarieswarnings: #-Wimplicit-interface:
# because we have many temporary arrays (performance issue?): #-pedantic-errors:
#-Wimplicit-interface #-fmodule-private:
#-pedantic-errors
#-fmodule-private
# #
#OPTIONS FOR DEGUBBING DURING RUNTIME #OPTIONS FOR DEGUBBING DURING RUNTIME
#-fcheck-bounds: check if an array index is too small (<1) or too large! #-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 module kdtree2_priority_queue_module
use prec use prec, only: pInt, &
pReal
! !
! maintain a priority queue (PQ) of data, pairs of 'priority/payload', ! maintain a priority queue (PQ) of data, pairs of 'priority/payload',
! implemented with a binary heap. This is the type, and the 'dis' field ! implemented with a binary heap. This is the type, and the 'dis' field
! is the priority. ! is the priority.
! !
implicit none
private
type kdtree2_result type kdtree2_result
! a pair of distances, indexes ! a pair of distances, indexes
real(pReal) :: dis = 0.0_pReal real(pReal) :: dis = 0.0_pReal
@ -74,11 +77,9 @@ module kdtree2_priority_queue_module
public :: pq_create public :: pq_create
public :: pq_delete, pq_insert public :: pq_delete, pq_insert
public :: pq_extract_max, pq_max, pq_replace_max, pq_maxpri public :: pq_extract_max, pq_max, pq_replace_max, pq_maxpri
private
contains contains
function pq_create(results_in) result(res) function pq_create(results_in) result(res)
! !
! Create a priority queue from ALREADY allocated ! Create a priority queue from ALREADY allocated
@ -93,6 +94,7 @@ contains
! allocate(x(1000),k(1000)) ! allocate(x(1000),k(1000))
! pq => pq_create(x,k) ! pq => pq_create(x,k)
! !
implicit none
type(kdtree2_result), target:: results_in(:) type(kdtree2_result), target:: results_in(:)
type(pq) :: res type(pq) :: res
! !
@ -147,6 +149,7 @@ contains
! heap canonical form. This is performance critical ! heap canonical form. This is performance critical
! and has been tweaked a little to reflect this. ! and has been tweaked a little to reflect this.
! !
implicit none
type(pq),pointer :: a type(pq),pointer :: a
integer(pInt), intent(in) :: i_in integer(pInt), intent(in) :: i_in
! !
@ -224,26 +227,30 @@ bigloop: do
! on the queue, which should be the first one, if it is ! on the queue, which should be the first one, if it is
! in heapified form. ! in heapified form.
! !
use IO, only: IO_error
implicit none
type(pq),pointer :: a type(pq),pointer :: a
type(kdtree2_result),intent(out) :: e type(kdtree2_result),intent(out) :: e
if (a%heap_size .gt. 0) then if (a%heap_size .gt. 0) then
e = a%elems(1) e = a%elems(1)
else else
write (*,*) 'PQ_MAX: ERROR, heap_size < 1' call IO_error (500_pInt, ext_msg='PQ_MAX: heap_size < 1')
stop
endif endif
return return
end subroutine pq_max end subroutine pq_max
real(pReal) function pq_maxpri(a) real(pReal) function pq_maxpri(a)
use IO, only: IO_error
implicit none
type(pq), pointer :: a type(pq), pointer :: a
if (a%heap_size .gt. 0) then if (a%heap_size .gt. 0) then
pq_maxpri = a%elems(1)%dis pq_maxpri = a%elems(1)%dis
else else
write (*,*) 'PQ_MAX_PRI: ERROR, heapsize < 1' call IO_error (500_pInt,ext_msg='PPQ_MAX_PRI: heap_size < 1')
stop
endif endif
return return
end function pq_maxpri end function pq_maxpri
@ -254,6 +261,9 @@ bigloop: do
! element, and remove it from the queue. ! element, and remove it from the queue.
! (equivalent to 'pop()' on a stack) ! (equivalent to 'pop()' on a stack)
! !
use IO, only: IO_error
implicit none
type(pq),pointer :: a type(pq),pointer :: a
type(kdtree2_result), intent(out) :: e type(kdtree2_result), intent(out) :: e
@ -271,10 +281,8 @@ bigloop: do
call heapify(a,1_pInt) call heapify(a,1_pInt)
return return
else else
write (*,*) 'PQ_EXTRACT_MAX: error, attempted to pop non-positive PQ' call IO_error (500_pInt,ext_msg='PQ_EXTRACT_MAX: attempted to pop non-positive PQ')
stop
end if end if
end subroutine pq_extract_max end subroutine pq_extract_max
@ -283,6 +291,7 @@ bigloop: do
! Insert a new element and return the new maximum priority, ! Insert a new element and return the new maximum priority,
! which may or may not be the same as the old maximum priority. ! which may or may not be the same as the old maximum priority.
! !
implicit none
type(pq),pointer :: a type(pq),pointer :: a
real(pReal), intent(in) :: dis real(pReal), intent(in) :: dis
integer(pInt), intent(in) :: idx integer(pInt), intent(in) :: idx
@ -323,6 +332,7 @@ bigloop: do
end function pq_insert end function pq_insert
subroutine pq_adjust_heap(a,i) subroutine pq_adjust_heap(a,i)
implicit none
type(pq), pointer :: a type(pq), pointer :: a
integer(pInt), intent(in) :: i integer(pInt), intent(in) :: i
! !
@ -370,6 +380,7 @@ bigloop: do
! the new maximum priority, which may be larger ! the new maximum priority, which may be larger
! or smaller than the old one. ! or smaller than the old one.
! !
implicit none
type(pq),pointer :: a type(pq),pointer :: a
real(pReal), intent(in) :: dis real(pReal), intent(in) :: dis
integer(pInt), intent(in) :: idx integer(pInt), intent(in) :: idx
@ -438,12 +449,14 @@ bigloop: do
! !
! delete item with index 'i' ! delete item with index 'i'
! !
use IO, only: IO_error
implicit none
type(pq),pointer :: a type(pq),pointer :: a
integer(pInt) :: i integer(pInt) :: i
if ((i .lt. 1) .or. (i .gt. a%heap_size)) then if ((i .lt. 1) .or. (i .gt. a%heap_size)) then
write (*,*) 'PQ_DELETE: error, attempt to remove out of bounds element.' call IO_error (500_pInt,ext_msg='PQ_DELETE: attempt to remove out of bounds element')
stop
endif endif
! swap the item to be deleted with the last element ! swap the item to be deleted with the last element
@ -461,6 +474,9 @@ end module kdtree2_priority_queue_module
module kdtree2_module module kdtree2_module
use prec use prec
use kdtree2_priority_queue_module use kdtree2_priority_queue_module
implicit none
private
! K-D tree routines in Fortran 90 by Matt Kennel. ! K-D tree routines in Fortran 90 by Matt Kennel.
! Original program was written in Sather by Steve Omohundro and ! Original program was written in Sather by Steve Omohundro and
! Matt Kennel. Only the Euclidean metric is supported. ! Matt Kennel. Only the Euclidean metric is supported.
@ -583,9 +599,6 @@ module kdtree2_module
integer(pInt), pointer :: ind(:) ! temp pointer to indexes integer(pInt), pointer :: ind(:) ! temp pointer to indexes
end type tree_search_record end type tree_search_record
private
! everything else is private.
type(tree_search_record), save, target :: sr ! A GLOBAL VARIABLE for search type(tree_search_record), save, target :: sr ! A GLOBAL VARIABLE for search
contains contains
@ -614,6 +627,9 @@ contains
! building takes longer, and extra memory is used. ! building takes longer, and extra memory is used.
! !
! .. Function Return Cut_value .. ! .. Function Return Cut_value ..
use IO, only: IO_error
implicit none
type (kdtree2), pointer :: mr type (kdtree2), pointer :: mr
integer(pInt), intent(in), optional :: myDim integer(pInt), intent(in), optional :: myDim
logical, intent(in), optional :: sort 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: 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: with usually N >> D. If N =approx= D, then a k-d tree'
write (*,*) 'KD_TREE_TRANS: is not an appropriate data structure.' write (*,*) 'KD_TREE_TRANS: is not an appropriate data structure.'
stop call IO_error (500_pInt)
end if end if
call build_tree(mr) call build_tree(mr)
@ -673,6 +689,7 @@ contains
end function kdtree2_create end function kdtree2_create
subroutine build_tree(tp) subroutine build_tree(tp)
implicit none
type (kdtree2), pointer :: tp type (kdtree2), pointer :: tp
! .. ! ..
integer(pInt) :: j integer(pInt) :: j
@ -687,6 +704,7 @@ contains
recursive function build_tree_for_range(tp,l,u,parent) result (res) recursive function build_tree_for_range(tp,l,u,parent) result (res)
! .. Function Return Cut_value .. ! .. Function Return Cut_value ..
implicit none
type (tree_node), pointer :: res type (tree_node), pointer :: res
! .. ! ..
! .. Structure Arguments .. ! .. Structure Arguments ..
@ -823,8 +841,7 @@ contains
end if end if
end function build_tree_for_range end function build_tree_for_range
integer(pInt) function select_on_coordinate_value(v,ind,c,alpha,li,ui) & integer(pInt) function select_on_coordinate_value(v,ind,c,alpha,li,ui) result(res)
result(res)
! Move elts of ind around between l and u, so that all points ! Move elts of ind around between l and u, so that all points
! <= than alpha (in c cooordinate) are first, and then ! <= than alpha (in c cooordinate) are first, and then
! all points > alpha are second. ! all points > alpha are second.
@ -842,6 +859,7 @@ contains
! The algorithm finishes when the unknown stack is empty. ! The algorithm finishes when the unknown stack is empty.
! !
! .. Scalar Arguments .. ! .. Scalar Arguments ..
implicit none
integer(pInt), intent (In) :: c, li, ui integer(pInt), intent (In) :: c, li, ui
real(pReal), intent(in) :: alpha real(pReal), intent(in) :: alpha
! .. ! ..
@ -889,6 +907,7 @@ contains
! element ! element
! is >= those below, <= those above, in the coordinate c. ! is >= those below, <= those above, in the coordinate c.
! .. Scalar Arguments .. ! .. Scalar Arguments ..
implicit none
integer(pInt), intent (In) :: c, k, li, ui integer(pInt), intent (In) :: c, k, li, ui
! .. ! ..
integer(pInt) :: i, l, m, s, t, u integer(pInt) :: i, l, m, s, t, u
@ -923,6 +942,7 @@ contains
! Return lower bound in 'smin', and upper in 'smax', ! Return lower bound in 'smin', and upper in 'smax',
! .. ! ..
! .. Structure Arguments .. ! .. Structure Arguments ..
implicit none
type (kdtree2), pointer :: tp type (kdtree2), pointer :: tp
type(interval), intent(out) :: interv type(interval), intent(out) :: interv
! .. ! ..
@ -970,6 +990,7 @@ contains
subroutine kdtree2_destroy(tp) subroutine kdtree2_destroy(tp)
! Deallocates all memory for the tree, except input data matrix ! Deallocates all memory for the tree, except input data matrix
! .. Structure Arguments .. ! .. Structure Arguments ..
implicit none
type (kdtree2), pointer :: tp type (kdtree2), pointer :: tp
! .. ! ..
call destroy_node(tp%root) call destroy_node(tp%root)
@ -988,6 +1009,7 @@ contains
contains contains
recursive subroutine destroy_node(np) recursive subroutine destroy_node(np)
! .. Structure Arguments .. ! .. Structure Arguments ..
implicit none
type (tree_node), pointer :: np type (tree_node), pointer :: np
! .. ! ..
! .. Intrinsic Functions .. ! .. Intrinsic Functions ..
@ -1013,6 +1035,7 @@ contains
! Find the 'nn' vectors in the tree nearest to 'qv' in euclidean norm ! Find the 'nn' vectors in the tree nearest to 'qv' in euclidean norm
! returning their indexes and distances in 'indexes' and 'distances' ! returning their indexes and distances in 'indexes' and 'distances'
! arrays already allocated passed to this subroutine. ! arrays already allocated passed to this subroutine.
implicit none
type (kdtree2), pointer :: tp type (kdtree2), pointer :: tp
real(pReal), target, intent (In) :: qv(:) real(pReal), target, intent (In) :: qv(:)
integer(pInt), intent (In) :: nn integer(pInt), intent (In) :: nn
@ -1056,6 +1079,7 @@ contains
! Find the 'nn' vectors in the tree nearest to point 'idxin', ! Find the 'nn' vectors in the tree nearest to point 'idxin',
! with correlation window 'correltime', returing results in ! with correlation window 'correltime', returing results in
! results(:), which must be pre-allocated upon entry. ! results(:), which must be pre-allocated upon entry.
implicit none
type (kdtree2), pointer :: tp type (kdtree2), pointer :: tp
integer(pInt), intent (In) :: idxin, correltime, nn integer(pInt), intent (In) :: idxin, correltime, nn
type(kdtree2_result), target :: results(:) type(kdtree2_result), target :: results(:)
@ -1106,6 +1130,7 @@ contains
! the smallest ball inside norm r^2 ! the smallest ball inside norm r^2
! !
! Results are NOT sorted unless tree was created with sort option. ! Results are NOT sorted unless tree was created with sort option.
implicit none
type (kdtree2), pointer :: tp type (kdtree2), pointer :: tp
real(pReal), target, intent (In) :: qv(:) real(pReal), target, intent (In) :: qv(:)
real(pReal), intent(in) :: r2 real(pReal), intent(in) :: r2
@ -1156,14 +1181,14 @@ contains
return return
end subroutine kdtree2_r_nearest end subroutine kdtree2_r_nearest
subroutine kdtree2_r_nearest_around_point(tp,idxin,correltime,r2,& subroutine kdtree2_r_nearest_around_point(tp,idxin,correltime,r2,nfound,nalloc,results)
nfound,nalloc,results)
! !
! Like kdtree2_r_nearest, but around a point 'idxin' already existing ! Like kdtree2_r_nearest, but around a point 'idxin' already existing
! in the data set. ! in the data set.
! !
! Results are NOT sorted unless tree was created with sort option. ! Results are NOT sorted unless tree was created with sort option.
! !
implicit none
type (kdtree2), pointer :: tp type (kdtree2), pointer :: tp
integer(pInt), intent (In) :: idxin, correltime, nalloc integer(pInt), intent (In) :: idxin, correltime, nalloc
real(pReal), intent(in) :: r2 real(pReal), intent(in) :: r2
@ -1225,6 +1250,7 @@ contains
function kdtree2_r_count(tp,qv,r2) result(nfound) function kdtree2_r_count(tp,qv,r2) result(nfound)
! Count the number of neighbors within square distance 'r2'. ! Count the number of neighbors within square distance 'r2'.
implicit none
type (kdtree2), pointer :: tp type (kdtree2), pointer :: tp
real(pReal), target, intent (In) :: qv(:) real(pReal), target, intent (In) :: qv(:)
real(pReal), intent(in) :: r2 real(pReal), intent(in) :: r2
@ -1267,11 +1293,11 @@ contains
return return
end function kdtree2_r_count end function kdtree2_r_count
function kdtree2_r_count_around_point(tp,idxin,correltime,r2) & function kdtree2_r_count_around_point(tp,idxin,correltime,r2) result(nfound)
result(nfound)
! Count the number of neighbors within square distance 'r2' around ! Count the number of neighbors within square distance 'r2' around
! point 'idxin' with decorrelation time 'correltime'. ! point 'idxin' with decorrelation time 'correltime'.
! !
implicit none
type (kdtree2), pointer :: tp type (kdtree2), pointer :: tp
integer(pInt), intent (In) :: correltime, idxin integer(pInt), intent (In) :: correltime, idxin
real(pReal), intent(in) :: r2 real(pReal), intent(in) :: r2
@ -1322,12 +1348,13 @@ contains
! !
! make sure we have enough storage for n ! make sure we have enough storage for n
! !
use IO, only: IO_error
implicit none
integer(pInt), intent(in) :: n integer(pInt), intent(in) :: n
if (int(size(sr%results,1),pInt) .lt. n) then if (int(size(sr%results,1),pInt) .lt. n) then
write (*,*) 'KD_TREE_TRANS: you did not provide enough storage for results(1:n)' call IO_error (500_pInt,ext_msg='KD_TREE_TRANS: not enough storage for results(1:n)')
stop
return
endif endif
return return
@ -1337,12 +1364,10 @@ contains
! distance between iv[1:n] and qv[1:n] ! distance between iv[1:n] and qv[1:n]
! .. Function Return Value .. ! .. Function Return Value ..
! re-implemented to improve vectorization. ! re-implemented to improve vectorization.
implicit none
real(pReal) :: res real(pReal) :: res
! ..
! ..
! .. Scalar Arguments .. ! .. Scalar Arguments ..
integer(pInt) :: d integer(pInt) :: d
! ..
! .. Array Arguments .. ! .. Array Arguments ..
real(pReal) :: iv(:),qv(:) real(pReal) :: iv(:),qv(:)
! .. ! ..
@ -1358,6 +1383,7 @@ contains
! This version uses a logically complete secondary search of ! This version uses a logically complete secondary search of
! "box in bounds", whether the sear ! "box in bounds", whether the sear
! !
implicit none
type (Tree_node), pointer :: node type (Tree_node), pointer :: node
! .. ! ..
type(tree_node),pointer :: ncloser, nfarther type(tree_node),pointer :: ncloser, nfarther
@ -1428,6 +1454,8 @@ contains
real(pReal) function dis2_from_bnd(x,amin,amax) result (res) real(pReal) function dis2_from_bnd(x,amin,amax) result (res)
implicit none
real(pReal), intent(in) :: x, amin,amax real(pReal), intent(in) :: x, amin,amax
if (x > amax) then if (x > amax) then
@ -1452,6 +1480,7 @@ contains
! for all coordinates outside the box. Coordinates inside the box ! for all coordinates outside the box. Coordinates inside the box
! contribute nothing to the distance. ! contribute nothing to the distance.
! !
implicit none
type (tree_node), pointer :: node type (tree_node), pointer :: node
type (tree_search_record), pointer :: sr type (tree_search_record), pointer :: sr
@ -1482,6 +1511,7 @@ contains
! Look for actual near neighbors in 'node', and update ! Look for actual near neighbors in 'node', and update
! the search results on the sr data structure. ! the search results on the sr data structure.
! !
implicit none
type (tree_node), pointer :: node type (tree_node), pointer :: node
! !
real(pReal), pointer :: qv(:) real(pReal), pointer :: qv(:)
@ -1588,6 +1618,7 @@ contains
! the search results on the sr data structure, i.e. ! the search results on the sr data structure, i.e.
! save all within a fixed ball. ! save all within a fixed ball.
! !
implicit none
type (tree_node), pointer :: node type (tree_node), pointer :: node
! !
real(pReal), pointer :: qv(:) real(pReal), pointer :: qv(:)
@ -1678,6 +1709,7 @@ contains
! only use this subroutine for testing, as it is SLOW! The ! 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 ! whole point of a k-d tree is to avoid doing what this subroutine
! does. ! does.
implicit none
type (kdtree2), pointer :: tp type (kdtree2), pointer :: tp
real(pReal), intent (In) :: qv(:) real(pReal), intent (In) :: qv(:)
integer(pInt), intent (In) :: nn integer(pInt), intent (In) :: nn
@ -1718,6 +1750,7 @@ contains
! only use this subroutine for testing, as it is SLOW! The ! 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 ! whole point of a k-d tree is to avoid doing what this subroutine
! does. ! does.
implicit none
type (kdtree2), pointer :: tp type (kdtree2), pointer :: tp
real(pReal), intent (In) :: qv(:) real(pReal), intent (In) :: qv(:)
real(pReal), intent (In) :: r2 real(pReal), intent (In) :: r2
@ -1756,6 +1789,7 @@ contains
subroutine kdtree2_sort_results(nfound,results) subroutine kdtree2_sort_results(nfound,results)
! Use after search to sort results(1:nfound) in order of increasing ! Use after search to sort results(1:nfound) in order of increasing
! distance. ! distance.
implicit none
integer(pInt), intent(in) :: nfound integer(pInt), intent(in) :: nfound
type(kdtree2_result), target :: results(:) 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. ! If ind(k) = k upon input, then it will give a sort index upon output.
! !
implicit none
integer(pInt),intent(in) :: n integer(pInt),intent(in) :: n
real(pReal), intent(inout) :: a(:) real(pReal), intent(inout) :: a(:)
integer(pInt), intent(inout) :: ind(:) integer(pInt), intent(inout) :: ind(:)
@ -1833,6 +1868,7 @@ contains
! Sort a(1:n) in ascending order ! Sort a(1:n) in ascending order
! !
! !
implicit none
integer(pInt),intent(in) :: n integer(pInt),intent(in) :: n
type(kdtree2_result),intent(inout) :: a(:) type(kdtree2_result),intent(inout) :: a(:)
@ -1885,6 +1921,3 @@ contains
end subroutine heapsort_struct end subroutine heapsort_struct
end module kdtree2_module end module kdtree2_module
!#############################################################################################################################
! END KDTREE2
!#############################################################################################################################

17
code/prec.f90
View File

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