DAMASK_interface.f90

Go to the documentation of this file.

# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/DAMASK_interface.f90"
# 1 "<built-in>"
# 1 "<command-line>"
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/DAMASK_interface.f90"
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
 
 
 
 
 
 
module damask_interface
  use, intrinsic :: iso_fortran_env
 
  use petscsys
 
  use prec
  use system_routines
  
  implicit none
  private
  logical,                       public, protected :: &
    sigterm, &                                                                                      !< termination signal 
    sigusr1, &                                                                                      !< 1. user-defined signal
    sigusr2
  integer,                       public, protected :: &
    interface_restartinc = 0
  character(len=:), allocatable, public, protected :: &
    geometryfile, &                                                                                 !< parameter given for geometry file
    loadcasefile
 
  public :: &
    getsolverjobname, &
    damask_interface_init, &
    setsigterm, &
    setsigusr1, &
    setsigusr2
 
contains
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine damask_interface_init
 
# 1 "/opt/petsc-3.10.3/include/petsc/finclude/petscsys.h" 1
!
!
!  Part of the base include file for Fortran use of 1.
!  Note: This file should contain only define statements and
!  not the declaration of variables.
 
! No spaces for #defines as some compilers (PGI) also adds
! those additional spaces during preprocessing - bad for fixed format
!
 
 
 
# 1 "/opt/petsc-3.10.3/Intel-18.4-IntelMPI-2018/include/petscconf.h" 1
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
# 13 "/opt/petsc-3.10.3/include/petsc/finclude/petscsys.h" 2
 
 
 
 
# 1 "/opt/petsc-3.10.3/include/petscversion.h" 1
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
# 17 "/opt/petsc-3.10.3/include/petsc/finclude/petscsys.h" 2
 
# 1 "/opt/petsc-3.10.3/include/petsc/finclude/petscviewer.h" 1
!
!  Include file for Fortran use of the PetscViewer package in 1
!
 
 
 
 
 
 
 
 
 
 
 
 
 
# 31 "/opt/petsc-3.10.3/include/petsc/finclude/petscviewer.h"
 
# 18 "/opt/petsc-3.10.3/include/petsc/finclude/petscsys.h" 2
 
# 1 "/opt/petsc-3.10.3/include/petsc/finclude/petscerror.h" 1
 
!
!  Include file for Fortran error codes
!    These are also in include/petscerror.h
!
 
 
 
# 24 "/opt/petsc-3.10.3/include/petsc/finclude/petscerror.h"
 
# 38 "/opt/petsc-3.10.3/include/petsc/finclude/petscerror.h"
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
# 19 "/opt/petsc-3.10.3/include/petsc/finclude/petscsys.h" 2
 
# 1 "/opt/petsc-3.10.3/include/petsc/finclude/petsclog.h" 1
!
!  No includes needed for logging
# 20 "/opt/petsc-3.10.3/include/petsc/finclude/petscsys.h" 2
 
# 1 "/opt/petsc-3.10.3/include/petsc/finclude/petscbag.h" 1
!
!
!  Include file for Fortran use of the Bag package in 1
!
 
 
 
 
 
!
!  End of Fortran include file for the IS package in 1
 
# 21 "/opt/petsc-3.10.3/include/petsc/finclude/petscsys.h" 2
 
!
! The real*8,complex*16 notatiton is used so that the
! 1 double/complex variables are not affected by
! compiler options like -r4,-r8, sometimes invoked
! by the user. NAG compiler does not like integer*4,real*8
 
# 41 "/opt/petsc-3.10.3/include/petsc/finclude/petscsys.h"
 
 
 
 
 
 
 
 
 
# 63 "/opt/petsc-3.10.3/include/petsc/finclude/petscsys.h"
 
 
 
 
 
 
!
 
 
 
 
 
!
# 85 "/opt/petsc-3.10.3/include/petsc/finclude/petscsys.h"
!
 
 
 
 
 
 
!
 
 
 
 
!
 
!
 
 
!
# 128 "/opt/petsc-3.10.3/include/petsc/finclude/petscsys.h"
 
# 150 "/opt/petsc-3.10.3/include/petsc/finclude/petscsys.h"
!
!     Macro for templating between real and complex
!
# 174 "/opt/petsc-3.10.3/include/petsc/finclude/petscsys.h"
 
 
 
 
 
 
 
 
 
!
!    Allows the matrix Fortran Kernels to work with single precision
!    matrix data structures
!
 
!
!     PetscLogDouble variables are used to contain double precision numbers
!     that are not used in the numerical computations, but rather in logging,
!     timing etc.
!
 
 
!
!     Macros for error checking
!
 
 
 
 
 
 
 
 
# 215 "/opt/petsc-3.10.3/include/petsc/finclude/petscsys.h"
 
 
 
 
 
 
 
 
 
 
 
 
# 53 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/DAMASK_interface.f90" 2
# 64 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/DAMASK_interface.f90"
 
# 76 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/DAMASK_interface.f90"
 
# 88 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/DAMASK_interface.f90"
 
  character(len=pPathLen*3+pStringLen) :: &
    commandline
  character(len=pPathLen) :: &
    arg, &                                                                                          !< individual argument
    loadcasearg   = '', &                                                                           !< -l argument given to the executable
    geometryarg   = '', &                                                                           
    workingdirarg = ''                                                                              
  character(len=pStringLen) :: &
    username
  integer :: &
    stat, &
    i, &
 
 
 
    worldrank = 0, &
    worldsize = 0, &
    typesize
  integer, dimension(8) :: &
    dateandtime
  integer        :: mpi_err
  integer(kind=selected_int_kind(5)) :: petsc_err
  external :: &
    quit
 
  open(6, encoding='UTF-8')                                                                         ! for special characters in output
 
!--------------------------------------------------------------------------------------------------
! 1 Init
# 128 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/DAMASK_interface.f90"
  call petscinitializenoarguments(petsc_err)                                                        ! according to 1 manual, that should be the first line in the code
  if (petsc_err .ne. 0) then;call petscerrorf(petsc_err);return;endif                                                                                ! this is a macro definition, it is case sensitive
 
  call mpi_comm_rank(petsc_comm_world,worldrank,mpi_err)
  if (mpi_err /= 0) call quit(1)
  call mpi_comm_size(petsc_comm_world,worldsize,mpi_err)
  if (mpi_err /= 0) call quit(1)
 
  mainprocess: if (worldrank == 0) then
    if (output_unit /= 6) then
      write(output_unit,'(/,a)') ' ERROR: STDOUT != 6'
      call quit(1)
    endif
    if (error_unit /= 0) then
      write(output_unit,'(/,a)') ' ERROR: STDERR != 0'
      call quit(1)
    endif
  else mainprocess
    close(6)                                                                                        ! disable output for non-master processes (open 6 to rank specific file for debug)
    open(6,file='/dev/null',status='replace')                                                       ! close(6) alone will leave some temp files in cwd
  endif mainprocess
 
  write(6,'(/,a)') ' <<<+-  DAMASK_interface init  -+>>>'
 
 ! http://patorjk.com/software/taag/#p=display&f=Lean&t=DAMASK
  write(6,*) achar(27)//'[94m'
  write(6,*) '     _/_/_/      _/_/    _/      _/    _/_/      _/_/_/  _/    _/'
  write(6,*) '    _/    _/  _/    _/  _/_/  _/_/  _/    _/  _/        _/  _/'
  write(6,*) '   _/    _/  _/_/_/_/  _/  _/  _/  _/_/_/_/    _/_/    _/_/'
  write(6,*) '  _/    _/  _/    _/  _/      _/  _/    _/        _/  _/  _/'
  write(6,*) ' _/_/_/    _/    _/  _/      _/  _/    _/  _/_/_/    _/    _/'
  write(6,*) achar(27)//'[0m'
 
  write(6,'(/,a)') ' Roters et al., Computational Materials Science 158:420–478, 2019'
  write(6,'(a)')   ' https://doi.org/10.1016/j.commatsci.2018.04.030'
 
  write(6,'(/,a)') ' Version: '//damaskversion
 
  ! https://github.com/jeffhammond/HPCInfo/blob/master/docs/Preprocessor-Macros.md
 
  write(6,'(/,a)') ' Compiled with: '//compiler_version()
  write(6,'(a)')   ' Compiler options: '//compiler_options()
 
 
 
 
 
 
 
 
  write(6,'(/,a)') ' Compiled on: '//"Apr  1 2020"//' at '//"18:44:57"
 
  call date_and_time(values = dateandtime)
  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)
 
  call mpi_type_size(mpi_integer,typesize,mpi_err)
  if (mpi_err /= 0) call quit(1)
  if (typesize*8 /= bit_size(0)) then
    write(6,'(a)') ' Mismatch between MPI and DAMASK integer' 
    call quit(1)
  endif
 
  call mpi_type_size(mpi_double,typesize,mpi_err)
  if (mpi_err /= 0) call quit(1)
  if (typesize*8 /= storage_size(0.0_preal)) then
    write(6,'(a)') ' Mismatch between MPI and DAMASK real' 
    call quit(1)
  endif
 
  do i = 1, command_argument_count()
    call get_command_argument(i,arg)
    select case(trim(arg))                                                                          ! extract key
      case ('-h','--help')
        write(6,'(a)')  ' #######################################################################'
        write(6,'(a)')  ' DAMASK Command Line Interface:'
        write(6,'(a)')  ' For PETSc-based solvers for the Düsseldorf Advanced Material Simulation Kit'
        write(6,'(a,/)')' #######################################################################'
        write(6,'(a,/)')' Valid command line switches:'
        write(6,'(a)')  '    --geom         (-g, --geometry)'
        write(6,'(a)')  '    --load         (-l, --loadcase)'
        write(6,'(a)')  '    --workingdir   (-w, --wd, --workingdirectory, -d, --directory)'
        write(6,'(a)')  '    --restart      (-r, --rs)'
        write(6,'(a)')  '    --help         (-h)'
        write(6,'(/,a)')' -----------------------------------------------------------------------'
        write(6,'(a)')  ' Mandatory arguments:'
        write(6,'(/,a)')'   --geom PathToGeomFile/NameOfGeom'
        write(6,'(a)')  '        Specifies the location of the geometry definition file.'
        write(6,'(/,a)')'   --load PathToLoadFile/NameOfLoadFile'
        write(6,'(a)')  '        Specifies the location of the load case definition file.'
        write(6,'(/,a)')' -----------------------------------------------------------------------'
        write(6,'(a)')  ' Optional arguments:'
        write(6,'(/,a)')'   --workingdirectory PathToWorkingDirectory'
        write(6,'(a)')  '        Specifies the working directory and overwrites the default ./'
        write(6,'(a)')  '        Make sure the file "material.config" exists in the working'
        write(6,'(a)')  '            directory.'
        write(6,'(a)')  '        For further configuration place "numerics.config"'
        write(6,'(a)')'            and "debug.config" in that directory.'
        write(6,'(/,a)')'   --restart XX'
        write(6,'(a)')  '        Reads in increment XX and continues with calculating'
        write(6,'(a)')  '            increment XX+1 based on this.'
        write(6,'(a)')  '        Appends to existing results file'
        write(6,'(a)')  '            "NameOfGeom_NameOfLoadFile".'
        write(6,'(a)')  '        Works only if the restart information for increment XX'
        write(6,'(a)')  '            is available in the working directory.'
        write(6,'(/,a)')' -----------------------------------------------------------------------'
        write(6,'(a)')  ' Help:'
        write(6,'(/,a)')'   --help'
        write(6,'(a,/)')'        Prints this message and exits'
        call quit(0)                                                                                ! normal Termination
      case ('-l', '--load', '--loadcase')
        call get_command_argument(i+1,loadcasearg)
      case ('-g', '--geom', '--geometry')
        call get_command_argument(i+1,geometryarg)
      case ('-w', '-d', '--wd', '--directory', '--workingdir', '--workingdirectory')
        call get_command_argument(i+1,workingdirarg)
      case ('-r', '--rs', '--restart')
        call get_command_argument(i+1,arg)
        read(arg,*,iostat=stat) interface_restartinc
        if (interface_restartinc < 0 .or. stat /=0) then
          write(6,'(/,a)') ' ERROR: Could not parse restart increment: '//trim(arg)
          call quit(1)
        endif
    end select
  enddo
 
  if (len_trim(loadcasearg) == 0 .or. len_trim(geometryarg) == 0) then
    write(6,'(/,a)') ' ERROR: Please specify geometry AND load case (-h for help)'
    call quit(1)
  endif
 
  if (len_trim(workingdirarg) > 0) call setworkingdirectory(trim(workingdirarg))
  geometryfile = getgeometryfile(geometryarg)
  loadcasefile = getloadcasefile(loadcasearg)
 
  call get_command(commandline)
  call get_environment_variable('USER',username)
  ! ToDo: https://stackoverflow.com/questions/8953424/how-to-get-the-username-in-c-c-in-linux
  write(6,'(/,a,i4.1)') ' MPI processes: ',worldsize
  write(6,'(a,a)')      ' Host name: ', trim(gethostname())
  write(6,'(a,a)')      ' User name: ', trim(username)
 
  write(6,'(/a,a)')     ' Command line call:      ', trim(commandline)
  if (len_trim(workingdirarg) > 0) &
    write(6,'(a,a)')    ' Working dir argument:   ', trim(workingdirarg)
  write(6,'(a,a)')      ' Geometry argument:      ', trim(geometryarg)
  write(6,'(a,a)')      ' Load case argument:     ', trim(loadcasearg)
  write(6,'(a,a)')      ' Working directory:      ', getcwd()
  write(6,'(a,a)')      ' Geometry file:          ', geometryfile
  write(6,'(a,a)')      ' Loadcase file:          ', loadcasefile
  write(6,'(a,a)')      ' Solver job name:        ', getsolverjobname()
  if (interface_restartinc > 0) &
    write(6,'(a,i6.6)') ' Restart from increment: ', interface_restartinc
 
  !call signalterm_c(c_funloc(catchSIGTERM))
  call signalusr1_c(c_funloc(catchsigusr1))
  call signalusr2_c(c_funloc(catchsigusr2))
  call setsigterm(.false.)
  call setsigusr1(.false.)
  call setsigusr2(.false.)
 
 
end subroutine damask_interface_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine setworkingdirectory(workingDirectoryArg)
 
  character(len=*),  intent(in) :: workingDirectoryArg
  character(len=pPathLen)       :: workingDirectory
  logical                       :: error
  external                      :: quit
 
  absolutepath: if (workingdirectoryarg(1:1) == '/') then
    workingdirectory = workingdirectoryarg
  else absolutepath
    workingdirectory = getcwd()
    workingdirectory = trim(workingdirectory)//'/'//workingdirectoryarg
  endif absolutepath
 
  workingdirectory = trim(rectifypath(workingdirectory))
  error = setcwd(trim(workingdirectory))
  if(error) then
    write(6,'(/,a)') ' ERROR: Invalid Working directory: '//trim(workingdirectory)
    call quit(1)
  endif
 
end subroutine setworkingdirectory
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function getsolverjobname()
 
  character(len=:), allocatable :: getsolverjobname
  integer :: posext,possep
 
  posext = scan(geometryfile,'.',back=.true.)
  possep = scan(geometryfile,'/',back=.true.)
 
  getsolverjobname = geometryfile(possep+1:posext-1)
 
  posext = scan(loadcasefile,'.',back=.true.)
  possep = scan(loadcasefile,'/',back=.true.)
 
  getsolverjobname = getsolverjobname//'_'//loadcasefile(possep+1:posext-1)
 
end function getsolverjobname
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function getgeometryfile(geometryParameter)
 
  character(len=:), allocatable :: getgeometryfile
  character(len=*),  intent(in) :: geometryparameter
  logical                       :: file_exists
  external                      :: quit
 
  getgeometryfile = trim(geometryparameter)
  if (scan(getgeometryfile,'/') /= 1) getgeometryfile = getcwd()//'/'//trim(getgeometryfile)
  getgeometryfile = trim(makerelativepath(getcwd(), getgeometryfile))
 
  inquire(file=getgeometryfile, exist=file_exists)
  if (.not. file_exists) then
    write(6,'(/,a)') ' ERROR: Geometry file does not exists ('//trim(getgeometryfile)//')'
    call quit(1)
  endif
 
end function getgeometryfile
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function getloadcasefile(loadCaseParameter)
 
  character(len=:), allocatable :: getloadcasefile
  character(len=*),  intent(in) :: loadcaseparameter
  logical                       :: file_exists
  external                      :: quit
 
  getloadcasefile = trim(loadcaseparameter)
  if (scan(getloadcasefile,'/') /= 1) getloadcasefile = getcwd()//'/'//trim(getloadcasefile)
  getloadcasefile = trim(makerelativepath(getcwd(), getloadcasefile))
 
  inquire(file=getloadcasefile, exist=file_exists)
  if (.not. file_exists) then
    write(6,'(/,a)') ' ERROR: Load case file does not exists ('//trim(getloadcasefile)//')'
    call quit(1)
  endif
 
end function getloadcasefile
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function rectifypath(path)
 
  character(len=*), intent(in)  :: path
  character(len=:), allocatable :: rectifypath
  integer :: i,j,k,l
 
!--------------------------------------------------------------------------------------------------
! remove /./ from path
  rectifypath = trim(path)
  l = len_trim(rectifypath)
  do i = l,3,-1
    if (rectifypath(i-2:i) == '/./') rectifypath(i-1:l) = rectifypath(i+1:l)//'  '
  enddo
 
!--------------------------------------------------------------------------------------------------
! remove // from path
  l = len_trim(rectifypath)
  do i = l,2,-1
    if (rectifypath(i-1:i) == '//') rectifypath(i-1:l) = rectifypath(i:l)//' '
  enddo
 
!--------------------------------------------------------------------------------------------------
! remove ../ and corresponding directory from rectifyPath
  l = len_trim(rectifypath)
  i = index(rectifypath(i:l),'../')
  j = 0
  do while (i > j)
     j = scan(rectifypath(1:i-2),'/',back=.true.)
     rectifypath(j+1:l) = rectifypath(i+3:l)//repeat(' ',2+i-j)
     if (rectifypath(j+1:j+1) == '/') then                                                          !search for '//' that appear in case of XXX/../../XXX
       k = len_trim(rectifypath)
       rectifypath(j+1:k-1) = rectifypath(j+2:k)
       rectifypath(k:k) = ' '
     endif
     i = j+index(rectifypath(j+1:l),'../')
  enddo
  if(len_trim(rectifypath) == 0) rectifypath = '/'
 
  rectifypath = trim(rectifypath)
 
end function rectifypath
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function makerelativepath(a,b)
 
  character (len=*), intent(in) :: a,b
  character (len=pPathLen)      :: a_cleaned,b_cleaned
  character(len=:), allocatable :: makerelativepath
  integer :: i,poslastcommonslash,remainingslashes
 
  poslastcommonslash = 0
  remainingslashes = 0
  a_cleaned = rectifypath(trim(a)//'/')
  b_cleaned = rectifypath(b)
 
  do i = 1, min(1024,len_trim(a_cleaned),len_trim(rectifypath(b_cleaned)))
    if (a_cleaned(i:i) /= b_cleaned(i:i)) exit
    if (a_cleaned(i:i) == '/') poslastcommonslash = i
  enddo
  do i = poslastcommonslash+1,len_trim(a_cleaned)
    if (a_cleaned(i:i) == '/') remainingslashes = remainingslashes + 1
  enddo
 
  makerelativepath = repeat('..'//'/',remainingslashes)//b_cleaned(poslastcommonslash+1:len_trim(b_cleaned))
 
end function makerelativepath
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine catchsigterm(signal) bind(C)
 
  integer(C_INT), value :: signal
  sigterm = .true.
 
  write(6,'(a,i2.2,a)') ' received signal ',signal, ', set SIGTERM'
 
end subroutine catchsigterm
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine setsigterm(state)
 
  logical, intent(in) :: state
  sigterm = state
 
end subroutine setsigterm
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine catchsigusr1(signal) bind(C)
 
  integer(C_INT), value :: signal
  sigusr1 = .true.
 
  write(6,'(a,i2.2,a)') ' received signal ',signal, ', set SIGUSR1'
 
end subroutine catchsigusr1
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine setsigusr1(state)
 
  logical, intent(in) :: state
  sigusr1 = state
 
end subroutine setsigusr1
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine catchsigusr2(signal) bind(C)
 
  integer(C_INT), value :: signal
  sigusr2 = .true.
 
  write(6,'(a,i2.2,a)') ' received signal ',signal, ', set SIGUSR2'
 
end subroutine catchsigusr2
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine setsigusr2(state)
 
  logical, intent(in) :: state
  sigusr2 = state
 
end subroutine setsigusr2
 
 
end module