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

no need to use pInt here

This commit is contained in:
Martin Diehl 2019-03-06 15:47:48 +01:00
parent 977f61452b
commit c9e7311b42
1 changed files with 334 additions and 333 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

91
src/DAMASK_interface.f90
View File

@ -10,13 +10,13 @@
!> and working directory. !> and working directory.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
module DAMASK_interface module DAMASK_interface
use prec, only: &
pInt
implicit none implicit none
private private
logical, public, protected :: SIGUSR1,SIGUSR2 logical, public, protected :: &
integer(pInt), public, protected :: & SIGUSR1, & !< user-defined signal 1
interface_restartInc = 0_pInt !< Increment at which calculation starts SIGUSR2 !< user-defined signal 2
integer, public, protected :: &
interface_restartInc = 0 !< Increment at which calculation starts
character(len=1024), public, protected :: & character(len=1024), public, protected :: &
geometryFile = '', & !< parameter given for geometry file geometryFile = '', & !< parameter given for geometry file
loadCaseFile = '' !< parameter given for load case file loadCaseFile = '' !< parameter given for load case file
@ -42,8 +42,15 @@ contains
subroutine DAMASK_interface_init() subroutine DAMASK_interface_init()
use, intrinsic :: & use, intrinsic :: &
iso_fortran_env iso_fortran_env
use :: & use, intrinsic :: &
iso_c_binding iso_c_binding
use PETScSys
use system_routines, only: &
signalusr1_C, &
signalusr2_C, &
getHostName, &
getCWD
#include <petsc/finclude/petscsys.h> #include <petsc/finclude/petscsys.h>
#if defined(__GFORTRAN__) && __GNUC__ < 5 #if defined(__GFORTRAN__) && __GNUC__ < 5
=================================================================================================== ===================================================================================================
@ -81,13 +88,6 @@ subroutine DAMASK_interface_init()
=================================================================================================== ===================================================================================================
#endif #endif
use PETScSys
use system_routines, only: &
signalusr1_C, &
signalusr2_C, &
getHostName, &
getCWD
implicit none implicit none
character(len=1024) :: & character(len=1024) :: &
commandLine, & !< command line call as string commandLine, & !< command line call as string
@ -105,7 +105,7 @@ subroutine DAMASK_interface_init()
integer, allocatable, dimension(:) :: & integer, allocatable, dimension(:) :: &
chunkPos chunkPos
integer, dimension(8) :: & integer, dimension(8) :: &
dateAndTime ! type default integer dateAndTime
PetscErrorCode :: ierr PetscErrorCode :: ierr
external :: & external :: &
quit quit
@ -120,7 +120,7 @@ subroutine DAMASK_interface_init()
call MPI_Init_Thread(MPI_THREAD_FUNNELED,threadLevel,ierr);CHKERRQ(ierr) call MPI_Init_Thread(MPI_THREAD_FUNNELED,threadLevel,ierr);CHKERRQ(ierr)
if (threadLevel<MPI_THREAD_FUNNELED) then if (threadLevel<MPI_THREAD_FUNNELED) then
write(6,'(a)') ' MPI library does not support OpenMP' write(6,'(a)') ' MPI library does not support OpenMP'
call quit(1_pInt) call quit(1)
endif endif
#endif #endif
call PETScInitialize(PETSC_NULL_CHARACTER,ierr) ! according to PETSc manual, that should be the first line in the code call PETScInitialize(PETSC_NULL_CHARACTER,ierr) ! according to PETSc manual, that should be the first line in the code
@ -130,11 +130,11 @@ subroutine DAMASK_interface_init()
mainProcess: if (worldrank == 0) then mainProcess: if (worldrank == 0) then
if (output_unit /= 6) then if (output_unit /= 6) then
write(output_unit,'(a)') ' STDOUT != 6' write(output_unit,'(a)') ' STDOUT != 6'
call quit(1_pInt) call quit(1)
endif endif
if (error_unit /= 0) then if (error_unit /= 0) then
write(output_unit,'(a)') ' STDERR != 0' write(output_unit,'(a)') ' STDERR != 0'
call quit(1_pInt) call quit(1)
endif endif
else mainProcess else mainProcess
close(6) ! disable output for non-master processes (open 6 to rank specific file for debug) close(6) ! disable output for non-master processes (open 6 to rank specific file for debug)
@ -167,7 +167,7 @@ subroutine DAMASK_interface_init()
call get_command(commandLine) call get_command(commandLine)
chunkPos = IIO_stringPos(commandLine) chunkPos = IIO_stringPos(commandLine)
do i = 2_pInt, chunkPos(1) do i = 2, chunkPos(1)
select case(IIO_stringValue(commandLine,chunkPos,i)) ! extract key select case(IIO_stringValue(commandLine,chunkPos,i)) ! extract key
case ('-h','--help') case ('-h','--help')
write(6,'(a)') ' #######################################################################' write(6,'(a)') ' #######################################################################'
@ -205,23 +205,23 @@ subroutine DAMASK_interface_init()
write(6,'(a)') ' Help:' write(6,'(a)') ' Help:'
write(6,'(/,a)')' --help' write(6,'(/,a)')' --help'
write(6,'(a,/)')' Prints this message and exits' write(6,'(a,/)')' Prints this message and exits'
call quit(0_pInt) ! normal Termination call quit(0) ! normal Termination
case ('-l', '--load', '--loadcase') case ('-l', '--load', '--loadcase')
if ( i < chunkPos(1)) loadcaseArg = trim(IIO_stringValue(commandLine,chunkPos,i+1_pInt)) if ( i < chunkPos(1)) loadcaseArg = trim(IIO_stringValue(commandLine,chunkPos,i+1))
case ('-g', '--geom', '--geometry') case ('-g', '--geom', '--geometry')
if (i < chunkPos(1)) geometryArg = trim(IIO_stringValue(commandLine,chunkPos,i+1_pInt)) if (i < chunkPos(1)) geometryArg = trim(IIO_stringValue(commandLine,chunkPos,i+1))
case ('-w', '-d', '--wd', '--directory', '--workingdir', '--workingdirectory') case ('-w', '-d', '--wd', '--directory', '--workingdir', '--workingdirectory')
if (i < chunkPos(1)) workingDirArg = trim(IIO_stringValue(commandLine,chunkPos,i+1_pInt)) if (i < chunkPos(1)) workingDirArg = trim(IIO_stringValue(commandLine,chunkPos,i+1))
case ('-r', '--rs', '--restart') case ('-r', '--rs', '--restart')
if (i < chunkPos(1)) then if (i < chunkPos(1)) then
interface_restartInc = IIO_IntValue(commandLine,chunkPos,i+1_pInt) interface_restartInc = IIO_IntValue(commandLine,chunkPos,i+1)
endif endif
end select end select
enddo enddo
if (len_trim(loadcaseArg) == 0 .or. len_trim(geometryArg) == 0) then if (len_trim(loadcaseArg) == 0 .or. len_trim(geometryArg) == 0) then
write(6,'(a)') ' Please specify geometry AND load case (-h for help)' write(6,'(a)') ' Please specify geometry AND load case (-h for help)'
call quit(1_pInt) call quit(1)
endif endif
if (len_trim(workingDirArg) > 0) call setWorkingDirectory(trim(workingDirArg)) if (len_trim(workingDirArg) > 0) call setWorkingDirectory(trim(workingDirArg))
@ -243,7 +243,7 @@ subroutine DAMASK_interface_init()
write(6,'(a,a)') ' Geometry file: ', trim(geometryFile) write(6,'(a,a)') ' Geometry file: ', trim(geometryFile)
write(6,'(a,a)') ' Loadcase file: ', trim(loadCaseFile) write(6,'(a,a)') ' Loadcase file: ', trim(loadCaseFile)
write(6,'(a,a)') ' Solver job name: ', trim(getSolverJobName()) write(6,'(a,a)') ' Solver job name: ', trim(getSolverJobName())
if (interface_restartInc > 0_pInt) & if (interface_restartInc > 0) &
write(6,'(a,i6.6)') ' Restart from increment: ', interface_restartInc write(6,'(a,i6.6)') ' Restart from increment: ', interface_restartInc
call signalusr1_c(c_funloc(setSIGUSR1)) call signalusr1_c(c_funloc(setSIGUSR1))
@ -280,8 +280,8 @@ subroutine setWorkingDirectory(workingDirectoryArg)
workingDirectory = trim(rectifyPath(workingDirectory)) workingDirectory = trim(rectifyPath(workingDirectory))
error = setCWD(trim(workingDirectory)) error = setCWD(trim(workingDirectory))
if(error) then if(error) then
write(6,'(a20,a,a16)') ' working directory "',trim(workingDirectory),'" does not exist' write(6,'(a20,a,a16)') ' Working directory "',trim(workingDirectory),'" does not exist'
call quit(1_pInt) call quit(1)
endif endif
end subroutine setWorkingDirectory end subroutine setWorkingDirectory
@ -331,7 +331,7 @@ character(len=1024) function getGeometryFile(geometryParameter)
inquire(file=trim(getGeometryFile), exist=file_exists) inquire(file=trim(getGeometryFile), exist=file_exists)
if (.not. file_exists) then if (.not. file_exists) then
write(6,'(a)') ' Geometry file does not exists ('//trim(getGeometryFile)//')' write(6,'(a)') ' Geometry file does not exists ('//trim(getGeometryFile)//')'
call quit(1_pInt) call quit(1)
endif endif
end function getGeometryFile end function getGeometryFile
@ -355,8 +355,8 @@ character(len=1024) function getLoadCaseFile(loadCaseParameter)
inquire(file=trim(getLoadCaseFile), exist=file_exists) inquire(file=trim(getLoadCaseFile), exist=file_exists)
if (.not. file_exists) then if (.not. file_exists) then
write(6,'(a)') ' Geometry file does not exists ('//trim(getLoadCaseFile)//')' write(6,'(a)') ' Load case file does not exists ('//trim(getLoadCaseFile)//')'
call quit(1_pInt) call quit(1)
endif endif
end function getLoadCaseFile end function getLoadCaseFile
@ -371,7 +371,7 @@ function rectifyPath(path)
implicit none implicit none
character(len=*) :: path character(len=*) :: path
character(len=1024) :: rectifyPath character(len=1024) :: rectifyPath
integer :: i,j,k,l ! no pInt integer :: i,j,k,l
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! remove /./ from path ! remove /./ from path
@ -416,7 +416,7 @@ character(len=1024) function makeRelativePath(a,b)
implicit none implicit none
character (len=*), intent(in) :: a,b character (len=*), intent(in) :: a,b
character (len=1024) :: a_cleaned,b_cleaned character (len=1024) :: a_cleaned,b_cleaned
integer :: i,posLastCommonSlash,remainingSlashes !no pInt integer :: i,posLastCommonSlash,remainingSlashes
posLastCommonSlash = 0 posLastCommonSlash = 0
remainingSlashes = 0 remainingSlashes = 0
@ -435,6 +435,7 @@ character(len=1024) function makeRelativePath(a,b)
end function makeRelativePath end function makeRelativePath
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief sets global variable SIGUSR1 to .true. if program receives SIGUSR1 !> @brief sets global variable SIGUSR1 to .true. if program receives SIGUSR1
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
@ -471,8 +472,8 @@ end subroutine setSIGUSR2
pure function IIO_stringValue(string,chunkPos,myChunk) pure function IIO_stringValue(string,chunkPos,myChunk)
implicit none implicit none
integer(pInt), dimension(:), intent(in) :: chunkPos !< positions of start and end of each tag/chunk in given string integer, dimension(:), intent(in) :: chunkPos !< positions of start and end of each tag/chunk in given string
integer(pInt), intent(in) :: myChunk !< position number of desired chunk integer, intent(in) :: myChunk !< position number of desired chunk
character(len=chunkPos(myChunk*2+1)-chunkPos(myChunk*2)+1) :: IIO_stringValue character(len=chunkPos(myChunk*2+1)-chunkPos(myChunk*2)+1) :: IIO_stringValue
character(len=*), intent(in) :: string !< raw input with known start and end of each chunk character(len=*), intent(in) :: string !< raw input with known start and end of each chunk
@ -484,21 +485,21 @@ end function IIO_stringValue
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief taken from IO, check IO_intValue for documentation !> @brief taken from IO, check IO_intValue for documentation
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
integer(pInt) pure function IIO_intValue(string,chunkPos,myChunk) integer pure function IIO_intValue(string,chunkPos,myChunk)
implicit none implicit none
character(len=*), intent(in) :: string !< raw input with known start and end of each chunk character(len=*), intent(in) :: string !< raw input with known start and end of each chunk
integer(pInt), intent(in) :: myChunk !< position number of desired sub string integer, intent(in) :: myChunk !< position number of desired sub string
integer(pInt), dimension(:), intent(in) :: chunkPos !< positions of start and end of each tag/chunk in given string integer, dimension(:), intent(in) :: chunkPos !< positions of start and end of each tag/chunk in given string
valuePresent: if (myChunk > chunkPos(1) .or. myChunk < 1_pInt) then valuePresent: if (myChunk > chunkPos(1) .or. myChunk < 1) then
IIO_intValue = 0_pInt IIO_intValue = 0
else valuePresent else valuePresent
read(UNIT=string(chunkPos(myChunk*2):chunkPos(myChunk*2+1)),ERR=100,FMT=*) IIO_intValue read(UNIT=string(chunkPos(myChunk*2):chunkPos(myChunk*2+1)),ERR=100,FMT=*) IIO_intValue
endif valuePresent endif valuePresent
return return
100 IIO_intValue = huge(1_pInt) 100 IIO_intValue = huge(1)
end function IIO_intValue end function IIO_intValue
@ -509,20 +510,20 @@ end function IIO_intValue
pure function IIO_stringPos(string) pure function IIO_stringPos(string)
implicit none implicit none
integer(pInt), dimension(:), allocatable :: IIO_stringPos integer, dimension(:), allocatable :: IIO_stringPos
character(len=*), intent(in) :: string !< string in which chunks are searched for character(len=*), intent(in) :: string !< string in which chunks are searched for
character(len=*), parameter :: SEP=achar(44)//achar(32)//achar(9)//achar(10)//achar(13) ! comma and whitespaces character(len=*), parameter :: SEP=achar(44)//achar(32)//achar(9)//achar(10)//achar(13) ! comma and whitespaces
integer :: left, right ! no pInt (verify and scan return default integer) integer :: left, right
allocate(IIO_stringPos(1), source=0_pInt) allocate(IIO_stringPos(1), source=0)
right = 0 right = 0
do while (verify(string(right+1:),SEP)>0) do while (verify(string(right+1:),SEP)>0)
left = right + verify(string(right+1:),SEP) left = right + verify(string(right+1:),SEP)
right = left + scan(string(left:),SEP) - 2 right = left + scan(string(left:),SEP) - 2
IIO_stringPos = [IIO_stringPos,int(left, pInt), int(right, pInt)] IIO_stringPos = [IIO_stringPos,left, right]
IIO_stringPos(1) = IIO_stringPos(1)+1_pInt IIO_stringPos(1) = IIO_stringPos(1)+1
enddo enddo
end function IIO_stringPos end function IIO_stringPos