IO.f90

Go to the documentation of this file.

# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/IO.f90"
# 1 "<built-in>"
# 1 "<command-line>"
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/IO.f90"
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module io
  use prec
 
  implicit none
  private
  character(len=*), parameter, public :: &
    io_eof = '#EOF#', &                                                                             !< end of file string
    io_whitespace = achar(44)//achar(32)//achar(9)//achar(10)//achar(13)                            
  character, parameter, public :: &
    io_eol = new_line('DAMASK'), &                                                                  
    io_comment = '#'
  character(len=*), parameter, private :: &
    io_divider = '───────────────────'//&
                 '───────────────────'//&
                 '───────────────────'//&
                 '────────────'
  public :: &
    io_init, &
    io_read_ascii, &
    io_open_binary, &
    io_isblank, &
    io_gettag, &
    io_stringpos, &
    io_stringvalue, &
    io_floatvalue, &
    io_intvalue, &
    io_lc, &
    io_error, &
    io_warning
 
contains
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine io_init
 
  write(6,'(/,a)') ' <<<+-  IO init  -+>>>'; flush(6)
 
  call unittest
 
end subroutine io_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function io_read_ascii(fileName) result(fileContent)
 
  character(len=*),          intent(in)                :: filename
 
  character(len=pStringLen), dimension(:), allocatable :: filecontent
  character(len=pStringLen)                            :: line
  character(len=:),                        allocatable :: rawdata
  integer ::  &
    filelength, &
    fileunit, &
    startpos, endpos, &
    mytotallines, &                                                                                 !< # lines read from file
    l, &
    mystat
  logical :: warned
 
!--------------------------------------------------------------------------------------------------
! read data as stream
  inquire(file = filename, size=filelength)
  if (filelength == 0) then
    allocate(filecontent(0))
    return
  endif
  open(newunit=fileunit, file=filename, access='stream',&
       status='old', position='rewind', action='read',iostat=mystat)
  if(mystat /= 0) call io_error(100,ext_msg=trim(filename))
  allocate(character(len=fileLength)::rawdata)
  read(fileunit) rawdata
  close(fileunit)
 
!--------------------------------------------------------------------------------------------------
! count lines to allocate string array
  mytotallines = 1
  do l=1, len(rawdata)
    if (rawdata(l:l) == io_eol) mytotallines = mytotallines+1
  enddo
  allocate(filecontent(mytotallines))
 
!--------------------------------------------------------------------------------------------------
! split raw data at end of line
  warned = .false.
  startpos = 1
  l = 1
  do while (l <= mytotallines)
    endpos = merge(startpos + scan(rawdata(startpos:),io_eol) - 2,len(rawdata),l /= mytotallines)
    if (endpos - startpos > pstringlen-1) then
      line = rawdata(startpos:startpos+pstringlen-1)
      if (.not. warned) then
        call io_warning(207,ext_msg=trim(filename),el=l)
        warned = .true.
      endif
    else
      line = rawdata(startpos:endpos)
    endif
    startpos = endpos + 2                                                                           ! jump to next line start
 
    filecontent(l) = line
    l = l + 1
  enddo
 
end function io_read_ascii
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
integer function io_open_binary(fileName,mode)
 
  character(len=*), intent(in)           :: filename
  character,        intent(in), optional :: mode
 
  character :: m
  integer   :: ierr
 
  if (present(mode)) then
    m = mode
  else
    m = 'r'
  endif
 
  if    (m == 'w') then
    open(newunit=io_open_binary, file=trim(filename),&
         status='replace',access='stream',action='write',iostat=ierr)
    if (ierr /= 0) call io_error(100,ext_msg='could not open file (w): '//trim(filename))
  elseif(m == 'r') then
    open(newunit=io_open_binary, file=trim(filename),&
         status='old',    access='stream',action='read', iostat=ierr)
    if (ierr /= 0) call io_error(100,ext_msg='could not open file (r): '//trim(filename))
  else
    call io_error(100,ext_msg='unknown access mode: '//m)
  endif
 
end function io_open_binary
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
logical pure function io_isblank(string)
 
  character(len=*), intent(in) :: string
 
  integer :: posnonblank
 
  posnonblank = verify(string,io_whitespace)
  io_isblank = posnonblank == 0 .or. posnonblank == scan(string,io_comment)
 
end function io_isblank
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function io_gettag(string,openChar,closeChar)
 
  character(len=*), intent(in)  :: string
  character,        intent(in)  :: openchar, &                                                      !< indicates beginning of tag
                                   closechar
  character(len=:), allocatable :: io_gettag
 
  integer :: left,right
 
  left  = scan(string,openchar)
  right = merge(scan(string,closechar), &
                left + merge(scan(string(left+1:),openchar),0,len(string) > left), &
                openchar /= closechar)
 
  foundtag: if (left == verify(string,io_whitespace) .and. right > left) then
    io_gettag = string(left+1:right-1)
  else foundtag
    io_gettag = ''
  endif foundtag
 
end function io_gettag
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function io_stringpos(string)
 
  character(len=*),                  intent(in) :: string
  integer, dimension(:), allocatable            :: io_stringpos
 
  integer                      :: left, right
 
  allocate(io_stringpos(1), source=0)
  right = 0
 
  do while (verify(string(right+1:),io_whitespace)>0)
    left  = right + verify(string(right+1:),io_whitespace)
    right = left + scan(string(left:),io_whitespace) - 2
    if ( string(left:left) == io_comment) exit
    io_stringpos = [io_stringpos,left,right]
    io_stringpos(1) = io_stringpos(1)+1
    endofstring: if (right < left) then
      io_stringpos(io_stringpos(1)*2+1) = len_trim(string)
      exit
    endif endofstring
  enddo
 
end function io_stringpos
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function io_stringvalue(string,chunkPos,myChunk)
 
  character(len=*),             intent(in) :: string
  integer,   dimension(:),      intent(in) :: chunkpos
  integer,                      intent(in) :: mychunk
  character(len=:), allocatable            :: io_stringvalue
 
  validchunk: if (mychunk > chunkpos(1) .or. mychunk < 1) then
    io_stringvalue = ''
    call io_error(110,el=mychunk,ext_msg='IO_stringValue: "'//trim(string)//'"')
  else validchunk
    io_stringvalue = string(chunkpos(mychunk*2):chunkpos(mychunk*2+1))
  endif validchunk
 
end function io_stringvalue
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
integer function io_intvalue(string,chunkPos,myChunk)
 
  character(len=*),      intent(in) :: string
  integer, dimension(:), intent(in) :: chunkpos
  integer,               intent(in) :: mychunk
 
  io_intvalue = verifyintvalue(io_stringvalue(string,chunkpos,mychunk))
 
end function io_intvalue
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
real(pReal) function io_floatvalue(string,chunkPos,myChunk)
 
  character(len=*),        intent(in) :: string
  integer,   dimension(:), intent(in) :: chunkpos
  integer,                 intent(in) :: mychunk
 
  io_floatvalue = verifyfloatvalue(io_stringvalue(string,chunkpos,mychunk))
 
end function io_floatvalue
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function io_lc(string)
 
  character(len=*), intent(in) :: string
  character(len=len(string))   :: io_lc
 
  character(len=*),          parameter :: lower = 'abcdefghijklmnopqrstuvwxyz'
  character(len=len(LOWER)), parameter :: upper = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
 
  integer :: i,n
 
  do i=1,len(string)
    n = index(upper,string(i:i))
    if(n/=0) then
      io_lc(i:i) = lower(n:n)
    else
      io_lc(i:i) = string(i:i)
    endif
  enddo
 
end function io_lc
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine io_error(error_ID,el,ip,g,instance,ext_msg)
 
  integer,                    intent(in) :: error_id
  integer,          optional, intent(in) :: el,ip,g,instance
  character(len=*), optional, intent(in) :: ext_msg
 
  external                               :: quit
  character(len=pStringLen)              :: msg
  character(len=pStringLen)              :: formatstring
 
  select case (error_id)
 
!--------------------------------------------------------------------------------------------------
! internal errors
    case (0)
      msg = 'internal check failed:'
 
!--------------------------------------------------------------------------------------------------
! file handling errors
    case (100)
      msg = 'could not open file:'
    case (101)
      msg = 'write error for file:'
    case (102)
      msg = 'could not read file:'
    case (103)
      msg = 'could not assemble input files'
    case (106)
      msg = 'working directory does not exist:'
 
!--------------------------------------------------------------------------------------------------
! file parsing errors
    case (110)
      msg = 'invalid chunk selected'
    case (111)
      msg = 'invalid character for int:'
    case (112)
      msg = 'invalid character for float:'
 
!--------------------------------------------------------------------------------------------------
! lattice error messages
    case (130)
      msg = 'unknown lattice structure encountered'
    case (131)
      msg = 'hex lattice structure with invalid c/a ratio'
    case (132)
      msg = 'trans_lattice_structure not possible'
    case (133)
      msg = 'transformed hex lattice structure with invalid c/a ratio'
    case (134)
      msg = 'negative lattice parameter'
    case (135)
      msg = 'zero entry on stiffness diagonal'
    case (136)
      msg = 'zero entry on stiffness diagonal for transformed phase'
    case (137)
      msg = 'not defined for lattice structure'
    case (138)
      msg = 'not enough interaction parameters given'
 
!--------------------------------------------------------------------------------------------------
! errors related to the parsing of material.config
    case (140)
      msg = 'key not found'
    case (141)
      msg = 'number of chunks in string differs'
    case (142)
      msg = 'empty list'
    case (143)
      msg = 'no value found for key'
    case (144)
      msg = 'negative number systems requested'
    case (145)
      msg = 'too many systems requested'
    case (146)
      msg = 'number of values does not match'
    case (147)
      msg = 'not supported anymore'
    case (148)
      msg = 'Nconstituents mismatch between homogenization and microstructure'
 
!--------------------------------------------------------------------------------------------------
! material error messages and related messages in mesh
    case (150)
      msg = 'index out of bounds'
    case (151)
      msg = 'microstructure has no constituents'
    case (153)
      msg = 'sum of phase fractions differs from 1'
    case (154)
      msg = 'homogenization index out of bounds'
    case (155)
      msg = 'microstructure index out of bounds'
    case (157)
      msg = 'invalid texture transformation specified'
    case (160)
      msg = 'no entries in config part'
    case (161)
      msg = 'config part found twice'
    case (165)
      msg = 'homogenization configuration'
    case (170)
      msg = 'no homogenization specified via State Variable 2'
    case (180)
      msg = 'no microstructure specified via State Variable 3'
    case (190)
      msg = 'unknown element type:'
    case (191)
      msg = 'mesh consists of more than one element type'
 
!--------------------------------------------------------------------------------------------------
! plasticity error messages
    case (200)
      msg = 'unknown elasticity specified:'
    case (201)
      msg = 'unknown plasticity specified:'
 
    case (210)
      msg = 'unknown material parameter:'
    case (211)
      msg = 'material parameter out of bounds:'
 
!--------------------------------------------------------------------------------------------------
! numerics error messages
    case (300)
      msg = 'unknown numerics parameter:'
    case (301)
      msg = 'numerics parameter out of bounds:'
 
!--------------------------------------------------------------------------------------------------
! math errors
    case (400)
      msg = 'matrix inversion error'
    case (401)
      msg = 'error in Eigenvalue calculation'
    case (402)
      msg = 'invalid orientation specified'
 
!-------------------------------------------------------------------------------------------------
! homogenization errors
    case (500)
      msg = 'unknown homogenization specified'
 
!--------------------------------------------------------------------------------------------------
! user errors
    case (600)
      msg = 'Ping-Pong not possible when using non-DAMASK elements'
    case (601)
      msg = 'Ping-Pong needed when using non-local plasticity'
    case (602)
      msg = 'invalid selection for debug'
 
!-------------------------------------------------------------------------------------------------
! errors related to the grid solver
    case (809)
      msg = 'initializing FFTW'
    case (810)
      msg = 'FFTW plan creation'
    case (831)
      msg = 'mask consistency violated in grid load case'
    case (832)
      msg = 'ill-defined L (line partly defined) in grid load case'
    case (834)
      msg = 'negative time increment in grid load case'
    case (835)
      msg = 'non-positive increments in grid load case'
    case (836)
      msg = 'non-positive result frequency in grid load case'
    case (837)
      msg = 'incomplete loadcase'
    case (838)
      msg = 'mixed boundary conditions allow rotation'
    case (839)
      msg = 'non-positive restart frequency in grid load case'
    case (841)
      msg = 'missing header length info in grid mesh'
    case (842)
      msg = 'incomplete information in grid mesh header'
    case (843)
      msg = 'microstructure count mismatch'
    case (846)
      msg = 'rotation for load case rotation ill-defined (R:RT != I)'
    case (891)
      msg = 'unknown solver type selected'
    case (892)
      msg = 'unknown filter type selected'
    case (894)
      msg = 'MPI error'
 
 
!-------------------------------------------------------------------------------------------------
! general error messages
    case default
      msg = 'unknown error number...'
 
  end select
 
  !$OMP CRITICAL (write2out)
  write(0,'(/,a)')                ' ┌'//io_divider//'┐'
  write(0,'(a,24x,a,40x,a)')      ' │','error',                                             '│'
  write(0,'(a,24x,i3,42x,a)')     ' │',error_id,                                            '│'
  write(0,'(a)')                  ' ├'//io_divider//'┤'
  write(formatstring,'(a,i6.6,a,i6.6,a)') '(1x,a4,a',max(1,len_trim(msg)),',',&
                                                     max(1,72-len_trim(msg)-4),'x,a)'
  write(0,formatstring)            '│ ',trim(msg),                                          '│'
  if (present(ext_msg)) then
    write(formatstring,'(a,i6.6,a,i6.6,a)') '(1x,a4,a',max(1,len_trim(ext_msg)),',',&
                                                       max(1,72-len_trim(ext_msg)-4),'x,a)'
    write(0,formatstring)          '│ ',trim(ext_msg),                                      '│'
  endif
  if (present(el)) &
    write(0,'(a19,1x,i9,44x,a3)') ' │ at element    ',el,                                   '│'
  if (present(ip)) &
    write(0,'(a19,1x,i9,44x,a3)') ' │ at IP         ',ip,                                   '│'
  if (present(g)) &
    write(0,'(a19,1x,i9,44x,a3)') ' │ at constituent',g,                                    '│'
  if (present(instance)) &
    write(0,'(a19,1x,i9,44x,a3)') ' │ at instance   ',instance,                             '│'
  write(0,'(a,69x,a)')            ' │',                                                     '│'
  write(0,'(a)')                  ' └'//io_divider//'┘'
  flush(0)
  call quit(9000+error_id)
  !$OMP END CRITICAL (write2out)
 
end subroutine io_error
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine io_warning(warning_ID,el,ip,g,ext_msg)
 
  integer,                    intent(in) :: warning_id
  integer,          optional, intent(in) :: el,ip,g
  character(len=*), optional, intent(in) :: ext_msg
 
  character(len=pStringLen)              :: msg
  character(len=pStringLen)              :: formatstring
 
  select case (warning_id)
    case (1)
      msg = 'unknown key'
    case (34)
      msg = 'invalid restart increment given'
    case (35)
      msg = 'could not get $DAMASK_NUM_THREADS'
    case (40)
      msg = 'found spectral solver parameter'
    case (42)
      msg = 'parameter has no effect'
    case (43)
      msg = 'main diagonal of C66 close to zero'
    case (47)
      msg = 'no valid parameter for FFTW, using FFTW_PATIENT'
    case (50)
      msg = 'not all available slip system families are defined'
    case (51)
      msg = 'not all available twin system families are defined'
    case (52)
      msg = 'not all available parameters are defined'
    case (53)
      msg = 'not all available transformation system families are defined'
    case (101)
      msg = 'crystallite debugging off'
    case (201)
      msg = 'position not found when parsing line'
    case (207)
      msg = 'line truncated'
    case (600)
      msg = 'crystallite responds elastically'
    case (601)
      msg = 'stiffness close to zero'
    case (650)
      msg = 'polar decomposition failed'
    case (700)
      msg = 'unknown crystal symmetry'
    case (850)
      msg = 'max number of cut back exceeded, terminating'
    case default
      msg = 'unknown warning number'
    end select
 
  !$OMP CRITICAL (write2out)
  write(6,'(/,a)')                ' ┌'//io_divider//'┐'
  write(6,'(a,24x,a,38x,a)')      ' │','warning',                                           '│'
  write(6,'(a,24x,i3,42x,a)')     ' │',warning_id,                                          '│'
  write(6,'(a)')                  ' ├'//io_divider//'┤'
  write(formatstring,'(a,i6.6,a,i6.6,a)') '(1x,a4,a',max(1,len_trim(msg)),',',&
                                                     max(1,72-len_trim(msg)-4),'x,a)'
  write(6,formatstring)            '│ ',trim(msg),                                          '│'
  if (present(ext_msg)) then
    write(formatstring,'(a,i6.6,a,i6.6,a)') '(1x,a4,a',max(1,len_trim(ext_msg)),',',&
                                                       max(1,72-len_trim(ext_msg)-4),'x,a)'
    write(6,formatstring)          '│ ',trim(ext_msg),                                      '│'
  endif
  if (present(el)) &
    write(6,'(a19,1x,i9,44x,a3)') ' │ at element    ',el,                                   '│'
  if (present(ip)) &
    write(6,'(a19,1x,i9,44x,a3)') ' │ at IP         ',ip,                                   '│'
  if (present(g)) &
    write(6,'(a19,1x,i9,44x,a3)') ' │ at constituent',g,                                    '│'
  write(6,'(a,69x,a)')            ' │',                                                     '│'
  write(6,'(a)')                  ' └'//io_divider//'┘'
  flush(6)
  !$OMP END CRITICAL (write2out)
 
end subroutine io_warning
 
 
!--------------------------------------------------------------------------------------------------
! internal helper functions
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
integer function verifyintvalue(string)
 
  character(len=*), intent(in) :: string
 
  integer                      :: readstatus
  character(len=*), parameter  :: validchars = '0123456789+- '
 
  valid: if (verify(string,validchars) == 0) then
    read(string,*,iostat=readstatus) verifyintvalue
    if (readstatus /= 0) call io_error(111,ext_msg=string)
  else valid
    verifyintvalue = 0
    call io_error(111,ext_msg=string)
  endif valid
 
end function verifyintvalue
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
real(pReal) function verifyfloatvalue(string)
 
  character(len=*), intent(in) :: string
 
  integer                      :: readstatus
  character(len=*), parameter  :: validchars = '0123456789eE.+- '
 
  valid: if (verify(string,validchars) == 0) then
    read(string,*,iostat=readstatus) verifyfloatvalue
    if (readstatus /= 0) call io_error(112,ext_msg=string)
  else valid
    verifyfloatvalue = 0.0_preal
    call io_error(112,ext_msg=string)
  endif valid
 
end function verifyfloatvalue
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine unittest
 
  integer, dimension(:), allocatable :: chunkPos
  character(len=:),      allocatable :: str
 
  if(dneq(1.0_preal, verifyfloatvalue('1.0')))      call io_error(0,ext_msg='verifyFloatValue')
  if(dneq(1.0_preal, verifyfloatvalue('1e0')))      call io_error(0,ext_msg='verifyFloatValue')
  if(dneq(0.1_preal, verifyfloatvalue('1e-1')))     call io_error(0,ext_msg='verifyFloatValue')
 
  if(3112019  /= verifyintvalue( '3112019'))        call io_error(0,ext_msg='verifyIntValue')
  if(3112019  /= verifyintvalue(' 3112019'))        call io_error(0,ext_msg='verifyIntValue')
  if(-3112019 /= verifyintvalue('-3112019'))        call io_error(0,ext_msg='verifyIntValue')
  if(3112019  /= verifyintvalue('+3112019 '))       call io_error(0,ext_msg='verifyIntValue')
 
  if(any([1,1,1]     /= io_stringpos('a')))         call io_error(0,ext_msg='IO_stringPos')
  if(any([2,2,3,5,5] /= io_stringpos(' aa b')))     call io_error(0,ext_msg='IO_stringPos')
 
  str=' 1.0 xxx'
  chunkpos = io_stringpos(str)
  if(dneq(1.0_preal,io_floatvalue(str,chunkpos,1))) call io_error(0,ext_msg='IO_floatValue')
 
  str='M 3112019 F'
  chunkpos = io_stringpos(str)
  if(3112019 /= io_intvalue(str,chunkpos,2))        call io_error(0,ext_msg='IO_intValue')
 
  if(.not. io_isblank('  '))                        call io_error(0,ext_msg='IO_isBlank/1')
  if(.not. io_isblank('  #isBlank'))                call io_error(0,ext_msg='IO_isBlank/2')
  if(      io_isblank('  i#s'))                     call io_error(0,ext_msg='IO_isBlank/3')
 
end subroutine unittest
 
end module io