DAMASK_marc.f90

Go to the documentation of this file.

# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/DAMASK_marc.f90"
# 1 "<built-in>"
# 1 "<command-line>"
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/DAMASK_marc.f90"
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
 
 
 
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/prec.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module prec
  use, intrinsic :: ieee_arithmetic
 
  implicit none
  public
 
  ! https://software.intel.com/en-us/blogs/2017/03/27/doctor-fortran-in-it-takes-all-kinds
  integer,     parameter :: preal      = ieee_selected_real_kind(15,307)                            
 
  integer,     parameter :: pint       = selected_int_kind(18)                                      
 
 
 
  integer,     parameter :: plongint   = selected_int_kind(18)                                      
  integer,     parameter :: pstringlen = 256
  integer,     parameter :: ppathlen   = 4096
 
  real(preal), parameter :: tol_math_check = 1.0e-8_preal                                           
 
 
  type :: group_float                                                                               
    real(preal), dimension(:), pointer :: p
  end type group_float
 
  type :: group_int
    integer, dimension(:), pointer :: p
  end type group_int
 
  ! http://stackoverflow.com/questions/3948210/can-i-have-a-pointer-to-an-item-in-an-allocatable-array
  type :: tstate
    integer :: &
      sizestate        = 0, &                                                                       !< size of state
      sizedotstate     = 0, &                                                                       
      offsetdeltastate = 0, &                                                                       
      sizedeltastate   = 0                                                                          
    real(preal), pointer,     dimension(:), contiguous :: &
      atol
    real(preal), pointer,     dimension(:,:), contiguous :: &                                       ! a pointer is needed here because we might point to state/doState. However, they will never point to something, but are rather allocated and, hence, contiguous
      state0, &
      state, &                                                                                      !< state
      dotstate, &                                                                                   !< rate of state change
      deltastate
    real(preal), allocatable, dimension(:,:) :: &
      partionedstate0, &
      substate0, &
      previousdotstate, &
      previousdotstate2
    real(preal), allocatable, dimension(:,:,:) :: &
      rk4dotstate, &
      rkck45dotstate
  end type
 
  type, extends(tstate) :: tplasticstate
    logical :: &
      nonlocal = .false.
    real(preal), pointer,     dimension(:,:) :: &
      sliprate, &                                                                                   !< slip rate
      accumulatedslip
  end type
 
  type :: tsourcestate
    type(tstate), dimension(:), allocatable :: p
  end type
 
  type :: thomogmapping
    integer, pointer, dimension(:,:) :: p
  end type
 
  real(preal), private, parameter :: preal_epsilon = epsilon(0.0_preal)                             
  real(preal), private, parameter :: preal_min     = tiny(0.0_preal)                                
 
  integer,                   dimension(0), parameter :: &
    emptyintarray    = [integer::]
  real(preal),               dimension(0), parameter :: &
    emptyrealarray   = [real(preal)::]
  character(len=pStringLen), dimension(0), parameter :: &
    emptystringarray = [character(len=pstringlen)::]
 
  private :: &
    unittest
 
contains
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine prec_init
 
  write(6,'(/,a)') ' <<<+-  prec init  -+>>>'
 
  write(6,'(a,i3)')    ' Size of integer in bit: ',bit_size(0)
  write(6,'(a,i19)')   '   Maximum value:        ',huge(0)
  write(6,'(/,a,i3)')  ' Size of float in bit:   ',storage_size(0.0_preal)
  write(6,'(a,e10.3)') '   Maximum value:        ',huge(0.0_preal)
  write(6,'(a,e10.3)') '   Minimum value:        ',tiny(0.0_preal)
  write(6,'(a,i3)')    '   Decimal precision:    ',precision(0.0_preal)
 
  call unittest
 
end subroutine prec_init
 
 
!--------------------------------------------------------------------------------------------------
! replaces "==" but for certain (relative) tolerance. Counterpart to dNeq
! https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/
! AlmostEqualRelative
!--------------------------------------------------------------------------------------------------
logical elemental pure function dEq(a,b,tol)
 
  real(preal), intent(in)           :: a,b
  real(preal), intent(in), optional :: tol
  real(preal)                       :: eps
 
  if (present(tol)) then
    eps = tol
  else
    eps = preal_epsilon * maxval(abs([a,b]))
  endif
 
  deq = merge(.true.,.false.,abs(a-b) <= eps)
 
end function deq
 
 
!--------------------------------------------------------------------------------------------------
! replaces "!=" but for certain (relative) tolerance. Counterpart to dEq
! https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/
! AlmostEqualRelative NOT
!--------------------------------------------------------------------------------------------------
logical elemental pure function dneq(a,b,tol)
 
  real(preal), intent(in)           :: a,b
  real(preal), intent(in), optional :: tol
 
  if (present(tol)) then
    dneq = .not. deq(a,b,tol)
  else
    dneq = .not. deq(a,b)
  endif
 
end function dneq
 
 
!--------------------------------------------------------------------------------------------------
! replaces "==0" but everything not representable as a normal number is treated as 0. Counterpart to dNeq0
! https://de.mathworks.com/help/matlab/ref/realmin.html
! https://docs.oracle.com/cd/E19957-01/806-3568/ncg_math.html
!--------------------------------------------------------------------------------------------------
logical elemental pure function deq0(a,tol)
 
  real(preal), intent(in)           :: a
  real(preal), intent(in), optional :: tol
  real(preal)                       :: eps
 
  if (present(tol)) then
    eps = tol
  else
    eps = preal_min * 10.0_preal
  endif
 
  deq0 = merge(.true.,.false.,abs(a) <= eps)
 
end function deq0
 
 
!--------------------------------------------------------------------------------------------------
! replaces "!=0" but everything not representable as a normal number is treated as 0. Counterpart to dEq0
! https://de.mathworks.com/help/matlab/ref/realmin.html
! https://docs.oracle.com/cd/E19957-01/806-3568/ncg_math.html
!--------------------------------------------------------------------------------------------------
logical elemental pure function dneq0(a,tol)
 
  real(preal), intent(in)           :: a
  real(preal), intent(in), optional :: tol
 
  if (present(tol)) then
    dneq0 = .not. deq0(a,tol)
  else
    dneq0 = .not. deq0(a)
  endif
 
end function dneq0
 
 
!--------------------------------------------------------------------------------------------------
! replaces "==" but for certain (relative) tolerance. Counterpart to cNeq
! https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/
! probably a component wise comparison would be more accurate than the comparsion of the absolute
! value
!--------------------------------------------------------------------------------------------------
logical elemental pure function ceq(a,b,tol)
 
  complex(pReal), intent(in)           :: a,b
  real(preal),    intent(in), optional :: tol
  real(preal)                          :: eps
 
  if (present(tol)) then
    eps = tol
  else
    eps = preal_epsilon * maxval(abs([a,b]))
  endif
 
  ceq = merge(.true.,.false.,abs(a-b) <= eps)
 
end function ceq
 
 
!--------------------------------------------------------------------------------------------------
! replaces "!=" but for certain (relative) tolerance. Counterpart to cEq
! https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/
! probably a component wise comparison would be more accurate than the comparsion of the absolute
! value
!--------------------------------------------------------------------------------------------------
logical elemental pure function cneq(a,b,tol)
 
  complex(pReal), intent(in)           :: a,b
  real(preal),    intent(in), optional :: tol
 
  if (present(tol)) then
    cneq = .not. ceq(a,b,tol)
  else
    cneq = .not. ceq(a,b)
  endif
 
end function cneq
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine unittest
 
  integer, allocatable, dimension(:) :: realloc_lhs_test
  real(preal), dimension(2) :: r
  external :: &
    quit
 
  call random_number(r)
  r = r/minval(r)
  if(.not. all(deq(r,r+preal_epsilon)))    call quit(9000)
  if(deq(r(1),r(2)) .and. dneq(r(1),r(2))) call quit(9000)
  if(.not. all(deq0(r-(r+preal_min))))     call quit(9000)
 
  realloc_lhs_test = [1,2]
  if (any(realloc_lhs_test/=[1,2])) call quit(9000)
 
end subroutine unittest
 
end module prec
# 29 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/DAMASK_marc.f90" 2
 
module damask_interface
  use prec
 
 
 
 
 
  use ifport, only: &
    chdir
 
  implicit none
  private
 
  logical,          protected, public :: symmetricsolver
  character(len=*), parameter, public :: inputfileextension = '.dat'
 
  public :: &
    damask_interface_init, &
    getsolverjobname
 
contains
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine damask_interface_init
 
  integer, dimension(8)   :: dateandtime
  integer                 :: ierr
  character(len=pPathLen) :: wd
 
  write(6,'(/,a)') ' <<<+-  DAMASK_marc init -+>>>'
 
  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,i4.4,a,i8.8)') ' Compiled with Intel fortran version :', __intel_compiler,&
                                                        ', build date :', __intel_compiler_build_date
 
 
  write(6,'(/,a)') ' Compiled on: '//"Apr  1 2020"//' at '//"18:44:55"
 
  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)
 
  inquire(5, name=wd)
  wd = wd(1:scan(wd,'/',back=.true.))
  ierr = chdir(wd)
  if (ierr /= 0) then
    write(6,'(a20,a,a16)') ' working directory "',trim(wd),'" does not exist'
    call quit(1)
  endif
  symmetricsolver = solverissymmetric()
 
end subroutine damask_interface_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function getsolverjobname()
 
  character(len=:), allocatable :: getsolverjobname
  character(1024)               :: inputname
  character(len=*), parameter   :: pathsep = achar(47)//achar(92)                                   ! forward and backward slash
  integer :: extpos
 
  inputname=''
  inquire(5, name=inputname)                                                                        ! determine inputfile
  extpos = len_trim(inputname)-4
  getsolverjobname=inputname(scan(inputname,pathsep,back=.true.)+1:extpos)
 
end function getsolverjobname
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
logical function solverissymmetric()
 
  character(len=pStringLen) :: line
  integer :: mystat,fileunit,s,e
 
  open(newunit=fileunit, file=getsolverjobname()//inputfileextension, &
       status='old', position='rewind', action='read',iostat=mystat)
  do
    read (fileunit,'(A)',END=100) line
    if(index(trim(lc(line)),'solver') == 1) then
      read (fileunit,'(A)',END=100) line                                                            ! next line
        s =     verify(line,      ' ')                                                              ! start of first chunk
        s = s + verify(line(s+1:),' ')                                                              ! start of second chunk
        e = s + scan(line(s+1:),' ')                                                              ! end of second chunk
      solverissymmetric = line(s:e) /= '1'
    endif
  enddo
100 close(fileunit)
  contains
 
  !--------------------------------------------------------------------------------------------------
  !--------------------------------------------------------------------------------------------------
  function lc(string)
 
    character(len=*), intent(in) :: string
    character(len=len(string))   :: lc
 
    character(26), parameter :: lower = 'abcdefghijklmnopqrstuvwxyz'
    character(26), parameter :: upper = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
 
    integer                  :: i,n
 
    do i=1,len(string)
      lc(i:i) = string(i:i)
      n = index(upper,lc(i:i))
      if (n/=0) lc(i:i) = lower(n:n)
    enddo
  end function lc
 
end function solverissymmetric
 
end module damask_interface
 
 
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/IO.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
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
# 7 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/numerics.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module numerics
 use prec
 use io
 
 
 
 
 
!$ use OMP_LIB
 
 implicit none
 private
 
 integer, protected, public :: &
   ijacostiffness             =  1, &                                                               !< frequency of stiffness update
   randomseed                 =  0, &                                                               
   worldrank                  =  0, &                                                               
   worldsize                  =  1, &                                                               
   numerics_integrator        =  1                                                                  
 integer(4), protected, public :: &
   damask_numthreadsint       =  0
 real(preal), protected, public :: &
   defgradtolerance           =  1.0e-7_preal, &                                                    
   numerics_unitlength        =  1.0_preal, &                                                       
   charlength                 =  1.0_preal, &                                                       
   residualstiffness          =  1.0e-6_preal                                                       
 logical, protected, public :: &
   usepingpong                = .true.
 
!--------------------------------------------------------------------------------------------------
! field parameters:
 real(preal), protected, public :: &
   err_struct_tolabs          =  1.0e-10_preal, &                                                   
   err_struct_tolrel          =  1.0e-4_preal, &                                                    
   err_thermal_tolabs         =  1.0e-2_preal, &                                                    
   err_thermal_tolrel         =  1.0e-6_preal, &                                                    
   err_damage_tolabs          =  1.0e-2_preal, &                                                    
   err_damage_tolrel          =  1.0e-6_preal                                                       
 integer, protected, public :: &
   itmax                      =  250, &                                                             !< maximum number of iterations
   itmin                      =  1, &                                                               
   stagitmax                  =  10, &                                                              
   maxcutback                 =  3                                                                  
 
!--------------------------------------------------------------------------------------------------
! spectral parameters:
# 65 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/numerics.f90"
 
!--------------------------------------------------------------------------------------------------
! FEM parameters:
# 77 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/numerics.f90"
 
 public :: numerics_init
 
contains
 
 
!--------------------------------------------------------------------------------------------------
! a sanity check
!--------------------------------------------------------------------------------------------------
subroutine numerics_init
!$ integer ::                                gotDAMASK_NUM_THREADS = 1
 integer :: i,j, ierr
 integer, allocatable, dimension(:) :: chunkpos
 character(len=pStringLen), dimension(:), allocatable :: filecontent
 character(len=pStringLen) :: &
   tag ,&
   line
 logical :: fexist
!$ character(len=6) DAMASK_NumThreadsString                                                         ! environment variable DAMASK_NUM_THREADS
 
 
 
 
 
 write(6,'(/,a)') ' <<<+-  numerics init  -+>>>'
 
!$ call GET_ENVIRONMENT_VARIABLE(NAME='DAMASK_NUM_THREADS',VALUE=DAMASK_NumThreadsString,STATUS=gotDAMASK_NUM_THREADS)   ! get environment variable DAMASK_NUM_THREADS...
!$ if(gotDAMASK_NUM_THREADS /= 0) then                                                              ! could not get number of threads, set it to 1
!$   call IO_warning(35,ext_msg='BEGIN:'//DAMASK_NumThreadsString//':END')
!$   DAMASK_NumThreadsInt = 1_4
!$ else
!$   read(DAMASK_NumThreadsString,'(i6)') DAMASK_NumThreadsInt                                      ! read as integer
!$   if (DAMASK_NumThreadsInt < 1_4) DAMASK_NumThreadsInt = 1_4                                     ! in case of string conversion fails, set it to one
!$ endif
!$ call omp_set_num_threads(DAMASK_NumThreadsInt)                                                   ! set number of threads for parallel execution
 
 inquire(file='numerics.config', exist=fexist)
 
 fileexists: if (fexist) then
   write(6,'(a,/)') ' using values from config file'
   flush(6)
   filecontent = io_read_ascii('numerics.config')
   do j=1, size(filecontent)
 
!--------------------------------------------------------------------------------------------------
! read variables from config file and overwrite default parameters if keyword is present
     line = filecontent(j)
     do i=1,len(line)
       if(line(i:i) == '=') line(i:i) = ' '                                                         ! also allow keyword = value version
     enddo
     if (io_isblank(line)) cycle                                                                    ! skip empty lines
     chunkpos = io_stringpos(line)
     tag = io_lc(io_stringvalue(line,chunkpos,1))                                                   ! extract key
 
     select case(tag)
       case ('defgradtolerance')
         defgradtolerance = io_floatvalue(line,chunkpos,2)
       case ('ijacostiffness')
         ijacostiffness = io_intvalue(line,chunkpos,2)
       case ('integrator')
         numerics_integrator = io_intvalue(line,chunkpos,2)
       case ('usepingpong')
         usepingpong = io_intvalue(line,chunkpos,2) > 0
       case ('unitlength')
         numerics_unitlength = io_floatvalue(line,chunkpos,2)
 
!--------------------------------------------------------------------------------------------------
! random seeding parameter
       case ('random_seed','fixed_seed')
         randomseed = io_intvalue(line,chunkpos,2)
 
!--------------------------------------------------------------------------------------------------
! gradient parameter
       case ('charlength')
         charlength = io_floatvalue(line,chunkpos,2)
       case ('residualstiffness')
         residualstiffness = io_floatvalue(line,chunkpos,2)
 
!--------------------------------------------------------------------------------------------------
! field parameters
       case ('err_struct_tolabs')
         err_struct_tolabs = io_floatvalue(line,chunkpos,2)
       case ('err_struct_tolrel')
         err_struct_tolrel = io_floatvalue(line,chunkpos,2)
       case ('err_thermal_tolabs')
         err_thermal_tolabs = io_floatvalue(line,chunkpos,2)
       case ('err_thermal_tolrel')
         err_thermal_tolrel = io_floatvalue(line,chunkpos,2)
       case ('err_damage_tolabs')
         err_damage_tolabs = io_floatvalue(line,chunkpos,2)
       case ('err_damage_tolrel')
         err_damage_tolrel = io_floatvalue(line,chunkpos,2)
       case ('itmax')
         itmax = io_intvalue(line,chunkpos,2)
       case ('itmin')
         itmin = io_intvalue(line,chunkpos,2)
       case ('maxcutback')
         maxcutback = io_intvalue(line,chunkpos,2)
       case ('maxstaggerediter')
         stagitmax = io_intvalue(line,chunkpos,2)
 
!--------------------------------------------------------------------------------------------------
! spectral parameters
# 201 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/numerics.f90"
 
!--------------------------------------------------------------------------------------------------
! FEM parameters
# 214 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/numerics.f90"
     end select
   enddo
 else fileexists
   write(6,'(a,/)') ' using standard values'
   flush(6)
 endif fileexists
 
 
!--------------------------------------------------------------------------------------------------
! writing parameters to output
 write(6,'(a24,1x,es8.1)')  ' defgradTolerance:       ',defgradtolerance
 write(6,'(a24,1x,i8)')     ' iJacoStiffness:         ',ijacostiffness
 write(6,'(a24,1x,i8)')     ' integrator:             ',numerics_integrator
 write(6,'(a24,1x,L8)')     ' use ping pong scheme:   ',usepingpong
 write(6,'(a24,1x,es8.1,/)')' unitlength:             ',numerics_unitlength
 
!--------------------------------------------------------------------------------------------------
! Random seeding parameter
 write(6,'(a16,1x,i16,/)')    ' random_seed:    ',randomseed
 if (randomseed <= 0) &
   write(6,'(a,/)')           ' random seed will be generated!'
 
!--------------------------------------------------------------------------------------------------
! gradient parameter
 write(6,'(a24,1x,es8.1)')   ' charLength:             ',charlength
 write(6,'(a24,1x,es8.1)')   ' residualStiffness:      ',residualstiffness
 
!--------------------------------------------------------------------------------------------------
! openMP parameter
 !$  write(6,'(a24,1x,i8,/)')   ' number of threads:      ',DAMASK_NumThreadsInt
 
!--------------------------------------------------------------------------------------------------
! field parameters
 write(6,'(a24,1x,i8)')      ' itmax:                  ',itmax
 write(6,'(a24,1x,i8)')      ' itmin:                  ',itmin
 write(6,'(a24,1x,i8)')      ' maxCutBack:             ',maxcutback
 write(6,'(a24,1x,i8)')      ' maxStaggeredIter:       ',stagitmax
 write(6,'(a24,1x,es8.1)')   ' err_struct_tolAbs:      ',err_struct_tolabs
 write(6,'(a24,1x,es8.1)')   ' err_struct_tolRel:      ',err_struct_tolrel
 write(6,'(a24,1x,es8.1)')   ' err_thermal_tolabs:     ',err_thermal_tolabs
 write(6,'(a24,1x,es8.1)')   ' err_thermal_tolrel:     ',err_thermal_tolrel
 write(6,'(a24,1x,es8.1)')   ' err_damage_tolabs:      ',err_damage_tolabs
 write(6,'(a24,1x,es8.1)')   ' err_damage_tolrel:      ',err_damage_tolrel
 
!--------------------------------------------------------------------------------------------------
! spectral parameters
# 271 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/numerics.f90"
 
!--------------------------------------------------------------------------------------------------
! spectral parameters
 
 
 
 
 
 
 
!--------------------------------------------------------------------------------------------------
! sanity checks
 if (defgradtolerance <= 0.0_preal)        call io_error(301,ext_msg='defgradTolerance')
 if (ijacostiffness < 1)                   call io_error(301,ext_msg='iJacoStiffness')
 if (numerics_integrator <= 0 .or. numerics_integrator >= 6) &
                                           call io_error(301,ext_msg='integrator')
 if (numerics_unitlength <= 0.0_preal)     call io_error(301,ext_msg='unitlength')
 if (residualstiffness < 0.0_preal)        call io_error(301,ext_msg='residualStiffness')
 if (itmax <= 1)                           call io_error(301,ext_msg='itmax')
 if (itmin > itmax .or. itmin < 1)         call io_error(301,ext_msg='itmin')
 if (maxcutback < 0)                       call io_error(301,ext_msg='maxCutBack')
 if (stagitmax < 0)                        call io_error(301,ext_msg='maxStaggeredIter')
 if (err_struct_tolrel <= 0.0_preal)       call io_error(301,ext_msg='err_struct_tolRel')
 if (err_struct_tolabs <= 0.0_preal)       call io_error(301,ext_msg='err_struct_tolAbs')
 if (err_thermal_tolabs <= 0.0_preal)      call io_error(301,ext_msg='err_thermal_tolabs')
 if (err_thermal_tolrel <= 0.0_preal)      call io_error(301,ext_msg='err_thermal_tolrel')
 if (err_damage_tolabs <= 0.0_preal)       call io_error(301,ext_msg='err_damage_tolabs')
 if (err_damage_tolrel <= 0.0_preal)       call io_error(301,ext_msg='err_damage_tolrel')
# 311 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/numerics.f90"
 
end subroutine numerics_init
 
end module numerics
# 8 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/debug.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module debug
  use prec
  use io
 
  implicit none
  private
 
  integer, parameter, public :: &
    debug_levelselective     = 2**0, &
    debug_levelbasic         = 2**1, &
    debug_levelextensive     = 2**2
  integer, parameter, private :: &
    debug_maxgeneral         = debug_levelextensive                                                 ! must be set to the last bitcode used by (potentially) all debug types
  integer, parameter, public :: &
    debug_spectralrestart    = debug_maxgeneral*2**1, &
    debug_spectralfftw       = debug_maxgeneral*2**2, &
    debug_spectraldivergence = debug_maxgeneral*2**3, &
    debug_spectralrotation   = debug_maxgeneral*2**4, &
    debug_spectralpetsc      = debug_maxgeneral*2**5
    
  integer, parameter, public :: &
    debug_debug                   =  1, &
    debug_math                    =  2, &
    debug_fesolving               =  3, &
    debug_mesh                    =  4, &                                                           
    debug_material                =  5, &                                                           
    debug_lattice                 =  6, &                                                           
    debug_constitutive            =  7, &                                                           
    debug_crystallite             =  8, &
    debug_homogenization          =  9, &
    debug_cpfem                   = 10, &
    debug_spectral                = 11, &
    debug_marc                    = 12
  integer, parameter, private :: &
    debug_maxntype                = debug_marc                                                      
 
  integer,protected, dimension(debug_maxNtype+2),  public :: &                                      ! specific ones, and 2 for "all" and "other"
    debug_level                    = 0
 
  integer, protected, public :: &
    debug_e                       = 1, &
    debug_i                       = 1, &
    debug_g                       = 1
 
  integer, dimension(2), public :: &
    debug_stressmaxlocation       = 0, &
    debug_stressminlocation       = 0, &
    debug_jacobianmaxlocation     = 0, &
    debug_jacobianminlocation     = 0
 
 
  real(preal), public :: &
    debug_stressmax               = -huge(1.0_preal), &
    debug_stressmin               =  huge(1.0_preal), &
    debug_jacobianmax             = -huge(1.0_preal), &
    debug_jacobianmin             =  huge(1.0_preal)
 
 
 
 
 
  public :: debug_init, &
            debug_reset, &
            debug_info
 
contains
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine debug_init
 
  character(len=pStringLen), dimension(:), allocatable :: filecontent
 
  integer                            :: i, what, j
  integer, allocatable, dimension(:) :: chunkpos
  character(len=pStringLen)          :: tag, line
  logical :: fexist 
 
  write(6,'(/,a)')   ' <<<+-  debug init  -+>>>'
 
 
 
 
 
  inquire(file='debug.config', exist=fexist)
 
  fileexists: if (fexist) then
    filecontent = io_read_ascii('debug.config') 
    do j=1, size(filecontent)
      line = filecontent(j)
      if (io_isblank(line)) cycle                                                                    ! skip empty lines
      chunkpos = io_stringpos(line)
      tag = io_lc(io_stringvalue(line,chunkpos,1))                                                   ! extract key
      select case(tag)
        case ('element','e','el')
          debug_e = io_intvalue(line,chunkpos,2)
        case ('integrationpoint','i','ip')
          debug_i = io_intvalue(line,chunkpos,2)
        case ('grain','g','gr')
          debug_g = io_intvalue(line,chunkpos,2)
      end select
 
      what = 0
      select case(tag)
        case ('debug')
          what = debug_debug
        case ('math')
          what = debug_math
        case ('fesolving', 'fe')
          what = debug_fesolving
        case ('mesh')
          what = debug_mesh
        case ('material')
          what = debug_material
        case ('lattice')
          what = debug_lattice
        case ('constitutive')
          what = debug_constitutive
        case ('crystallite')
          what = debug_crystallite
        case ('homogenization')
          what = debug_homogenization
        case ('cpfem')
          what = debug_cpfem
        case ('spectral')
          what = debug_spectral
        case ('marc')
          what = debug_marc
        case ('all')
          what = debug_maxntype + 1
        case ('other')
          what = debug_maxntype + 2
      end select
      if (what /= 0) then
        do i = 2, chunkpos(1)
          select case(io_lc(io_stringvalue(line,chunkpos,i)))
            case('basic')
              debug_level(what) = ior(debug_level(what), debug_levelbasic)
            case('extensive')
              debug_level(what) = ior(debug_level(what), debug_levelextensive)
            case('selective')
              debug_level(what) = ior(debug_level(what), debug_levelselective)
            case('restart')
              debug_level(what) = ior(debug_level(what), debug_spectralrestart)
            case('fft','fftw')
              debug_level(what) = ior(debug_level(what), debug_spectralfftw)
            case('divergence')
              debug_level(what) = ior(debug_level(what), debug_spectraldivergence)
            case('rotation')
              debug_level(what) = ior(debug_level(what), debug_spectralrotation)
            case('petsc')
              debug_level(what) = ior(debug_level(what), debug_spectralpetsc)
          end select
        enddo
       endif
    enddo
 
    do i = 1, debug_maxntype
      if (debug_level(i) == 0) &
        debug_level(i) = ior(debug_level(i), debug_level(debug_maxntype + 2))                        ! fill undefined debug types with levels specified by "other"
 
      debug_level(i) = ior(debug_level(i), debug_level(debug_maxntype + 1))                          ! fill all debug types with levels specified by "all"
    enddo
 
    if (iand(debug_level(debug_debug),debug_levelbasic) /= 0) &
      write(6,'(a,/)') ' using values from config file'
  else fileexists
    if (iand(debug_level(debug_debug),debug_levelbasic) /= 0) &
      write(6,'(a,/)') ' using standard values'
  endif fileexists
 
!--------------------------------------------------------------------------------------------------
! output switched on (debug level for debug must be extensive)
   if (iand(debug_level(debug_debug),debug_levelextensive) /= 0) then
     do i = 1, debug_maxntype
       select case(i)
         case (debug_debug)
           tag = ' Debug'
         case (debug_math)
           tag = ' Math'
         case (debug_fesolving)
           tag = ' FEsolving'
         case (debug_mesh)
           tag = ' Mesh'
         case (debug_material)
           tag = ' Material'
         case (debug_lattice)
           tag = ' Lattice'
         case (debug_constitutive)
           tag = ' Constitutive'
         case (debug_crystallite)
           tag = ' Crystallite'
         case (debug_homogenization)
           tag = ' Homogenizaiton'
         case (debug_cpfem)
           tag = ' CPFEM'
         case (debug_spectral)
           tag = ' Spectral solver'
         case (debug_marc)
           tag = ' MSC.MARC FEM solver'
       end select
 
       if(debug_level(i) /= 0) then
         write(6,'(3a)') ' debug level for ', trim(tag), ':'
         if(iand(debug_level(i),debug_levelbasic)        /= 0) write(6,'(a)') '  basic'
         if(iand(debug_level(i),debug_levelextensive)    /= 0) write(6,'(a)') '  extensive'
         if(iand(debug_level(i),debug_levelselective)    /= 0) then
           write(6,'(a)') ' selective on:'
           write(6,'(a24,1x,i8)') '  element:              ',debug_e
           write(6,'(a24,1x,i8)') '  ip:                   ',debug_i
           write(6,'(a24,1x,i8)') '  grain:                ',debug_g
         endif
         if(iand(debug_level(i),debug_spectralrestart)   /= 0) write(6,'(a)') '  restart'
         if(iand(debug_level(i),debug_spectralfftw)      /= 0) write(6,'(a)') '  FFTW'
         if(iand(debug_level(i),debug_spectraldivergence)/= 0) write(6,'(a)') '  divergence'
         if(iand(debug_level(i),debug_spectralrotation)  /= 0) write(6,'(a)') '  rotation'
         if(iand(debug_level(i),debug_spectralpetsc)     /= 0) write(6,'(a)') '  PETSc'
       endif
     enddo
   endif
 
end subroutine debug_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine debug_reset
 
  debug_stressmaxlocation   = 0
  debug_stressminlocation   = 0
  debug_jacobianmaxlocation = 0
  debug_jacobianminlocation = 0
  debug_stressmax           = -huge(1.0_preal)
  debug_stressmin           =  huge(1.0_preal)
  debug_jacobianmax         = -huge(1.0_preal)
  debug_jacobianmin         =  huge(1.0_preal)
 
end subroutine debug_reset
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine debug_info
 
  !$OMP CRITICAL (write2out)
    debugoutputcpfem: if (iand(debug_level(debug_cpfem),debug_levelbasic) /= 0 &
                       .and. any(debug_stressminlocation /= 0) &
                       .and. any(debug_stressmaxlocation /= 0) ) then
      write(6,'(2/,a,/)') ' Extreme values of returned stress and Jacobian'
      write(6,'(a39)')                      '                      value     el   ip'
      write(6,'(a14,1x,e12.3,1x,i8,1x,i4)')   ' stress   min :', debug_stressmin, debug_stressminlocation
      write(6,'(a14,1x,e12.3,1x,i8,1x,i4)')   '          max :', debug_stressmax, debug_stressmaxlocation
      write(6,'(a14,1x,e12.3,1x,i8,1x,i4)')   ' Jacobian min :', debug_jacobianmin, debug_jacobianminlocation
      write(6,'(a14,1x,e12.3,1x,i8,1x,i4,/)') '          max :', debug_jacobianmax, debug_jacobianmaxlocation
    endif debugoutputcpfem
  !$OMP END CRITICAL (write2out)
 
end subroutine debug_info
 
end module debug
# 9 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/list.f90" 1
!-------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module list
  use prec
  use io
 
  implicit none
  private 
   type, private :: tpartitionedstring
    character(len=:),      allocatable :: val
    integer, dimension(:), allocatable :: pos
  end type tpartitionedstring
  
  type, public :: tpartitionedstringlist
    type(tpartitionedstring)               :: string
    type(tpartitionedstringlist),  pointer :: next => null()
    contains
      procedure :: add            => add
      procedure :: show           => show
      procedure :: free           => free
 
 ! currently, a finalize is needed for all shapes of tPartitionedStringList.
 ! with Fortran 2015, we can define one recursive elemental function
 ! https://software.intel.com/en-us/forums/intel-visual-fortran-compiler-for-windows/topic/543326
      final     :: finalize, &
                   finalizearray 
 
      procedure :: keyexists      => keyexists
      procedure :: countkeys      => countkeys
 
      procedure :: getfloat       => getfloat
      procedure :: getint         => getint
      procedure :: getstring      => getstring
 
      procedure :: getfloats      => getfloats
      procedure :: getints        => getints
      procedure :: getstrings     => getstrings
 
  end type tpartitionedstringlist
 
contains
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine add(this,string)
 
  class(tpartitionedstringlist),  target, intent(in) :: this
  character(len=*),                       intent(in) :: string
  type(tpartitionedstringlist),   pointer            :: new, temp
 
  if (io_isblank(string)) return
 
  allocate(new)
  temp => this
  do while (associated(temp%next))
    temp => temp%next
  enddo
  temp%string%val = io_lc(trim(string))
  temp%string%pos = io_stringpos(trim(string))
  temp%next => new
 
end subroutine add
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine show(this)
 
  class(tpartitionedstringlist), target, intent(in) :: this
  type(tpartitionedstringlist),  pointer            :: item
 
  item => this
  do while (associated(item%next))
    write(6,'(a)') ' '//trim(item%string%val)
    item => item%next
  enddo
 
end subroutine show
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine free(this)
 
  class(tpartitionedstringlist),  intent(inout) :: this
 
  if(associated(this%next)) deallocate(this%next)
 
end subroutine free
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
recursive subroutine finalize(this)
 
  type(tpartitionedstringlist),  intent(inout) :: this
 
  if(associated(this%next)) deallocate(this%next)
 
end subroutine finalize
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine finalizearray(this)
 
  integer :: i
  type(tpartitionedstringlist),  intent(inout), dimension(:) :: this
  type(tpartitionedstringlist),  pointer :: temp ! bug in Gfortran?
 
  do i=1, size(this)
    if (associated(this(i)%next)) then
      temp => this(i)%next
      !deallocate(this(i)) !internal compiler error: in gfc_build_final_call, at fortran/trans.c:975
      deallocate(temp)
    endif
  enddo
 
end subroutine finalizearray
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
logical function keyexists(this,key)
 
  class(tpartitionedstringlist), target, intent(in) :: this
  character(len=*),                      intent(in) :: key
  type(tpartitionedstringlist),  pointer            :: item
 
  keyexists = .false.
 
  item => this
  do while (associated(item%next) .and. .not. keyexists)
    keyexists = trim(io_stringvalue(item%string%val,item%string%pos,1)) == trim(key)
    item => item%next
  enddo
 
end function keyexists
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
integer function countkeys(this,key)
 
  class(tpartitionedstringlist), target, intent(in) :: this
  character(len=*),                      intent(in) :: key
  type(tpartitionedstringlist),  pointer            :: item
 
  countkeys = 0
 
  item => this
  do while (associated(item%next))
    if (trim(io_stringvalue(item%string%val,item%string%pos,1)) == trim(key)) &
      countkeys = countkeys + 1
    item => item%next
  enddo
 
end function countkeys
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
real(pReal) function getfloat(this,key,defaultVal)
 
  class(tpartitionedstringlist), target, intent(in)           :: this
  character(len=*),                      intent(in)           :: key
  real(preal),                           intent(in), optional :: defaultval
  type(tpartitionedstringlist), pointer                       :: item
  logical                                                     :: found
  
  getfloat = huge(1.0)                                                                              ! suppress warning about unitialized value
  found = present(defaultval)
  if (found) getfloat = defaultval
  
  item => this
  do while (associated(item%next))
    if (trim(io_stringvalue(item%string%val,item%string%pos,1)) == trim(key)) then
      found = .true.
      if (item%string%pos(1) < 2) call io_error(143,ext_msg=key)
      getfloat = io_floatvalue(item%string%val,item%string%pos,2)
    endif
    item => item%next
  enddo
 
  if (.not. found) call io_error(140,ext_msg=key)
 
end function getfloat
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
integer function getint(this,key,defaultVal)
 
  class(tpartitionedstringlist), target, intent(in)           :: this
  character(len=*),                      intent(in)           :: key
  integer,                               intent(in), optional :: defaultval
  type(tpartitionedstringlist), pointer                       :: item
  logical                                                     :: found
 
  getint = huge(1)                                                                                  ! suppress warning about unitialized value
  found = present(defaultval)
  if (found) getint = defaultval
  
  item => this
  do while (associated(item%next))
    if (trim(io_stringvalue(item%string%val,item%string%pos,1)) == trim(key)) then
      found = .true.
      if (item%string%pos(1) < 2) call io_error(143,ext_msg=key)
      getint = io_intvalue(item%string%val,item%string%pos,2)
    endif
    item => item%next
  enddo
 
  if (.not. found) call io_error(140,ext_msg=key)
 
end function getint
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
character(len=pStringLen) function getstring(this,key,defaultVal,raw)
 
  class(tpartitionedstringlist), target, intent(in)           :: this
  character(len=*),                      intent(in)           :: key
  character(len=*),                      intent(in), optional :: defaultval
  logical,                               intent(in), optional :: raw
  type(tpartitionedstringlist),  pointer                      :: item
  logical                                                     :: found, &
                                                                 whole
  if (present(raw)) then
    whole = raw
  else
    whole = .false.
  endif
 
  found = present(defaultval)
  if (found) then
    if (len_trim(defaultval) > len(getstring)) call io_error(0,ext_msg='getString')
    getstring = trim(defaultval)
  endif
 
  item => this
  do while (associated(item%next))
    if (trim(io_stringvalue(item%string%val,item%string%pos,1)) == trim(key)) then
      found = .true.
      if (item%string%pos(1) < 2) call io_error(143,ext_msg=key)
 
      if (whole) then
        getstring = trim(item%string%val(item%string%pos(4):))                                      ! raw string starting a second chunk
      else
        getstring = io_stringvalue(item%string%val,item%string%pos,2)
      endif
    endif
    item => item%next
  enddo
 
  if (.not. found) call io_error(140,ext_msg=key)
 
end function getstring
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function getfloats(this,key,defaultVal,requiredSize)
 
  real(preal),     dimension(:), allocatable          :: getfloats
  class(tpartitionedstringlist), target, intent(in)   :: this
  character(len=*),              intent(in)           :: key
  real(preal),   dimension(:),   intent(in), optional :: defaultval
  integer,                 intent(in), optional :: requiredsize
  type(tpartitionedstringlist),  pointer              :: item
  integer                                       :: i
  logical                                             :: found, &
                                                         cumulative
 
  cumulative = (key(1:1) == '(' .and. key(len_trim(key):len_trim(key)) == ')')
  found = .false.
 
  allocate(getfloats(0))
 
  item => this
  do while (associated(item%next))
    if (trim(io_stringvalue(item%string%val,item%string%pos,1)) == trim(key)) then
      found = .true.
      if (.not. cumulative) getfloats = [real(preal)::]
      if (item%string%pos(1) < 2) call io_error(143,ext_msg=key)
      do i = 2, item%string%pos(1)
        getfloats = [getfloats,io_floatvalue(item%string%val,item%string%pos,i)]
      enddo
    endif
    item => item%next
  enddo
 
  if (.not. found) then
    if (present(defaultval)) then; getfloats = defaultval; else; call io_error(140,ext_msg=key); endif
  endif
  if (present(requiredsize)) then
    if(requiredsize /= size(getfloats)) call io_error(146,ext_msg=key)
  endif
 
end function getfloats
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function getints(this,key,defaultVal,requiredSize)
 
  integer, dimension(:), allocatable                          :: getints
  class(tpartitionedstringlist), target, intent(in)           :: this
  character(len=*),                      intent(in)           :: key
  integer, dimension(:),                 intent(in), optional :: defaultval
  integer,                               intent(in), optional :: requiredsize
  type(tpartitionedstringlist),  pointer                      :: item
  integer                                                     :: i
  logical                                                     :: found, &
                                                                 cumulative
 
  cumulative = (key(1:1) == '(' .and. key(len_trim(key):len_trim(key)) == ')')
  found = .false.
 
  allocate(getints(0))
 
  item => this
  do while (associated(item%next))
    if (trim(io_stringvalue(item%string%val,item%string%pos,1)) == trim(key)) then
      found = .true.
      if (.not. cumulative) getints = [integer::]
      if (item%string%pos(1) < 2) call io_error(143,ext_msg=key)
      do i = 2, item%string%pos(1)
        getints = [getints,io_intvalue(item%string%val,item%string%pos,i)]
      enddo
    endif
    item => item%next
  enddo
 
  if (.not. found) then
    if (present(defaultval)) then; getints = defaultval; else; call io_error(140,ext_msg=key); endif
  endif
  if (present(requiredsize)) then
    if(requiredsize /= size(getints)) call io_error(146,ext_msg=key)
  endif
 
end function getints
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function getstrings(this,key,defaultVal,raw)
 
  character(len=pStringLen),dimension(:), allocatable        :: getstrings
  class(tpartitionedstringlist),target, intent(in)           :: this
  character(len=*),                     intent(in)           :: key
  character(len=*),    dimension(:),    intent(in), optional :: defaultval
  logical,                              intent(in), optional :: raw
  type(tpartitionedstringlist), pointer                      :: item
  character(len=pStringLen)                                  :: str
  integer                                                    :: i
  logical                                                    :: found, &
                                                                whole, &
                                                                cumulative
 
  cumulative = (key(1:1) == '(' .and. key(len_trim(key):len_trim(key)) == ')')
  if (present(raw)) then
    whole = raw
  else
    whole = .false.
  endif
  found = .false.
 
  item => this
  do while (associated(item%next))
    if (trim(io_stringvalue(item%string%val,item%string%pos,1)) == trim(key)) then
      found = .true.
      if (allocated(getstrings) .and. .not. cumulative) deallocate(getstrings)
      if (item%string%pos(1) < 2) call io_error(143,ext_msg=key)
      
      notallocated: if (.not. allocated(getstrings)) then
        if (whole) then
          str = item%string%val(item%string%pos(4):)
          getstrings = [str]
        else
          str = io_stringvalue(item%string%val,item%string%pos,2)
          allocate(getstrings(1),source=str)
          do i=3,item%string%pos(1)
            str = io_stringvalue(item%string%val,item%string%pos,i)
            getstrings = [getstrings,str]
          enddo
        endif
      else notallocated
        if (whole) then
          str = item%string%val(item%string%pos(4):)
          getstrings = [getstrings,str]
        else
          do i=2,item%string%pos(1)
            str = io_stringvalue(item%string%val,item%string%pos,i)
            getstrings = [getstrings,str]
          enddo
        endif
      endif notallocated
    endif
    item => item%next
  enddo
 
  if (.not. found) then
    if (present(defaultval)) then
      if (len(defaultval) > len(getstrings)) call io_error(0,ext_msg='getStrings')
      getstrings = defaultval
    else
      call io_error(140,ext_msg=key)
    endif
  endif
 
end function getstrings
 
 
end module list
# 10 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/future.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module future
  use prec
 
  implicit none
  public
 
contains
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function findloc(a,v)
 
  integer, intent(in), dimension(:) :: a
  integer, intent(in) :: v
  integer :: i,j
  integer, allocatable, dimension(:) ::  findloc
 
  allocate(findloc(count(a==v)))
  j = 1
  do i = 1, size(a)
    if (a(i)==v) then
      findloc(j) = i
      j = j + 1
    endif
  enddo
end function findloc
 
 
end module future
# 11 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/config.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module config
  use prec
  use damask_interface
  use io
  use debug
  use list
 
  implicit none
  private
 
  type(tpartitionedstringlist), public, protected, allocatable, dimension(:) :: &
    config_phase, &
    config_microstructure, &
    config_homogenization, &
    config_texture, &
    config_crystallite
   
  type(tpartitionedstringlist), public, protected :: &
    config_numerics, &
    config_debug
 
  character(len=pStringLen),    public, protected, allocatable, dimension(:) :: &
    config_name_phase, &                                                                            !< name of each phase
    config_name_homogenization, &                                                                   !< name of each homogenization
    config_name_crystallite, &                                                                      !< name of each crystallite setting
    config_name_microstructure, &                                                                   !< name of each microstructure
    config_name_texture
 
  public :: &
    config_init, &
    config_deallocate
 
contains
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine config_init
 
  integer :: i
  logical :: verbose
 
  character(len=pStringLen) :: &
    line, &
    part
  character(len=pStringLen), dimension(:), allocatable :: filecontent
  logical :: fileexists
 
  write(6,'(/,a)') ' <<<+-  config init  -+>>>'; flush(6)
 
  verbose = iand(debug_level(debug_material),debug_levelbasic) /= 0
 
  inquire(file=trim(getsolverjobname())//'.materialConfig',exist=fileexists)
  if(fileexists) then
    write(6,'(/,a)') ' reading '//trim(getsolverjobname())//'.materialConfig'; flush(6)
    filecontent = read_materialconfig(trim(getsolverjobname())//'.materialConfig')
  else
    inquire(file='material.config',exist=fileexists)
    if(.not. fileexists) call io_error(100,ext_msg='material.config')
    write(6,'(/,a)') ' reading material.config'; flush(6)
    filecontent = read_materialconfig('material.config')
  endif
 
  do i = 1, size(filecontent)
    line = trim(filecontent(i))
    part = io_lc(io_gettag(line,'<','>'))
    select case (trim(part))
    
      case (trim('phase'))
        call parse_materialconfig(config_name_phase,config_phase,line,filecontent(i+1:))
        if (verbose) write(6,'(a)') ' Phase          parsed'; flush(6)
    
      case (trim('microstructure'))
        call parse_materialconfig(config_name_microstructure,config_microstructure,line,filecontent(i+1:))
        if (verbose) write(6,'(a)') ' Microstructure parsed'; flush(6)
    
      case (trim('crystallite'))
        call parse_materialconfig(config_name_crystallite,config_crystallite,line,filecontent(i+1:))
        if (verbose) write(6,'(a)') ' Crystallite    parsed'; flush(6)
        deallocate(config_crystallite)
    
      case (trim('homogenization'))
        call parse_materialconfig(config_name_homogenization,config_homogenization,line,filecontent(i+1:))
        if (verbose) write(6,'(a)') ' Homogenization parsed'; flush(6)
    
      case (trim('texture'))
        call parse_materialconfig(config_name_texture,config_texture,line,filecontent(i+1:))
        if (verbose) write(6,'(a)') ' Texture        parsed'; flush(6)
 
    end select
 
  enddo
 
  if (.not. allocated(config_homogenization) .or. size(config_homogenization) < 1) &
    call io_error(160,ext_msg='<homogenization>')
  if (.not. allocated(config_microstructure) .or. size(config_microstructure) < 1) &
    call io_error(160,ext_msg='<microstructure>')
  if (.not. allocated(config_phase)          .or. size(config_phase)          < 1) &
    call io_error(160,ext_msg='<phase>')
  if (.not. allocated(config_texture)        .or. size(config_texture)        < 1) &
    call io_error(160,ext_msg='<texture>')
 
 
  inquire(file='numerics.config', exist=fileexists)
  if (fileexists) then
    write(6,'(/,a)') ' reading numerics.config'; flush(6)
    filecontent = io_read_ascii('numerics.config')
    call parse_debugandnumericsconfig(config_numerics,filecontent)
  endif
  
  inquire(file='debug.config', exist=fileexists)
  if (fileexists) then
    write(6,'(/,a)') ' reading debug.config'; flush(6)
    filecontent = io_read_ascii('debug.config')
    call parse_debugandnumericsconfig(config_debug,filecontent)
  endif
 
contains
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
recursive function read_materialconfig(fileName,cnt) result(fileContent)
 
  character(len=*),          intent(in)                :: filename
  integer,                   intent(in), optional      :: cnt
  character(len=pStringLen), dimension(:), allocatable :: filecontent
  character(len=pStringLen), dimension(:), allocatable :: includedcontent
  character(len=pStringLen)                            :: line
  character(len=pStringLen), parameter                 :: dummy = 'https://damask2.mpie.de'
  character(len=:),                        allocatable :: rawdata
  integer ::  &
    filelength, &
    fileunit, &
    startpos, endpos, &
    mytotallines, &                                                                                 !< # lines read from file without include statements
    l,i, &
    mystat
  logical :: warned
  
  if (present(cnt)) then
    if (cnt>10) call io_error(106,ext_msg=trim(filename))
  endif
 
!--------------------------------------------------------------------------------------------------
! 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 and handle includes
  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
 
    recursion: if (scan(trim(adjustl(line)),'{') == 1 .and. scan(trim(line),'}') > 2) then
      includedcontent = read_materialconfig(trim(line(scan(line,'{')+1:scan(line,'}')-1)), &
                        merge(cnt,1,present(cnt)))                                                  ! to track recursion depth
      filecontent     = [ filecontent(1:l-1), includedcontent, [(dummy,i=1,mytotallines-l)] ]       ! add content and grow array
      mytotallines    = mytotallines - 1 + size(includedcontent)
      l               = l            - 1 + size(includedcontent)
    else recursion
      filecontent(l) = line
      l = l + 1
    endif recursion
 
  enddo
 
end function read_materialconfig
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine parse_materialconfig(sectionNames,part,line, &
                                fileContent)
 
  character(len=pStringLen),    allocatable, dimension(:), intent(out)   :: sectionNames
  type(tpartitionedstringlist), allocatable, dimension(:), intent(inout) :: part
  character(len=pStringLen),                               intent(inout) :: line
  character(len=pStringLen),                 dimension(:), intent(in)    :: fileContent
 
  integer, allocatable, dimension(:) :: partPosition
  integer :: i, j
  logical :: echo
  character(len=pStringLen) :: sectionName
 
  echo = .false. 
 
  if (allocated(part)) call io_error(161,ext_msg=trim(line))
  allocate(partposition(0))
 
  do i = 1, size(filecontent)
    line = trim(filecontent(i))
    if (io_gettag(line,'<','>') /= '') exit
    nextsection: if (io_gettag(line,'[',']') /= '') then
      partposition = [partposition, i]
      cycle
    endif nextsection
    if (size(partposition) < 1) &
      echo = (trim(io_gettag(line,'/','/')) == 'echo') .or. echo
  enddo
 
  allocate(sectionnames(size(partposition)))
  allocate(part(size(partposition)))
 
  partposition = [partposition, i]                                                                  ! needed when actually storing content
 
  do i = 1, size(partposition) -1
    write(sectionname,'(i0,a,a)') i,'_',trim(io_gettag(filecontent(partposition(i)),'[',']'))
    sectionnames(i) = sectionname
    do j = partposition(i) + 1,  partposition(i+1) -1
      call part(i)%add(trim(adjustl(filecontent(j))))
    enddo
    if (echo) then
      write(6,*) 'section',i, '"'//trim(sectionnames(i))//'"'
      call part(i)%show()
    endif
  enddo
 
end subroutine parse_materialconfig
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine parse_debugandnumericsconfig(config_list, &
                                        fileContent)
 
  type(tpartitionedstringlist),              intent(out) :: config_list
  character(len=pStringLen),   dimension(:), intent(in)  :: fileContent
  integer :: i
 
  do i = 1, size(filecontent)
    call config_list%add(trim(adjustl(filecontent(i))))
  enddo
 
end subroutine parse_debugandnumericsconfig
 
end subroutine config_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine config_deallocate(what)
 
  character(len=*), intent(in) :: what
 
  select case(trim(what))
 
    case('material.config/phase')
      deallocate(config_phase)
 
    case('material.config/microstructure')
      deallocate(config_microstructure)
 
    case('material.config/homogenization')
      deallocate(config_homogenization)
 
    case('material.config/texture')
      deallocate(config_texture)
     
    case('debug.config')
      call config_debug%free
     
    case('numerics.config')
      call config_numerics%free
     
    case default
      call io_error(0,ext_msg='config_deallocate')
 
  end select
 
end subroutine config_deallocate
 
end module config
# 12 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/math.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module math
  use prec
  use io
  use numerics
 
  implicit none
  public
 
 
 
 
 
 
 
 
  real(preal),    parameter :: pi = acos(-1.0_preal)                                                
  real(preal),    parameter :: indeg = 180.0_preal/pi                                               
  real(preal),    parameter :: inrad = pi/180.0_preal                                               
  complex(pReal), parameter :: twopiimg = cmplx(0.0_preal,2.0_preal*pi)                             
 
  real(preal), dimension(3,3), parameter :: &
    math_i3 = reshape([&
      1.0_preal,0.0_preal,0.0_preal, &
      0.0_preal,1.0_preal,0.0_preal, &
      0.0_preal,0.0_preal,1.0_preal  &
      ],[3,3])                                                                                      
 
  real(preal), dimension(6), parameter, private :: &
    nrmmandel = [&
      1.0_preal,       1.0_preal,       1.0_preal, &
      sqrt(2.0_preal), sqrt(2.0_preal), sqrt(2.0_preal) ]                                           
 
  real(preal), dimension(6), parameter, private :: &
    invnrmmandel = 1.0_preal/nrmmandel                                                              
 
  integer, dimension (2,6), parameter, private :: &
    mapnye = reshape([&
      1,1, &
      2,2, &
      3,3, &
      1,2, &
      2,3, &
      1,3  &
      ],[2,6])                                                                                      
 
  integer, dimension (2,6), parameter, private :: &
    mapvoigt = reshape([&
      1,1, &
      2,2, &
      3,3, &
      2,3, &
      1,3, &
      1,2  &
      ],[2,6])                                                                                      
 
  integer, dimension (2,9), parameter, private :: &
    mapplain = reshape([&
      1,1, &
      1,2, &
      1,3, &
      2,1, &
      2,2, &
      2,3, &
      3,1, &
      3,2, &
      3,3  &
      ],[2,9])                                                                                      
 
  interface math_eye
    module procedure math_identity2nd
  end interface math_eye
 
 
!---------------------------------------------------------------------------------------------------
 private :: &
   unittest
 
contains
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine math_init
 
  real(pReal), dimension(4) :: randTest
  integer :: randSize
  integer, dimension(:), allocatable :: randInit
 
  write(6,'(/,a)') ' <<<+-  math init  -+>>>'; flush(6)
 
  call random_seed(size=randsize)
  allocate(randinit(randsize))
  if (randomseed > 0) then
    randinit = randomseed
  else
    call random_seed()
    call random_seed(get = randinit)
    randinit(2:randsize) = randinit(1)
  endif
 
  call random_seed(put = randinit)
  call random_number(randtest)
 
  write(6,'(a,i2)')                ' size  of random seed:     ', randsize
  write(6,'(a,i0)')                ' value of random seed:     ', randinit(1)
  write(6,'(a,4(/,26x,f17.14),/)') ' start of random sequence: ', randtest
 
  call random_seed(put = randinit)
 
  call unittest
 
end subroutine math_init
 
 
!--------------------------------------------------------------------------------------------------
! Sorting is done with respect to array(sort,:) and keeps array(/=sort,:) linked to it.
! default: sort=1
!--------------------------------------------------------------------------------------------------
recursive subroutine math_sort(a, istart, iend, sortDim)
 
  integer, dimension(:,:), intent(inout) :: a
  integer, intent(in),optional :: istart,iend, sortdim
  integer :: ipivot,s,e,d
 
  if(present(istart)) then
    s = istart
  else
    s = lbound(a,2)
  endif
 
  if(present(iend)) then
    e = iend
  else
    e = ubound(a,2)
  endif
 
  if(present(sortdim)) then
    d = sortdim
  else
    d = 1
  endif
 
  if (s < e) then
    ipivot = qsort_partition(a,s, e, d)
    call math_sort(a, s, ipivot-1, d)
    call math_sort(a, ipivot+1, e, d)
  endif
 
 
  contains
 
  !-------------------------------------------------------------------------------------------------
  !-------------------------------------------------------------------------------------------------
  integer function qsort_partition(a, istart, iend, sort)
 
    integer, dimension(:,:), intent(inout) :: a
    integer,                 intent(in)    :: istart,iend,sort
    integer, dimension(size(a,1))          :: tmp
    integer :: i,j
 
    do
      ! find the first element on the right side less than or equal to the pivot point
      do j = iend, istart, -1
        if (a(sort,j) <= a(sort,istart)) exit
      enddo
      ! find the first element on the left side greater than the pivot point
      do i = istart, iend
        if (a(sort,i) > a(sort,istart)) exit
      enddo
      cross: if (i >= j) then ! exchange left value with pivot and return with the partition index
        tmp         = a(:,istart)
        a(:,istart) = a(:,j)
        a(:,j)      = tmp
        qsort_partition = j
        return
      else cross              ! exchange values
        tmp    = a(:,i)
        a(:,i) = a(:,j)
        a(:,j) = tmp
      endif cross
    enddo
 
  end function qsort_partition
 
end subroutine math_sort
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function math_expand(what,how)
 
  real(preal),   dimension(:), intent(in) :: what
  integer,       dimension(:), intent(in) :: how
  real(preal), dimension(sum(how)) ::  math_expand
  integer :: i
 
  if (sum(how) == 0) return
 
  do i = 1, size(how)
    math_expand(sum(how(1:i-1))+1:sum(how(1:i))) = what(mod(i-1,size(what))+1)
  enddo
 
end function math_expand
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function math_range(N)
 
  integer, intent(in) :: n
  integer :: i
  integer, dimension(N) :: math_range
 
  math_range = [(i,i=1,n)]
 
end function math_range
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function math_identity2nd(d)
 
  integer, intent(in) :: d
  integer :: i
  real(preal), dimension(d,d) :: math_identity2nd
 
  math_identity2nd = 0.0_preal
  do i=1,d
    math_identity2nd(i,i) = 1.0_preal
  enddo
 
end function math_identity2nd
 
 
!--------------------------------------------------------------------------------------------------
!  from http://en.wikipedia.org/wiki/Tensor_derivative_(continuum_mechanics)#Derivative_of_a_second-order_tensor_with_respect_to_itself
!--------------------------------------------------------------------------------------------------
pure function math_identity4th(d)
 
  integer, intent(in) :: d
  integer :: i,j,k,l
  real(preal), dimension(d,d,d,d) :: math_identity4th
  real(preal), dimension(d,d)     :: identity2nd
 
  identity2nd = math_identity2nd(d)
  do i=1,d; do j=1,d; do k=1,d; do l=1,d
    math_identity4th(i,j,k,l) = 0.5_preal &
                              *(identity2nd(i,k)*identity2nd(j,l)+identity2nd(i,l)*identity2nd(j,k))
  enddo; enddo; enddo; enddo
 
end function math_identity4th
 
 
!--------------------------------------------------------------------------------------------------
! e_ijk =  1 if even permutation of ijk
! e_ijk = -1 if odd permutation of ijk
! e_ijk =  0 otherwise
!--------------------------------------------------------------------------------------------------
real(preal) pure function math_levicivita(i,j,k)
 
  integer, intent(in) :: i,j,k
 
  if     (all([i,j,k] == [1,2,3]) .or. all([i,j,k] == [2,3,1]) .or. all([i,j,k] == [3,1,2])) then
    math_levicivita = +1.0_preal
  elseif (all([i,j,k] == [3,2,1]) .or. all([i,j,k] == [2,1,3]) .or. all([i,j,k] == [1,3,2])) then
    math_levicivita = -1.0_preal
  else
    math_levicivita =  0.0_preal
  endif
 
end function math_levicivita
 
 
!--------------------------------------------------------------------------------------------------
! d_ij = 1 if i = j
! d_ij = 0 otherwise
!--------------------------------------------------------------------------------------------------
real(preal) pure function math_delta(i,j)
 
  integer, intent (in) :: i,j
 
  math_delta = merge(0.0_preal, 1.0_preal, i /= j)
 
end function math_delta
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function math_cross(A,B)
 
  real(preal), dimension(3), intent(in) ::  a,b
  real(preal), dimension(3) :: math_cross
 
  math_cross = [ a(2)*b(3) -a(3)*b(2), &
                 a(3)*b(1) -a(1)*b(3), &
                 a(1)*b(2) -a(2)*b(1) ]
 
end function math_cross
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function math_outer(A,B)
 
  real(preal), dimension(:), intent(in) ::  a,b
  real(preal), dimension(size(A,1),size(B,1)) ::  math_outer
  integer :: i,j
 
  do i=1,size(a,1); do j=1,size(b,1)
    math_outer(i,j) = a(i)*b(j)
  enddo; enddo
 
end function math_outer
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
real(preal) pure function math_inner(a,b)
 
  real(preal), dimension(:),         intent(in) :: a
  real(preal), dimension(size(A,1)), intent(in) :: b
 
  math_inner = sum(a*b)
 
end function math_inner
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
real(preal) pure function math_tensordot(a,b)
 
  real(preal), dimension(3,3), intent(in) :: a,b
 
  math_tensordot = sum(a*b)
 
end function math_tensordot
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function math_mul3333xx33(A,B)
 
  real(preal), dimension(3,3,3,3), intent(in) :: a
  real(preal), dimension(3,3),     intent(in) :: b
  real(preal), dimension(3,3) :: math_mul3333xx33
  integer :: i,j
 
  do i=1,3; do j=1,3
    math_mul3333xx33(i,j) = sum(a(i,j,1:3,1:3)*b(1:3,1:3))
  enddo; enddo
 
end function math_mul3333xx33
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function math_mul3333xx3333(A,B)
 
  integer :: i,j,k,l
  real(preal), dimension(3,3,3,3), intent(in) :: a
  real(preal), dimension(3,3,3,3), intent(in) :: b
  real(preal), dimension(3,3,3,3) :: math_mul3333xx3333
 
  do i=1,3; do j=1,3; do k=1,3; do l=1,3
    math_mul3333xx3333(i,j,k,l) = sum(a(i,j,1:3,1:3)*b(1:3,1:3,k,l))
  enddo; enddo; enddo; enddo
 
end function math_mul3333xx3333
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function math_exp33(A,n)
 
  real(preal), dimension(3,3), intent(in) :: a
  integer,                     intent(in), optional :: n
  real(preal), dimension(3,3) :: b, math_exp33
 
  real(preal) :: invfac
  integer     :: n_,i
 
  if (present(n)) then
    n_ = n
  else
    n_ = 5
  endif
 
  invfac     = 1.0_preal                                                                            ! 0!
  b          = math_i3
  math_exp33 = math_i3                                                                              ! A^0 = I
 
  do i = 1, n_
    invfac = invfac/real(i,preal)                                                                   ! invfac = 1/(i!)
    b = matmul(b,a)
    math_exp33 = math_exp33 + invfac*b                                                              ! exp = SUM (A^i)/(i!)
  enddo
 
end function math_exp33
 
 
!--------------------------------------------------------------------------------------------------
! if determinant is close to zero
!--------------------------------------------------------------------------------------------------
pure function math_inv33(A)
 
  real(preal), dimension(3,3), intent(in) :: a
  real(preal), dimension(3,3) :: math_inv33
 
  real(preal) :: deta
  logical     :: error
 
  call math_invert33(math_inv33,deta,error,a)
  if(error) math_inv33 = 0.0_preal
 
end function math_inv33
 
 
!--------------------------------------------------------------------------------------------------
!  Returns an error if not possible, i.e. if determinant is close to zero
!--------------------------------------------------------------------------------------------------
pure subroutine math_invert33(InvA, DetA, error, A)
 
  real(preal), dimension(3,3), intent(out) :: inva
  real(preal),                 intent(out) :: deta
  logical,                     intent(out) :: error
  real(preal), dimension(3,3), intent(in)  :: a
 
  inva(1,1) =  a(2,2) * a(3,3) - a(2,3) * a(3,2)
  inva(2,1) = -a(2,1) * a(3,3) + a(2,3) * a(3,1)
  inva(3,1) =  a(2,1) * a(3,2) - a(2,2) * a(3,1)
 
  deta = a(1,1) * inva(1,1) + a(1,2) * inva(2,1) + a(1,3) * inva(3,1)
 
  if (deq0(deta)) then
    inva = 0.0_preal
    error = .true.
  else
    inva(1,2) = -a(1,2) * a(3,3) + a(1,3) * a(3,2)
    inva(2,2) =  a(1,1) * a(3,3) - a(1,3) * a(3,1)
    inva(3,2) = -a(1,1) * a(3,2) + a(1,2) * a(3,1)
 
    inva(1,3) =  a(1,2) * a(2,3) - a(1,3) * a(2,2)
    inva(2,3) = -a(1,1) * a(2,3) + a(1,3) * a(2,1)
    inva(3,3) =  a(1,1) * a(2,2) - a(1,2) * a(2,1)
 
    inva = inva/deta
    error = .false.
  endif
 
end subroutine math_invert33
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function math_invsym3333(A)
 
  real(preal),dimension(3,3,3,3)            :: math_invsym3333
 
  real(preal),dimension(3,3,3,3),intent(in) :: a
 
  integer :: ierr
  integer,     dimension(6)        :: ipiv6
  real(preal), dimension(6,6)      :: temp66
  real(preal), dimension(6*(64+2)) :: work
  logical                          :: error
  external :: &
    dgetrf, &
    dgetri
 
  temp66 = math_sym3333to66(a)
  call dgetrf(6,6,temp66,6,ipiv6,ierr)
  error = (ierr /= 0)
  call dgetri(6,temp66,6,ipiv6,work,size(work,1),ierr)
  error = error .or. (ierr /= 0)
  if (error) then
    call io_error(400, ext_msg = 'math_invSym3333')
  else
    math_invsym3333 = math_66tosym3333(temp66)
  endif
 
end function math_invsym3333
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine math_invert(InvA, error, A)
 
  real(pReal), dimension(:,:),                 intent(in)  :: A
  real(pReal), dimension(size(A,1),size(A,1)), intent(out) :: invA
  logical,                                     intent(out) :: error
 
  integer,     dimension(size(A,1))        :: ipiv
  real(pReal), dimension(size(A,1)*(64+2)) :: work
  integer                                  :: ierr
  external :: &
    dgetrf, &
    dgetri
 
  inva = a
  call dgetrf(size(a,1),size(a,1),inva,size(a,1),ipiv,ierr)
  error = (ierr /= 0)
  call dgetri(size(a,1),inva,size(a,1),ipiv,work,size(work,1),ierr)
  error = error .or. (ierr /= 0)
 
end subroutine math_invert
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function math_symmetric33(m)
 
  real(preal), dimension(3,3) :: math_symmetric33
  real(preal), dimension(3,3), intent(in) :: m
 
  math_symmetric33 = 0.5_preal * (m + transpose(m))
 
end function math_symmetric33
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function math_symmetric66(m)
 
  real(preal), dimension(6,6) :: math_symmetric66
  real(preal), dimension(6,6), intent(in) :: m
 
  math_symmetric66 = 0.5_preal * (m + transpose(m))
 
end function math_symmetric66
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function math_skew33(m)
 
  real(preal), dimension(3,3) :: math_skew33
  real(preal), dimension(3,3), intent(in) :: m
 
  math_skew33 = m - math_symmetric33(m)
 
end function math_skew33
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function math_spherical33(m)
 
  real(preal), dimension(3,3) :: math_spherical33
  real(preal), dimension(3,3), intent(in) :: m
 
  math_spherical33 = math_i3 * math_trace33(m)/3.0_preal
 
end function math_spherical33
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function math_deviatoric33(m)
 
  real(preal), dimension(3,3) :: math_deviatoric33
  real(preal), dimension(3,3), intent(in) :: m
 
  math_deviatoric33 = m - math_spherical33(m)
 
end function math_deviatoric33
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
real(preal) pure function math_trace33(m)
 
  real(preal), dimension(3,3), intent(in) :: m
 
  math_trace33 = m(1,1) + m(2,2) + m(3,3)
 
end function math_trace33
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
real(preal) pure function math_det33(m)
 
  real(preal), dimension(3,3), intent(in) :: m
 
  math_det33 = m(1,1)* (m(2,2)*m(3,3)-m(2,3)*m(3,2)) &
             - m(1,2)* (m(2,1)*m(3,3)-m(2,3)*m(3,1)) &
             + m(1,3)* (m(2,1)*m(3,2)-m(2,2)*m(3,1))
 
end function math_det33
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
real(preal) pure function math_detsym33(m)
 
  real(preal), dimension(3,3), intent(in) :: m
 
  math_detsym33 = -(m(1,1)*m(2,3)**2 + m(2,2)*m(1,3)**2 + m(3,3)*m(1,2)**2) &
                  + m(1,1)*m(2,2)*m(3,3) + 2.0_preal * m(1,2)*m(1,3)*m(2,3)
 
end function  math_detsym33
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function math_33to9(m33)
 
  real(preal), dimension(9)               :: math_33to9
  real(preal), dimension(3,3), intent(in) :: m33
 
  integer :: i
 
  do i = 1, 9
    math_33to9(i) = m33(mapplain(1,i),mapplain(2,i))
  enddo
 
end function math_33to9
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function math_9to33(v9)
 
  real(preal), dimension(3,3)           :: math_9to33
  real(preal), dimension(9), intent(in) :: v9
 
  integer :: i
 
  do i = 1, 9
    math_9to33(mapplain(1,i),mapplain(2,i)) = v9(i)
  enddo
 
end function math_9to33
 
 
!--------------------------------------------------------------------------------------------------
! components according to Mandel. Advisable for matrix operations.
! Unweighted conversion only changes order according to Nye
!--------------------------------------------------------------------------------------------------
pure function math_sym33to6(m33,weighted)
 
  real(preal), dimension(6)               :: math_sym33to6
  real(preal), dimension(3,3), intent(in) :: m33
  logical,     optional,       intent(in) :: weighted
 
  real(preal), dimension(6) :: w
  integer :: i
 
  if(present(weighted)) then
    w = merge(nrmmandel,1.0_preal,weighted)
  else
    w = nrmmandel
  endif
 
  do i = 1, 6
    math_sym33to6(i) = w(i)*m33(mapnye(1,i),mapnye(2,i))
  enddo
 
end function math_sym33to6
 
 
!--------------------------------------------------------------------------------------------------
! components according to Mandel. Advisable for matrix operations.
! Unweighted conversion only changes order according to Nye
!--------------------------------------------------------------------------------------------------
pure function math_6tosym33(v6,weighted)
 
  real(preal), dimension(3,3)           :: math_6tosym33
  real(preal), dimension(6), intent(in) :: v6
  logical,     optional,     intent(in) :: weighted
 
  real(preal), dimension(6) :: w
  integer :: i
 
  if(present(weighted)) then
    w = merge(invnrmmandel,1.0_preal,weighted)
  else
    w = invnrmmandel
  endif
 
  do i=1,6
    math_6tosym33(mapnye(1,i),mapnye(2,i)) = w(i)*v6(i)
    math_6tosym33(mapnye(2,i),mapnye(1,i)) = w(i)*v6(i)
  enddo
 
end function math_6tosym33
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function math_3333to99(m3333)
 
  real(preal), dimension(9,9)                 :: math_3333to99
  real(preal), dimension(3,3,3,3), intent(in) :: m3333
 
  integer :: i,j
 
  do i=1,9; do j=1,9
    math_3333to99(i,j) = m3333(mapplain(1,i),mapplain(2,i),mapplain(1,j),mapplain(2,j))
  enddo; enddo
 
end function math_3333to99
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function math_99to3333(m99)
 
  real(preal), dimension(3,3,3,3)         :: math_99to3333
  real(preal), dimension(9,9), intent(in) :: m99
 
  integer :: i,j
 
  do i=1,9; do j=1,9
    math_99to3333(mapplain(1,i),mapplain(2,i),mapplain(1,j),mapplain(2,j)) = m99(i,j)
  enddo; enddo
 
end function math_99to3333
 
 
!--------------------------------------------------------------------------------------------------
! components according to Mandel. Advisable for matrix operations.
! Unweighted conversion only rearranges order according to Nye
!--------------------------------------------------------------------------------------------------
pure function math_sym3333to66(m3333,weighted)
 
  real(preal), dimension(6,6)                 :: math_sym3333to66
  real(preal), dimension(3,3,3,3), intent(in) :: m3333
  logical,     optional,           intent(in) :: weighted
 
  real(preal), dimension(6) :: w
  integer :: i,j
 
  if(present(weighted)) then
    w = merge(nrmmandel,1.0_preal,weighted)
  else
    w = nrmmandel
  endif
 
  do i=1,6; do j=1,6
    math_sym3333to66(i,j) = w(i)*w(j)*m3333(mapnye(1,i),mapnye(2,i),mapnye(1,j),mapnye(2,j))
  enddo; enddo
 
end function math_sym3333to66
 
 
!--------------------------------------------------------------------------------------------------
! components according to Mandel. Advisable for matrix operations.
! Unweighted conversion only rearranges order according to Nye
!--------------------------------------------------------------------------------------------------
pure function math_66tosym3333(m66,weighted)
 
  real(preal), dimension(3,3,3,3)            :: math_66tosym3333
  real(preal), dimension(6,6),    intent(in) :: m66
  logical,     optional,          intent(in) :: weighted
 
  real(preal), dimension(6) :: w
  integer :: i,j
 
  if(present(weighted)) then
    w = merge(invnrmmandel,1.0_preal,weighted)
  else
    w = invnrmmandel
  endif
 
  do i=1,6; do j=1,6
    math_66tosym3333(mapnye(1,i),mapnye(2,i),mapnye(1,j),mapnye(2,j)) = w(i)*w(j)*m66(i,j)
    math_66tosym3333(mapnye(2,i),mapnye(1,i),mapnye(1,j),mapnye(2,j)) = w(i)*w(j)*m66(i,j)
    math_66tosym3333(mapnye(1,i),mapnye(2,i),mapnye(2,j),mapnye(1,j)) = w(i)*w(j)*m66(i,j)
    math_66tosym3333(mapnye(2,i),mapnye(1,i),mapnye(2,j),mapnye(1,j)) = w(i)*w(j)*m66(i,j)
  enddo; enddo
 
end function math_66tosym3333
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function math_voigt66to3333(m66)
 
  real(preal), dimension(3,3,3,3) :: math_voigt66to3333
  real(preal), dimension(6,6), intent(in) :: m66
  integer :: i,j
 
  do i=1,6; do j=1, 6
    math_voigt66to3333(mapvoigt(1,i),mapvoigt(2,i),mapvoigt(1,j),mapvoigt(2,j)) = m66(i,j)
    math_voigt66to3333(mapvoigt(2,i),mapvoigt(1,i),mapvoigt(1,j),mapvoigt(2,j)) = m66(i,j)
    math_voigt66to3333(mapvoigt(1,i),mapvoigt(2,i),mapvoigt(2,j),mapvoigt(1,j)) = m66(i,j)
    math_voigt66to3333(mapvoigt(2,i),mapvoigt(1,i),mapvoigt(2,j),mapvoigt(1,j)) = m66(i,j)
  enddo; enddo
 
end function math_voigt66to3333
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
real(pReal) function math_samplegaussvar(meanvalue, stddev, width)
 
  real(preal), intent(in) ::            meanvalue, &                                                !< meanvalue of gauss distribution
                                        stddev
  real(preal), intent(in), optional ::  width
 
  real(preal), dimension(2) ::          rnd                                                         ! random numbers
  real(preal) ::                        scatter, &                                                  ! normalized scatter around meanvalue
                                        width_
 
  if (abs(stddev) < tol_math_check) then
    math_samplegaussvar = meanvalue
  else
    if (present(width)) then
      width_ = width
    else
      width_ = 3.0_preal                                                                            ! use +-3*sigma as default scatter
    endif
 
    do
      call random_number(rnd)
      scatter = width_ * (2.0_preal * rnd(1) - 1.0_preal)
      if (rnd(2) <= exp(-0.5_preal * scatter ** 2.0_preal)) exit                                    ! test if scattered value is drawn
    enddo
 
    math_samplegaussvar = scatter * stddev
  endif
 
end function math_samplegaussvar
 
 
!--------------------------------------------------------------------------------------------------
! ToDo: has wrong oder of arguments
!--------------------------------------------------------------------------------------------------
subroutine math_eigh(m,w,v,error)
 
  real(pReal), dimension(:,:),                  intent(in)  :: m
  real(pReal), dimension(size(m,1)),            intent(out) :: w
  real(pReal), dimension(size(m,1),size(m,1)),  intent(out) :: v
 
  logical, intent(out) :: error
  integer :: ierr
  real(pReal), dimension((64+2)*size(m,1)) :: work                                                  ! block size of 64 taken from http://www.netlib.org/lapack/double/dsyev.f
  external :: &
    dsyev
 
  v = m                                                                                             ! copy matrix to input (doubles as output) array
  call dsyev('V','U',size(m,1),v,size(m,1),w,work,size(work,1),ierr)
  error = (ierr /= 0)
 
end subroutine math_eigh
 
 
!--------------------------------------------------------------------------------------------------
! ToDo: has wrong oder of arguments
!--------------------------------------------------------------------------------------------------
subroutine math_eigh33(m,w,v)
 
  real(pReal), dimension(3,3),intent(in)  :: m
  real(pReal), dimension(3),  intent(out) :: w
  real(pReal), dimension(3,3),intent(out) :: v
 
  real(pReal) :: T, U, norm, threshold
  logical :: error
 
  w = math_eigvalsh33(m)
 
  v(1:3,2) = [ m(1, 2) * m(2, 3) - m(1, 3) * m(2, 2), &
               m(1, 3) * m(1, 2) - m(2, 3) * m(1, 1), &
               m(1, 2)**2]
 
  t = maxval(abs(w))
  u = max(t, t**2)
  threshold = sqrt(5.68e-14_preal * u**2)
 
  v(1:3,1) = [ v(1,2) + m(1, 3) * w(1), &
               v(2,2) + m(2, 3) * w(1), &
              (m(1,1) - w(1)) * (m(2,2) - w(1)) - v(3,2)]
  norm = norm2(v(1:3, 1))
  fallback1: if(norm < threshold) then
    call math_eigh(m,w,v,error)
  else fallback1
    v(1:3,1) = v(1:3, 1) / norm
    v(1:3,2) = [ v(1,2) + m(1, 3) * w(2), &
                 v(2,2) + m(2, 3) * w(2), &
                (m(1,1) - w(2)) * (m(2,2) - w(2)) - v(3,2)]
    norm = norm2(v(1:3, 2))
    fallback2: if(norm < threshold) then
      call math_eigh(m,w,v,error)
    else fallback2
      v(1:3,2) = v(1:3, 2) / norm
      v(1:3,3) = math_cross(v(1:3,1),v(1:3,2))
     endif fallback2
  endif fallback1
 
end subroutine math_eigh33
 
 
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function math_rotationalpart(m)
 
  real(preal), intent(in), dimension(3,3) :: m
  real(preal), dimension(3,3) :: math_rotationalpart
  real(preal), dimension(3,3) :: u , uinv
 
  u = eigenvectorbasis(matmul(transpose(m),m))
  uinv = math_inv33(u)
 
  inversionfailed: if (all(deq0(uinv))) then
    math_rotationalpart = math_i3
    call io_warning(650)
  else inversionfailed
    math_rotationalpart = matmul(m,uinv)
  endif inversionfailed
 
contains
  !--------------------------------------------------------------------------------------------------
  !--------------------------------------------------------------------------------------------------
  pure function eigenvectorbasis(m)
 
    real(preal), dimension(3,3)             :: eigenvectorbasis
    real(preal), dimension(3,3), intent(in) :: m
 
    real(preal), dimension(3)               :: i, v
    real(preal) :: p, q, rho, phi
    real(preal), parameter :: tol=1.e-14_preal
    real(preal), dimension(3,3,3) :: n, eb
 
    i = math_invariantssym33(m)
 
    p = i(2)-i(1)**2.0_preal/3.0_preal
    q = -2.0_preal/27.0_preal*i(1)**3.0_preal+product(i(1:2))/3.0_preal-i(3)
 
    threesimilareigvals: if(all(abs([p,q]) < tol)) then
      v = i(1)/3.0_preal
      ! this is not really correct, but at least the basis is correct
      eb = 0.0_preal
      eb(1,1,1)=1.0_preal
      eb(2,2,2)=1.0_preal
      eb(3,3,3)=1.0_preal
    else threesimilareigvals
      rho=sqrt(-3.0_preal*p**3.0_preal)/9.0_preal
      phi=acos(math_clip(-q/rho*0.5_preal,-1.0_preal,1.0_preal))
      v = 2.0_preal*rho**(1.0_preal/3.0_preal)* [cos((phi             )/3.0_preal), &
                                                 cos((phi+2.0_preal*pi)/3.0_preal), &
                                                 cos((phi+4.0_preal*pi)/3.0_preal) &
                                                ] + i(1)/3.0_preal
      n(1:3,1:3,1) = m-v(1)*math_i3
      n(1:3,1:3,2) = m-v(2)*math_i3
      n(1:3,1:3,3) = m-v(3)*math_i3
      twosimilareigvals: if(abs(v(1)-v(2)) < tol) then
        eb(1:3,1:3,3) = matmul(n(1:3,1:3,1),n(1:3,1:3,2))/((v(3)-v(1))*(v(3)-v(2)))
        eb(1:3,1:3,1) = math_i3-eb(1:3,1:3,3)
        eb(1:3,1:3,2) = 0.0_preal
      elseif               (abs(v(2)-v(3)) < tol) then twosimilareigvals
        eb(1:3,1:3,1) = matmul(n(1:3,1:3,2),n(1:3,1:3,3))/((v(1)-v(2))*(v(1)-v(3)))
        eb(1:3,1:3,2) = math_i3-eb(1:3,1:3,1)
        eb(1:3,1:3,3) = 0.0_preal
      elseif               (abs(v(3)-v(1)) < tol) then twosimilareigvals
        eb(1:3,1:3,2) = matmul(n(1:3,1:3,3),n(1:3,1:3,1))/((v(2)-v(3))*(v(2)-v(1)))
        eb(1:3,1:3,3) = math_i3-eb(1:3,1:3,2)
        eb(1:3,1:3,1) = 0.0_preal
      else twosimilareigvals
        eb(1:3,1:3,1) = matmul(n(1:3,1:3,2),n(1:3,1:3,3))/((v(1)-v(2))*(v(1)-v(3)))
        eb(1:3,1:3,2) = matmul(n(1:3,1:3,3),n(1:3,1:3,1))/((v(2)-v(3))*(v(2)-v(1)))
        eb(1:3,1:3,3) = matmul(n(1:3,1:3,1),n(1:3,1:3,2))/((v(3)-v(1))*(v(3)-v(2)))
      endif twosimilareigvals
    endif threesimilareigvals
 
   eigenvectorbasis = sqrt(v(1)) * eb(1:3,1:3,1) &
                    + sqrt(v(2)) * eb(1:3,1:3,2) &
                    + sqrt(v(3)) * eb(1:3,1:3,3)
 
  end function eigenvectorbasis
 
end function math_rotationalpart
 
 
!--------------------------------------------------------------------------------------------------
! will return NaN on error
!--------------------------------------------------------------------------------------------------
function math_eigvalsh(m)
 
  real(preal), dimension(:,:),                  intent(in)  :: m
  real(preal), dimension(size(m,1))                         :: math_eigvalsh
 
  real(preal), dimension(size(m,1),size(m,1))               :: m_
  integer :: ierr
  real(preal), dimension((64+2)*size(m,1)) :: work                                                  ! block size of 64 taken from http://www.netlib.org/lapack/double/dsyev.f
  external :: &
   dsyev
 
  m_= m                                                                                             ! copy matrix to input (will be destroyed)
  call dsyev('N','U',size(m,1),m_,size(m,1),math_eigvalsh,work,size(work,1),ierr)
  if (ierr /= 0) math_eigvalsh = ieee_value(1.0_preal,ieee_quiet_nan)
 
end function math_eigvalsh
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function math_eigvalsh33(m)
 
  real(preal), intent(in), dimension(3,3) :: m
  real(preal), dimension(3) :: math_eigvalsh33,i
  real(preal) :: p, q, rho, phi
  real(preal), parameter :: tol=1.e-14_preal
 
  i = math_invariantssym33(m)                                                                       ! invariants are coefficients in characteristic polynomial apart for the sign of c0 and c2 in http://arxiv.org/abs/physics/0610206
 
  p = i(2)-i(1)**2.0_preal/3.0_preal                                                                ! different from http://arxiv.org/abs/physics/0610206 (this formulation was in DAMASK)
  q = product(i(1:2))/3.0_preal &
    - 2.0_preal/27.0_preal*i(1)**3.0_preal &
    - i(3)                                                                                          ! different from http://arxiv.org/abs/physics/0610206 (this formulation was in DAMASK)
 
  if(all(abs([p,q]) < tol)) then
    math_eigvalsh33 = math_eigvalsh(m)
  else
    rho=sqrt(-3.0_preal*p**3.0_preal)/9.0_preal
    phi=acos(math_clip(-q/rho*0.5_preal,-1.0_preal,1.0_preal))
    math_eigvalsh33 = 2.0_preal*rho**(1.0_preal/3.0_preal)* &
                                                            [cos(phi/3.0_preal), &
                                                             cos((phi+2.0_preal*pi)/3.0_preal), &
                                                             cos((phi+4.0_preal*pi)/3.0_preal) &
                                                            ] &
                    + i(1)/3.0_preal
  endif
 
end function math_eigvalsh33
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function math_invariantssym33(m)
 
  real(preal), dimension(3,3), intent(in) :: m
  real(preal), dimension(3) :: math_invariantssym33
 
  math_invariantssym33(1) = math_trace33(m)
  math_invariantssym33(2) = m(1,1)*m(2,2) + m(1,1)*m(3,3) + m(2,2)*m(3,3) &
                          -(m(1,2)**2     + m(1,3)**2     + m(2,3)**2)
  math_invariantssym33(3) = math_detsym33(m)
 
end function math_invariantssym33
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
integer pure function math_factorial(n)
 
  integer, intent(in) :: n
 
  math_factorial = product(math_range(n))
 
end function math_factorial
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
integer pure function math_binomial(n,k)
 
  integer, intent(in) :: n, k
  integer :: i, k_, n_
 
  k_ = min(k,n-k)
  n_ = n
  math_binomial = merge(1,0,k_>-1)                                                                  ! handling special cases k < 0 or k > n
  do i = 1, k_
    math_binomial = (math_binomial * n_)/i
    n_ = n_ -1
  enddo
 
end function math_binomial
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
integer pure function math_multinomial(alpha)
 
  integer, intent(in), dimension(:) :: alpha
  integer :: i
 
  math_multinomial = 1
  do i = 1, size(alpha)
    math_multinomial = math_multinomial*math_binomial(sum(alpha(1:i)),alpha(i))
  enddo
 
end function math_multinomial
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
real(preal) pure function math_voltetrahedron(v1,v2,v3,v4)
 
  real(preal), dimension (3), intent(in) :: v1,v2,v3,v4
  real(preal), dimension (3,3) :: m
 
  m(1:3,1) = v1-v2
  m(1:3,2) = v1-v3
  m(1:3,3) = v1-v4
 
  math_voltetrahedron = abs(math_det33(m))/6.0_preal
 
end function math_voltetrahedron
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
real(preal) pure function math_areatriangle(v1,v2,v3)
 
  real(preal), dimension (3), intent(in) :: v1,v2,v3
 
  math_areatriangle = 0.5_preal * norm2(math_cross(v1-v2,v1-v3))
 
end function math_areatriangle
 
 
!--------------------------------------------------------------------------------------------------
! Will return NaN if left > right
!--------------------------------------------------------------------------------------------------
real(preal) pure elemental function math_clip(a, left, right)
 
  real(preal), intent(in) :: a
  real(preal), intent(in), optional :: left, right
 
  math_clip = a
  if (present(left))  math_clip = max(left,math_clip)
  if (present(right)) math_clip = min(right,math_clip)
  if (present(left) .and. present(right)) &
    math_clip = merge(ieee_value(1.0_preal,ieee_quiet_nan),math_clip, left>right)
 
end function math_clip
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine unittest
 
  integer, dimension(2,4) :: &
    sort_in_   = reshape([+1,+5,  +5,+6,  -1,-1,  +3,-2],[2,4])
  integer, dimension(2,4), parameter :: &
    sort_out_  = reshape([-1,-1,  +1,+5,  +5,+6,  +3,-2],[2,4])
 
  integer,     dimension(5) :: range_out_ = [1,2,3,4,5]
  integer,     dimension(3) :: ijk
 
  real(preal)                 :: det
  real(preal), dimension(3)   :: v3_1,v3_2,v3_3,v3_4
  real(preal), dimension(6)   :: v6
  real(preal), dimension(9)   :: v9
  real(preal), dimension(3,3) :: t33,t33_2
  real(preal), dimension(6,6) :: t66
  real(preal), dimension(9,9) :: t99,t99_2
  real(preal), dimension(:,:), &
               allocatable    :: txx,txx_2
  real(preal)                 :: r
  integer                     :: d
  logical                     :: e
 
  if (any(abs([1.0_preal,2.0_preal,2.0_preal,3.0_preal,3.0_preal,3.0_preal] - &
              math_expand([1.0_preal,2.0_preal,3.0_preal],[1,2,3,0])) > tol_math_check)) &
    call io_error(0,ext_msg='math_expand [1,2,3] by [1,2,3,0] => [1,2,2,3,3,3]')
 
  if (any(abs([1.0_preal,2.0_preal,2.0_preal] - &
              math_expand([1.0_preal,2.0_preal,3.0_preal],[1,2])) > tol_math_check)) &
    call io_error(0,ext_msg='math_expand [1,2,3] by [1,2] => [1,2,2]')
 
  if (any(abs([1.0_preal,2.0_preal,2.0_preal,1.0_preal,1.0_preal,1.0_preal] - &
              math_expand([1.0_preal,2.0_preal],[1,2,3])) > tol_math_check)) &
    call io_error(0,ext_msg='math_expand [1,2] by [1,2,3] => [1,2,2,1,1,1]')
 
  call math_sort(sort_in_,1,3,2)
  if(any(sort_in_ /= sort_out_)) &
    call io_error(0,ext_msg='math_sort')
 
  if(any(math_range(5) /= range_out_)) &
    call io_error(0,ext_msg='math_range')
 
   if(any(dneq(math_exp33(math_i3,0),math_i3))) &
    call io_error(0,ext_msg='math_exp33(math_I3,1)')
  if(any(dneq(math_exp33(math_i3,256),exp(1.0_preal)*math_i3))) &
    call io_error(0,ext_msg='math_exp33(math_I3,256)')
 
  call random_number(v9)
  if(any(dneq(math_33to9(math_9to33(v9)),v9))) &
    call io_error(0,ext_msg='math_33to9/math_9to33')
 
  call random_number(t99)
  if(any(dneq(math_3333to99(math_99to3333(t99)),t99))) &
    call io_error(0,ext_msg='math_3333to99/math_99to3333')
 
  call random_number(v6)
  if(any(dneq(math_sym33to6(math_6tosym33(v6)),v6))) &
    call io_error(0,ext_msg='math_sym33to6/math_6toSym33')
 
  call random_number(t66)
  if(any(dneq(math_sym3333to66(math_66tosym3333(t66)),t66))) &
    call io_error(0,ext_msg='math_sym3333to66/math_66toSym3333')
 
  call random_number(v6)
  if(any(dneq0(math_6tosym33(v6) - math_symmetric33(math_6tosym33(v6))))) &
    call io_error(0,ext_msg='math_symmetric33')
 
  call random_number(v3_1)
  call random_number(v3_2)
  call random_number(v3_3)
  call random_number(v3_4)
 
  if(dneq(abs(dot_product(math_cross(v3_1-v3_4,v3_2-v3_4),v3_3-v3_4))/6.0, &
          math_voltetrahedron(v3_1,v3_2,v3_3,v3_4),tol=1.0e-12_preal)) &
  call io_error(0,ext_msg='math_volTetrahedron')
 
  call random_number(t33)
  if(dneq(math_det33(math_symmetric33(t33)),math_detsym33(math_symmetric33(t33)),tol=1.0e-12_preal)) &
    call io_error(0,ext_msg='math_det33/math_detSym33')
 
  if(any(dneq0(math_identity2nd(3),math_inv33(math_i3)))) &
    call io_error(0,ext_msg='math_inv33(math_I3)')
 
  do while(abs(math_det33(t33))<1.0e-9_preal)
    call random_number(t33)
  enddo
  if(any(dneq0(matmul(t33,math_inv33(t33)) - math_identity2nd(3),tol=1.0e-9_preal))) &
    call io_error(0,ext_msg='math_inv33')
 
  call math_invert33(t33_2,det,e,t33)
  if(any(dneq0(matmul(t33,t33_2) - math_identity2nd(3),tol=1.0e-9_preal)) .or. e) &
    call io_error(0,ext_msg='math_invert33: T:T^-1 != I')
  if(dneq(det,math_det33(t33),tol=1.0e-12_preal)) &
    call io_error(0,ext_msg='math_invert33 (determinant)')
 
  call math_invert(t33_2,e,t33)
  if(any(dneq0(matmul(t33,t33_2) - math_identity2nd(3),tol=1.0e-9_preal)) .or. e) &
    call io_error(0,ext_msg='math_invert t33')
 
  do while(math_det33(t33)<1.0e-2_preal)                                                            ! O(det(F)) = 1
    call random_number(t33)
  enddo
  t33_2 = math_rotationalpart(transpose(t33))
  t33   = math_rotationalpart(t33)
  if(any(dneq0(matmul(t33_2,t33) - math_i3,tol=1.0e-10_preal))) &
    call io_error(0,ext_msg='math_rotationalPart')
 
  call random_number(r)
  d = int(r*5.0_preal) + 1
  txx = math_identity2nd(d)
  allocate(txx_2(d,d))
  call math_invert(txx_2,e,txx)
  if(any(dneq0(txx_2,txx) .or. e)) &
    call io_error(0,ext_msg='math_invert(txx)/math_identity2nd')
 
  call math_invert(t99_2,e,t99) ! not sure how likely it is that we get a singular matrix
  if(any(dneq0(matmul(t99_2,t99)-math_identity2nd(9),tol=1.0e-9_preal)) .or. e) &
    call io_error(0,ext_msg='math_invert(t99)')
 
  if(any(dneq(math_clip([4.0_preal,9.0_preal],5.0_preal,6.5_preal),[5.0_preal,6.5_preal]))) &
    call io_error(0,ext_msg='math_clip')
 
  if(math_factorial(10) /= 3628800) &
    call io_error(0,ext_msg='math_factorial')
 
  if(math_binomial(49,6) /= 13983816) &
    call io_error(0,ext_msg='math_binomial')
 
  ijk = cshift([1,2,3],int(r*1.0e2_preal))
  if(dneq(math_levicivita(ijk(1),ijk(2),ijk(3)),+1.0_preal)) &
    call io_error(0,ext_msg='math_LeviCivita(even)')
  ijk = cshift([3,2,1],int(r*2.0e2_preal))
  if(dneq(math_levicivita(ijk(1),ijk(2),ijk(3)),-1.0_preal)) &
    call io_error(0,ext_msg='math_LeviCivita(odd)')
  ijk = cshift([2,2,1],int(r*2.0e2_preal))
  if(dneq0(math_levicivita(ijk(1),ijk(2),ijk(3))))&
    call io_error(0,ext_msg='math_LeviCivita')
 
end subroutine unittest
 
end module math
# 13 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/quaternions.f90" 1
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
module quaternions
  use prec
  use io
 
  implicit none
  private
 
  real(preal), parameter, public :: p = -1.0_preal                                                  
 
  type, public :: quaternion
    real(preal), private :: w = 0.0_preal
    real(preal), private :: x = 0.0_preal
    real(preal), private :: y = 0.0_preal
    real(preal), private :: z = 0.0_preal
 
 
  contains
    procedure, private :: add__
    procedure, private :: pos__
    generic,   public  :: operator(+) => add__,pos__
 
    procedure, private :: sub__
    procedure, private :: neg__
    generic,   public  :: operator(-) => sub__,neg__
 
    procedure, private :: mul_quat__
    procedure, private :: mul_scal__
    generic,   public  :: operator(*) => mul_quat__, mul_scal__
 
    procedure, private :: div_quat__
    procedure, private :: div_scal__
    generic,   public  :: operator(/) => div_quat__, div_scal__
 
    procedure, private :: eq__
    generic,   public  :: operator(==) => eq__
 
    procedure, private :: neq__
    generic,   public  :: operator(/=) => neq__
 
    procedure, private :: pow_quat__
    procedure, private :: pow_scal__
    generic,   public  :: operator(**) => pow_quat__, pow_scal__
 
    procedure, public  :: abs   => abs__
    procedure, public  :: conjg => conjg__
    procedure, public  :: real  => real__
    procedure, public  :: aimag => aimag__
 
    procedure, public  :: homomorphed
    procedure, public  :: asarray
    procedure, public  :: inverse
 
  end type
 
  interface assignment (=)
    module procedure assign_quat__
    module procedure assign_vec__
  end interface assignment (=)
  
  interface quaternion
    module procedure init__
  end interface quaternion
  
  interface abs
    procedure abs__
  end interface abs
  
  interface dot_product
    procedure dot_product__
  end interface dot_product
  
  interface conjg
    module procedure conjg__
  end interface conjg
  
  interface exp
    module procedure exp__
  end interface exp
  
  interface log
    module procedure log__
  end interface log
 
  interface real
    module procedure real__
  end interface real
 
  interface aimag
    module procedure aimag__
  end interface aimag
 
  public :: &
    quaternions_init, &
    assignment(=), &
    conjg, aimag, &
    log, exp, &
    real
 
contains
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine quaternions_init
 
  write(6,'(/,a)') ' <<<+-  quaternions init  -+>>>'; flush(6)
  call unittest
 
end subroutine quaternions_init
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
type(quaternion) pure function init__(array)
 
  real(preal), intent(in), dimension(4) :: array
 
  init__%w = array(1)
  init__%x = array(2)
  init__%y = array(3)
  init__%z = array(4)
 
end function init__
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
elemental pure subroutine assign_quat__(self,other)
 
  type(quaternion), intent(out) :: self
  type(quaternion), intent(in)  :: other
 
  self = [other%w,other%x,other%y,other%z]
  
end subroutine assign_quat__
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure subroutine assign_vec__(self,other)
 
  type(quaternion), intent(out)                :: self
  real(preal),       intent(in), dimension(4)  :: other
 
  self%w = other(1)
  self%x = other(2)
  self%y = other(3)
  self%z = other(4)
 
end subroutine assign_vec__
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
type(quaternion) elemental pure function add__(self,other)
 
  class(quaternion), intent(in) :: self,other
 
  add__ = [ self%w,  self%x,  self%y ,self%z] &
        + [other%w, other%x, other%y,other%z]
  
end function add__
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
type(quaternion) elemental pure function pos__(self)
 
  class(quaternion), intent(in) :: self
 
  pos__ = self * (+1.0_preal)
  
end function pos__
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
type(quaternion) elemental pure function sub__(self,other)
 
  class(quaternion), intent(in) :: self,other
 
  sub__ = [ self%w,  self%x,  self%y ,self%z] &
        - [other%w, other%x, other%y,other%z]
  
end function sub__
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
type(quaternion) elemental pure function neg__(self)
 
  class(quaternion), intent(in) :: self
 
  neg__ = self * (-1.0_preal)
  
end function neg__
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
type(quaternion) elemental pure function mul_quat__(self,other)
 
  class(quaternion), intent(in) :: self, other
 
  mul_quat__%w = self%w*other%w - self%x*other%x -      self%y*other%y - self%z*other%z
  mul_quat__%x = self%w*other%x + self%x*other%w + p * (self%y*other%z - self%z*other%y)
  mul_quat__%y = self%w*other%y + self%y*other%w + p * (self%z*other%x - self%x*other%z)
  mul_quat__%z = self%w*other%z + self%z*other%w + p * (self%x*other%y - self%y*other%x)
 
end function mul_quat__
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
type(quaternion) elemental pure function mul_scal__(self,scal)
 
  class(quaternion), intent(in) :: self
  real(preal),       intent(in) :: scal
 
  mul_scal__ = [self%w,self%x,self%y,self%z]*scal
  
end function mul_scal__
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
type(quaternion) elemental pure function div_quat__(self,other)
 
  class(quaternion), intent(in) :: self, other
 
  div_quat__ = self * (conjg(other)/(abs(other)**2.0_preal))
 
end function div_quat__
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
type(quaternion) elemental pure function div_scal__(self,scal)
 
  class(quaternion), intent(in) :: self
  real(preal),       intent(in) :: scal
 
  div_scal__ = [self%w,self%x,self%y,self%z]/scal
 
end function div_scal__
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
logical elemental pure function eq__(self,other)
 
  class(quaternion), intent(in) :: self,other
 
  eq__ = all(deq([ self%w, self%x, self%y, self%z], &
                 [other%w,other%x,other%y,other%z]))
 
end function eq__
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
logical elemental pure function neq__(self,other)
 
  class(quaternion), intent(in) :: self,other
 
  neq__ = .not. self%eq__(other)
 
end function neq__
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
type(quaternion) elemental pure function pow_quat__(self,expon)
 
  class(quaternion), intent(in) :: self
  type(quaternion),  intent(in) :: expon
 
  pow_quat__ = exp(log(self)*expon)
 
end function pow_quat__
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
type(quaternion) elemental pure function pow_scal__(self,expon)
 
  class(quaternion), intent(in) :: self
  real(preal),       intent(in) :: expon
 
  pow_scal__ = exp(log(self)*expon)
 
end function pow_scal__
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
type(quaternion) elemental pure function exp__(a)
 
  class(quaternion), intent(in) :: a
  real(preal)                   :: absimag
 
  absimag = norm2(aimag(a))
 
  exp__ = merge(exp(a%w) * [               cos(absimag), &
                             a%x/absimag * sin(absimag), &
                             a%y/absimag * sin(absimag), &
                             a%z/absimag * sin(absimag)], &
                ieee_value(1.0_preal,ieee_signaling_nan), &
                dneq0(absimag))
 
end function exp__
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
type(quaternion) elemental pure function log__(a)
 
  class(quaternion), intent(in) :: a
  real(preal)                   :: absimag
 
  absimag = norm2(aimag(a))
 
  log__ = merge([log(abs(a)), &
                 a%x/absimag * acos(a%w/abs(a)), &
                 a%y/absimag * acos(a%w/abs(a)), &
                 a%z/absimag * acos(a%w/abs(a))], &
                ieee_value(1.0_preal,ieee_signaling_nan), &
                dneq0(absimag))
 
end function log__
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
real(preal) elemental pure function abs__(self)
 
  class(quaternion), intent(in) :: self
 
  abs__ = norm2([self%w,self%x,self%y,self%z])
 
end function abs__
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
real(preal) elemental pure function dot_product__(a,b)
 
  class(quaternion), intent(in) :: a,b
 
  dot_product__ = a%w*b%w + a%x*b%x + a%y*b%y + a%z*b%z
 
end function dot_product__
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
type(quaternion) elemental pure function conjg__(self)
 
  class(quaternion), intent(in) :: self
 
  conjg__ = [self%w,-self%x,-self%y,-self%z]
 
end function conjg__
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
type(quaternion) elemental pure function homomorphed(self)
 
  class(quaternion), intent(in) :: self
 
  homomorphed = - self
 
end function homomorphed
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function asarray(self)
 
  real(preal), dimension(4)     :: asarray
  class(quaternion), intent(in) :: self
 
  asarray = [self%w,self%x,self%y,self%z]
 
end function asarray
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function real__(self)
 
  real(preal)                   :: real__
  class(quaternion), intent(in) :: self
 
  real__ = self%w
 
end function real__
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function aimag__(self)
 
  real(preal), dimension(3)     :: aimag__
  class(quaternion), intent(in) :: self
 
  aimag__ = [self%x,self%y,self%z]
 
end function aimag__
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
type(quaternion) elemental pure function inverse(self)
 
  class(quaternion), intent(in) :: self
 
  inverse = conjg(self)/abs(self)**2.0_preal
 
end function inverse
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine unittest
 
  real(pReal), dimension(4) :: qu
  type(quaternion)          :: q, q_2
 
  call random_number(qu)
  qu = (qu-0.5_preal) * 2.0_preal
  q  = quaternion(qu)
 
  q_2= qu
  if(any(dneq(q%asArray(),q_2%asArray())))             call io_error(0,ext_msg='assign_vec__')
 
  q_2 = q + q
  if(any(dneq(q_2%asArray(),2.0_preal*qu)))            call io_error(0,ext_msg='add__')
 
  q_2 = q - q
  if(any(dneq0(q_2%asArray())))                        call io_error(0,ext_msg='sub__')
 
  q_2 = q * 5.0_preal
  if(any(dneq(q_2%asArray(),5.0_preal*qu)))            call io_error(0,ext_msg='mul__')
 
  q_2 = q / 0.5_preal
  if(any(dneq(q_2%asArray(),2.0_preal*qu)))            call io_error(0,ext_msg='div__')
 
  q_2 = q * 0.3_preal
  if(dneq0(abs(q)) .and. q_2 == q)                     call io_error(0,ext_msg='eq__')
 
  q_2 = q
  if(q_2 /= q)                                         call io_error(0,ext_msg='neq__')
 
  if(dneq(abs(q),norm2(qu)))                           call io_error(0,ext_msg='abs__')
  if(dneq(abs(q)**2.0_preal, real(q*q%conjg()),1.0e-14_preal)) &
                                                       call io_error(0,ext_msg='abs__/*conjg')
 
  if(any(dneq(q%asArray(),qu)))                        call io_error(0,ext_msg='eq__')
  if(dneq(q%real(),       qu(1)))                      call io_error(0,ext_msg='real()')
  if(any(dneq(q%aimag(),  qu(2:4))))                   call io_error(0,ext_msg='aimag()')
 
  q_2 = q%homomorphed()
  if(q                 /= q_2*    (-1.0_preal))        call io_error(0,ext_msg='homomorphed')
  if(dneq(q_2%real(),     qu(1)*  (-1.0_preal)))       call io_error(0,ext_msg='homomorphed/real')
  if(any(dneq(q_2%aimag(),qu(2:4)*(-1.0_preal))))      call io_error(0,ext_msg='homomorphed/aimag')
 
  q_2 = conjg(q)
  if(dneq(abs(q),abs(q_2)))                            call io_error(0,ext_msg='conjg/abs')
  if(q /= conjg(q_2))                                  call io_error(0,ext_msg='conjg/involution')
  if(dneq(q_2%real(),     q%real()))                   call io_error(0,ext_msg='conjg/real')
  if(any(dneq(q_2%aimag(),q%aimag()*(-1.0_preal))))    call io_error(0,ext_msg='conjg/aimag')
 
  if(abs(q) > 0.0_preal) then
    q_2 = q * q%inverse()
    if(     dneq(real(q_2), 1.0_preal,1.0e-15_preal))  call io_error(0,ext_msg='inverse/real')
    if(any(dneq0(aimag(q_2),          1.0e-15_preal))) call io_error(0,ext_msg='inverse/aimag')
 
    q_2 = q/abs(q)
    q_2 = conjg(q_2) - inverse(q_2)
    if(any(dneq0(q_2%asArray(),1.0e-15_preal)))        call io_error(0,ext_msg='inverse/conjg')
  endif
  if(dneq(dot_product(qu,qu),dot_product(q,q)))        call io_error(0,ext_msg='dot_product')
 
 
 
 
 
 
 
 
end subroutine unittest
 
 
end module quaternions
# 14 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/Lambert.f90" 1
! ###################################################################
! Copyright (c) 2013-2015, Marc De Graef/Carnegie Mellon University
! Modified      2017-2019, Martin Diehl/Max-Planck-Institut für Eisenforschung GmbH
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification, are 
! permitted provided that the following conditions are met:
!
!     - Redistributions of source code must retain the above copyright notice, this list 
!        of conditions and the following disclaimer.
!     - Redistributions in binary form must reproduce the above copyright notice, this 
!        list of conditions and the following disclaimer in the documentation and/or 
!        other materials provided with the distribution.
!     - Neither the names of Marc De Graef, Carnegie Mellon University nor the names 
!        of its contributors may be used to endorse or promote products derived from 
!        this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 
! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE 
! LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE 
! USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! ###################################################################
 
!--------------------------------------------------------------------------
!
!--------------------------------------------------------------------------
module lambert
  use prec
  use math
 
  implicit none
  private
  
  real(preal), parameter :: &
    spi  = sqrt(pi), &
    pref = sqrt(6.0_preal/pi), &
    a    = pi**(5.0_preal/6.0_preal)/6.0_preal**(1.0_preal/6.0_preal), &
    ap   = pi**(2.0_preal/3.0_preal), &
    sc   = a/ap, &
    beta = a/2.0_preal, &
    r1   = (3.0_preal*pi/4.0_preal)**(1.0_preal/3.0_preal), &
    r2   = sqrt(2.0_preal), &
    pi12 = pi/12.0_preal, &
    prek = r1 * 2.0_preal**(1.0_preal/4.0_preal)/beta
 
  public :: &
    lambert_cubetoball, &
    lambert_balltocube
 
contains
 
 
!--------------------------------------------------------------------------
!--------------------------------------------------------------------------
pure function lambert_cubetoball(cube) result(ball)
 
  real(preal), intent(in), dimension(3) :: cube
  real(preal),             dimension(3) :: ball, lamxyz, xyz
  real(preal),             dimension(2) :: t
  real(preal)                           :: c, s, q
  real(preal), parameter                :: eps = 1.0e-8_preal
  integer,                 dimension(3) :: p
  integer,                 dimension(2) :: order
  
  if (maxval(abs(cube)) > ap/2.0+eps) then
    ball = ieee_value(cube,ieee_positive_inf)
    return
  end if
  
  ! transform to the sphere grid via the curved square, and intercept the zero point
  center: if (all(deq0(cube))) then
    ball  = 0.0_preal
  else center
    ! get pyramide and scale by grid parameter ratio
    p = getpyramidorder(cube)
    xyz = cube(p) * sc
  
    ! intercept all the points along the z-axis
    special: if (all(deq0(xyz(1:2)))) then
      lamxyz = [ 0.0_preal, 0.0_preal, pref * xyz(3) ]
    else special
      order = merge( [2,1], [1,2], abs(xyz(2)) <= abs(xyz(1)))                                      ! order of absolute values of XYZ
      q = pi12 *  xyz(order(1))/xyz(order(2))                                                       ! smaller by larger
      c = cos(q)
      s = sin(q)
      q = prek * xyz(order(2))/ sqrt(r2-c)
      t = [ (r2*c - 1.0), r2 * s] * q
  
      ! transform to sphere grid (inverse Lambert)
      ! [note that there is no need to worry about dividing by zero, since XYZ(3) can not become zero]
      c = sum(t**2)
      s = pi * c/(24.0*xyz(3)**2)
      c = spi * c / sqrt(24.0_preal) / xyz(3)
      q = sqrt( 1.0 - s )
      lamxyz = [ t(order(2)) * q, t(order(1)) * q, pref * xyz(3) - c ]
    endif special
  
    ! reverse the coordinates back to order according to the original pyramid number
    ball = lamxyz(p)
 
  endif center
 
end function lambert_cubetoball
 
 
!--------------------------------------------------------------------------
!--------------------------------------------------------------------------
pure function lambert_balltocube(xyz) result(cube)
 
  real(preal), intent(in), dimension(3) :: xyz
  real(preal),             dimension(3) :: cube, xyz1, xyz3
  real(preal),             dimension(2) :: tinv, xyz2
  real(preal)                           :: rs, qxy, q2, sq2, q, tt
  integer,                 dimension(3) :: p
  
  rs = norm2(xyz)
  if (rs > r1) then 
    cube = ieee_value(cube,ieee_positive_inf)
    return
  endif
  
  center: if (all(deq0(xyz))) then 
    cube = 0.0_preal
  else center
    p = getpyramidorder(xyz)
    xyz3 = xyz(p)
    
    ! inverse M_3
    xyz2 = xyz3(1:2) * sqrt( 2.0*rs/(rs+abs(xyz3(3))) )
    
    ! inverse M_2
    qxy = sum(xyz2**2)
    
    special: if (deq0(qxy)) then 
      tinv = 0.0_preal
    else special
      q2 = qxy + maxval(abs(xyz2))**2
      sq2 = sqrt(q2)
      q = (beta/r2/r1) * sqrt(q2*qxy/(q2-maxval(abs(xyz2))*sq2))
      tt = (minval(abs(xyz2))**2+maxval(abs(xyz2))*sq2)/r2/qxy 
      tinv = q * sign(1.0_preal,xyz2) * merge([ 1.0_preal, acos(math_clip(tt,-1.0_preal,1.0_preal))/pi12], &
                                              [ acos(math_clip(tt,-1.0_preal,1.0_preal))/pi12, 1.0_preal], &
                                               abs(xyz2(2)) <= abs(xyz2(1)))
    endif special
    
    ! inverse M_1
    xyz1 = [ tinv(1), tinv(2), sign(1.0_preal,xyz3(3)) * rs / pref ] /sc
    
    ! reverse the coordinates back to order according to the original pyramid number
    cube = xyz1(p)
 
  endif center
 
end function lambert_balltocube
 
 
!--------------------------------------------------------------------------
!--------------------------------------------------------------------------
pure function getpyramidorder(xyz)
 
  real(preal),intent(in),dimension(3) :: xyz
  integer,               dimension(3) :: getpyramidorder
 
  if      (((abs(xyz(1)) <=  xyz(3)).and.(abs(xyz(2)) <=  xyz(3))) .or. &
           ((abs(xyz(1)) <= -xyz(3)).and.(abs(xyz(2)) <= -xyz(3)))) then
    getpyramidorder = [1,2,3]
  else if (((abs(xyz(3)) <=  xyz(1)).and.(abs(xyz(2)) <=  xyz(1))) .or. &
           ((abs(xyz(3)) <= -xyz(1)).and.(abs(xyz(2)) <= -xyz(1)))) then
    getpyramidorder = [2,3,1]
  else if (((abs(xyz(1)) <=  xyz(2)).and.(abs(xyz(3)) <=  xyz(2))) .or. &
           ((abs(xyz(1)) <= -xyz(2)).and.(abs(xyz(3)) <= -xyz(2)))) then
    getpyramidorder = [3,1,2]
  else
    getpyramidorder = -1                                                                            ! should be impossible, but might simplify debugging
  end if
 
end function getpyramidorder
 
end module lambert
# 15 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/rotations.f90" 1
! ###################################################################
! Copyright (c) 2013-2014, Marc De Graef/Carnegie Mellon University
! Modified      2017-2020, Martin Diehl/Max-Planck-Institut für Eisenforschung GmbH
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification, are 
! permitted provided that the following conditions are met:
!
!     - Redistributions of source code must retain the above copyright notice, this list 
!        of conditions and the following disclaimer.
!     - Redistributions in binary form must reproduce the above copyright notice, this 
!        list of conditions and the following disclaimer in the documentation and/or 
!        other materials provided with the distribution.
!     - Neither the names of Marc De Graef, Carnegie Mellon University nor the names 
!        of its contributors may be used to endorse or promote products derived from 
!        this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 
! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE 
! LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE 
! USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! ###################################################################
 
!---------------------------------------------------------------------------------------------------
!
!  All methods and naming conventions based on Rowenhorst_etal2015
!    Convention 1: coordinate frames are right-handed
!    Convention 2: a rotation angle ω is taken to be positive for a counterclockwise rotation
!                  when viewing from the end point of the rotation axis towards the origin
!    Convention 3: rotations will be interpreted in the passive sense
!    Convention 4: Euler angle triplets are implemented using the Bunge convention,
!                  with the angular ranges as [0, 2π],[0, π],[0, 2π]
!    Convention 5: the rotation angle ω is limited to the interval [0, π]
!    Convention 6: the real part of a quaternion is positive, Re(q) > 0
!    Convention 7: P = -1
!---------------------------------------------------------------------------------------------------
 
module rotations
  use prec
  use io
  use math
  use lambert
  use quaternions
 
  implicit none
  private
 
  type, public :: rotation
    type(quaternion), private :: q
    contains
      procedure, public :: asquaternion
      procedure, public :: aseulers
      procedure, public :: asaxisangle
      procedure, public :: asrodrigues
      procedure, public :: asmatrix
      !------------------------------------------
      procedure, public :: fromquaternion
      procedure, public :: fromeulers
      procedure, public :: fromaxisangle
      procedure, public :: frommatrix
      !------------------------------------------
      procedure, private :: rotrot__
      generic,   public  :: operator(*) => rotrot__
      generic,   public  :: rotate => rotvector,rottensor2,rottensor4
      procedure, public  :: rotvector
      procedure, public  :: rottensor2
      procedure, public  :: rottensor4
      procedure, public  :: rottensor4sym
      procedure, public  :: misorientation
      procedure, public  :: standardize
  end type rotation
  
  public :: &
    rotations_init, &
    eu2om
 
contains
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine rotations_init
 
  call quaternions_init
  write(6,'(/,a)') ' <<<+-  rotations init  -+>>>'; flush(6)
  call unittest
 
end subroutine rotations_init
 
 
!---------------------------------------------------------------------------------------------------
! Return rotation in different representations
!---------------------------------------------------------------------------------------------------
pure function asquaternion(self)
 
  class(rotation), intent(in) :: self
  real(preal), dimension(4)   :: asquaternion
 
  asquaternion = self%q%asArray()
 
end function asquaternion
!---------------------------------------------------------------------------------------------------
pure function aseulers(self)
  
  class(rotation), intent(in) :: self
  real(preal), dimension(3)   :: aseulers
   
  aseulers = qu2eu(self%q%asArray())
 
end function aseulers
!---------------------------------------------------------------------------------------------------
pure function asaxisangle(self)
 
  class(rotation), intent(in) :: self
  real(preal), dimension(4)   :: asaxisangle
 
  asaxisangle = qu2ax(self%q%asArray())
 
end function asaxisangle
!---------------------------------------------------------------------------------------------------
pure function asmatrix(self)
 
  class(rotation), intent(in) :: self
  real(preal), dimension(3,3) :: asmatrix
 
  asmatrix = qu2om(self%q%asArray())
 
end function asmatrix
!---------------------------------------------------------------------------------------------------
pure function asrodrigues(self)
 
  class(rotation), intent(in) :: self
  real(preal), dimension(4)   :: asrodrigues
 
  asrodrigues = qu2ro(self%q%asArray())
 
end function asrodrigues
!---------------------------------------------------------------------------------------------------
pure function ashomochoric(self)
 
  class(rotation), intent(in) :: self
  real(preal), dimension(3)   :: ashomochoric
 
  ashomochoric = qu2ho(self%q%asArray())
 
end function ashomochoric
 
!---------------------------------------------------------------------------------------------------
! Initialize rotation from different representations
!---------------------------------------------------------------------------------------------------
subroutine fromquaternion(self,qu)
 
  class(rotation), intent(out)          :: self
  real(pReal), dimension(4), intent(in) :: qu
 
  if (dneq(norm2(qu),1.0_preal)) &
    call io_error(402,ext_msg='fromQuaternion')
 
  self%q = qu
 
end subroutine fromquaternion
!---------------------------------------------------------------------------------------------------
subroutine fromeulers(self,eu,degrees)
 
  class(rotation), intent(out)          :: self
  real(pReal), dimension(3), intent(in) :: eu
  logical, intent(in), optional         :: degrees
 
  real(pReal), dimension(3)             :: Eulers
 
  if (.not. present(degrees)) then
    eulers = eu
  else
    eulers = merge(eu*inrad,eu,degrees)
  endif
 
  if (any(eulers<0.0_preal) .or. any(eulers>2.0_preal*pi) .or. eulers(2) > pi) &
    call io_error(402,ext_msg='fromEulers')
 
  self%q = eu2qu(eulers)
 
end subroutine fromeulers
!---------------------------------------------------------------------------------------------------
subroutine fromaxisangle(self,ax,degrees,P)
 
  class(rotation), intent(out)          :: self
  real(pReal), dimension(4), intent(in) :: ax
  logical, intent(in), optional         :: degrees
  integer, intent(in), optional         :: P
 
  real(pReal)                           :: angle
  real(pReal),dimension(3)              :: axis
 
  if (.not. present(degrees)) then
    angle = ax(4)
  else
    angle = merge(ax(4)*inrad,ax(4),degrees)
  endif
  
  if (.not. present(p)) then
    axis = ax(1:3)
  else
    axis = ax(1:3) * merge(-1.0_preal,1.0_preal,p == 1)
    if(abs(p) /= 1) call io_error(402,ext_msg='fromAxisAngle (P)')
  endif
 
  if(dneq(norm2(axis),1.0_preal) .or. angle < 0.0_preal .or. angle > pi) &
    call io_error(402,ext_msg='fromAxisAngle')
  
  self%q = ax2qu([axis,angle])
 
end subroutine fromaxisangle
!---------------------------------------------------------------------------------------------------
subroutine frommatrix(self,om)
 
  class(rotation), intent(out)            :: self
  real(pReal), dimension(3,3), intent(in) :: om
 
  if (dneq(math_det33(om),1.0_preal,tol=1.0e-5_preal)) &
    call io_error(402,ext_msg='fromMatrix')
 
  self%q = om2qu(om)
 
end subroutine frommatrix
!---------------------------------------------------------------------------------------------------
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure elemental function rotrot__(self,R) result(rRot)
    
  type(rotation)              :: rrot
  class(rotation), intent(in) :: self,r
  
  rrot = rotation(self%q*r%q)
  call rrot%standardize()
 
end function rotrot__
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure elemental subroutine standardize(self)
 
  class(rotation), intent(inout) :: self
  
  if (real(self%q) < 0.0_preal) self%q = self%q%homomorphed()
 
end subroutine standardize
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function rotvector(self,v,active) result(vRot)
    
  real(preal),                 dimension(3) :: vrot
  class(rotation), intent(in)               :: self
  real(preal),     intent(in), dimension(3) :: v
  logical,         intent(in), optional     :: active
  
  real(preal),    dimension(3) :: v_normed
  type(quaternion)             :: q
  logical                      :: passive
 
  if (present(active)) then
    passive = .not. active
  else
    passive = .true.
  endif
 
  if (deq0(norm2(v))) then
    vrot = v
  else
    v_normed = v/norm2(v)
    if (passive) then
      q = self%q * (quaternion([0.0_preal, v_normed(1), v_normed(2), v_normed(3)]) * conjg(self%q) )
    else
      q = conjg(self%q) * (quaternion([0.0_preal, v_normed(1), v_normed(2), v_normed(3)]) * self%q )
    endif
    vrot = q%aimag()*norm2(v)
  endif
 
end function rotvector
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function rottensor2(self,T,active) result(tRot)
  
  real(preal),                 dimension(3,3) :: trot
  class(rotation), intent(in)                 :: self
  real(preal),     intent(in), dimension(3,3) :: t
  logical,         intent(in), optional       :: active
   
  logical           :: passive
 
  if (present(active)) then
    passive = .not. active
  else
    passive = .true.
  endif
 
  if (passive) then
    trot = matmul(matmul(self%asMatrix(),t),transpose(self%asMatrix()))
  else
    trot = matmul(matmul(transpose(self%asMatrix()),t),self%asMatrix())
  endif
 
end function rottensor2
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function rottensor4(self,T,active) result(tRot)
 
  real(preal),                 dimension(3,3,3,3) :: trot
  class(rotation), intent(in)                     :: self
  real(preal),     intent(in), dimension(3,3,3,3) :: t
  logical,         intent(in), optional           :: active
 
  real(preal), dimension(3,3) :: r
  integer :: i,j,k,l,m,n,o,p
 
  if (present(active)) then
    r = merge(transpose(self%asMatrix()),self%asMatrix(),active)
  else
    r = self%asMatrix()
  endif
 
  trot = 0.0_preal
  do i = 1,3;do j = 1,3;do k = 1,3;do l = 1,3
  do m = 1,3;do n = 1,3;do o = 1,3;do p = 1,3
    trot(i,j,k,l) = trot(i,j,k,l) &
                  + r(i,m) * r(j,n) * r(k,o) * r(l,p) * t(m,n,o,p)
  enddo; enddo; enddo; enddo; enddo; enddo; enddo; enddo
 
end function rottensor4
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function rottensor4sym(self,T,active) result(tRot)
 
  real(preal),                 dimension(6,6) :: trot
  class(rotation), intent(in)                 :: self
  real(preal),     intent(in), dimension(6,6) :: t
  logical,         intent(in), optional       :: active
 
  if (present(active)) then
    trot = math_sym3333to66(rottensor4(self,math_66tosym3333(t),active))
  else
    trot = math_sym3333to66(rottensor4(self,math_66tosym3333(t)))
  endif
 
end function rottensor4sym
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure elemental function misorientation(self,other)
  
  type(rotation)              :: misorientation
  class(rotation), intent(in) :: self, other
  
  misorientation%q = other%q * conjg(self%q)
 
end function misorientation
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function qu2om(qu) result(om)
 
  real(preal), intent(in), dimension(4)   :: qu
  real(preal),             dimension(3,3) :: om
  
  real(preal)                             :: qq
 
  qq = qu(1)**2-sum(qu(2:4)**2)
 
 
  om(1,1) = qq+2.0_preal*qu(2)**2
  om(2,2) = qq+2.0_preal*qu(3)**2
  om(3,3) = qq+2.0_preal*qu(4)**2
 
  om(1,2) = 2.0_preal*(qu(2)*qu(3)-qu(1)*qu(4))
  om(2,3) = 2.0_preal*(qu(3)*qu(4)-qu(1)*qu(2))
  om(3,1) = 2.0_preal*(qu(4)*qu(2)-qu(1)*qu(3))
  om(2,1) = 2.0_preal*(qu(3)*qu(2)+qu(1)*qu(4))
  om(3,2) = 2.0_preal*(qu(4)*qu(3)+qu(1)*qu(2))
  om(1,3) = 2.0_preal*(qu(2)*qu(4)+qu(1)*qu(3))
 
  if (p < 0.0_preal) om = transpose(om)
 
end function qu2om
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function qu2eu(qu) result(eu)
 
  real(preal), intent(in), dimension(4) :: qu
  real(preal),             dimension(3) :: eu
  
  real(preal)                           :: q12, q03, chi, chiinv
  
  q03 = qu(1)**2+qu(4)**2
  q12 = qu(2)**2+qu(3)**2
  chi = sqrt(q03*q12)
  
  degenerated: if (deq0(chi)) then
    eu = merge([atan2(-p*2.0_preal*qu(1)*qu(4),qu(1)**2-qu(4)**2), 0.0_preal, 0.0_preal], &
               [atan2(   2.0_preal*qu(2)*qu(3),qu(2)**2-qu(3)**2), pi,        0.0_preal], &
               deq0(q12))
  else degenerated
    chiinv = 1.0_preal/chi
    eu = [atan2((-p*qu(1)*qu(3)+qu(2)*qu(4))*chi, (-p*qu(1)*qu(2)-qu(3)*qu(4))*chi ), &
          atan2( 2.0_preal*chi, q03-q12 ), &
          atan2(( p*qu(1)*qu(3)+qu(2)*qu(4))*chi, (-p*qu(1)*qu(2)+qu(3)*qu(4))*chi )]
  endif degenerated
  where(eu<0.0_preal) eu = mod(eu+2.0_preal*pi,[2.0_preal*pi,pi,2.0_preal*pi])
 
end function qu2eu
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function qu2ax(qu) result(ax)
 
  real(preal), intent(in), dimension(4) :: qu
  real(preal),             dimension(4) :: ax
  
  real(preal)                           :: omega, s
 
  if (deq0(sum(qu(2:4)**2))) then
    ax = [ 0.0_preal, 0.0_preal, 1.0_preal, 0.0_preal ]                                             ! axis = [001]
  elseif (dneq0(qu(1))) then
    s =  sign(1.0_preal,qu(1))/norm2(qu(2:4))
    omega = 2.0_preal * acos(math_clip(qu(1),-1.0_preal,1.0_preal))
    ax = [ qu(2)*s, qu(3)*s, qu(4)*s, omega ]
  else
    ax = [ qu(2),   qu(3),   qu(4),   pi ]
  end if
 
end function qu2ax
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function qu2ro(qu) result(ro)
  
  real(preal), intent(in), dimension(4) :: qu
  real(preal),             dimension(4) :: ro
  
  real(preal)                           :: s
  real(preal), parameter                :: thr = 1.0e-8_preal
  
  if (abs(qu(1)) < thr) then
    ro =   [qu(2),  qu(3),  qu(4), ieee_value(1.0_preal,ieee_positive_inf)]
  else
    s = norm2(qu(2:4))
    if (s < thr) then
      ro = [0.0_preal, 0.0_preal, p, 0.0_preal]
    else
      ro = [qu(2)/s,qu(3)/s,qu(4)/s, tan(acos(math_clip(qu(1),-1.0_preal,1.0_preal)))]
    endif
    
  end if
 
end function qu2ro
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function qu2ho(qu) result(ho)
 
  real(preal), intent(in), dimension(4) :: qu
  real(preal),             dimension(3) :: ho
  
  real(preal)                           :: omega, f
 
  omega = 2.0 * acos(math_clip(qu(1),-1.0_preal,1.0_preal))
  
  if (deq0(omega)) then
    ho = [ 0.0_preal, 0.0_preal, 0.0_preal ]
  else
    ho = qu(2:4)
    f  = 0.75_preal * ( omega - sin(omega) )
    ho = ho/norm2(ho)* f**(1.0_preal/3.0_preal)
  end if
 
end function qu2ho
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function qu2cu(qu) result(cu)
 
  real(preal), intent(in), dimension(4) :: qu
  real(preal),             dimension(3) :: cu
 
  cu = ho2cu(qu2ho(qu))
 
end function qu2cu
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function om2qu(om) result(qu)
 
  real(preal), intent(in), dimension(3,3) :: om
  real(preal),             dimension(4)   :: qu
 
  qu = eu2qu(om2eu(om))
 
end function om2qu
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function om2eu(om) result(eu)
 
  real(preal), intent(in), dimension(3,3) :: om
  real(preal),             dimension(3)   :: eu
  real(preal)                             :: zeta
  
  if (abs(om(3,3)) < 1.0_preal) then
    zeta = 1.0_preal/sqrt(1.0_preal-om(3,3)**2.0_preal)
    eu = [atan2(om(3,1)*zeta,-om(3,2)*zeta), &
          acos(om(3,3)), &
          atan2(om(1,3)*zeta, om(2,3)*zeta)]
  else 
    eu = [atan2(om(1,2),om(1,1)), 0.5_preal*pi*(1.0_preal-om(3,3)),0.0_preal ]
  end if
 
  where(eu<0.0_preal) eu = mod(eu+2.0_preal*pi,[2.0_preal*pi,pi,2.0_preal*pi])
 
end function om2eu
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
function om2ax(om) result(ax)
 
  real(preal), intent(in), dimension(3,3) :: om
  real(preal),             dimension(4)   :: ax
  
  real(preal)                      :: t
  real(preal), dimension(3)        :: wr, wi
  real(preal), dimension((64+2)*3) :: work
  real(preal), dimension(3,3)      :: vr, devnull, om_
  integer                          :: ierr, i
  
  external :: dgeev
  
  om_ = om
  
  ! first get the rotation angle
  t = 0.5_preal * (math_trace33(om) - 1.0_preal)
  ax(4) = acos(math_clip(t,-1.0_preal,1.0_preal))
  
  if (deq0(ax(4))) then
    ax(1:3) = [ 0.0_preal, 0.0_preal, 1.0_preal ]
  else
    call dgeev('N','V',3,om_,3,wr,wi,devnull,3,vr,3,work,size(work,1),ierr)
    if (ierr /= 0) call io_error(401,ext_msg='Error in om2ax: DGEEV return not zero')
 
    i = maxloc(merge(1,0,ceq(cmplx(wr,wi,preal),cmplx(1.0_preal,0.0_preal,preal),tol=1.0e-14_preal)),dim=1)
 
 
 
    if (i == 0) call io_error(401,ext_msg='Error in om2ax Real: eigenvalue not found')
    ax(1:3) = vr(1:3,i)
    where (                dneq0([om(2,3)-om(3,2), om(3,1)-om(1,3), om(1,2)-om(2,1)])) &
      ax(1:3) = sign(ax(1:3),-p *[om(2,3)-om(3,2), om(3,1)-om(1,3), om(1,2)-om(2,1)])
  endif
 
end function om2ax
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function om2ro(om) result(ro)
 
  real(preal), intent(in), dimension(3,3) :: om
  real(preal),             dimension(4)   :: ro
 
  ro = eu2ro(om2eu(om))
 
end function om2ro
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
function om2ho(om) result(ho)
 
  real(preal), intent(in), dimension(3,3) :: om
  real(preal),             dimension(3)   :: ho
 
  ho = ax2ho(om2ax(om))
 
end function om2ho
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
function om2cu(om) result(cu)
 
  real(preal), intent(in), dimension(3,3) :: om
  real(preal),             dimension(3)   :: cu
 
  cu = ho2cu(om2ho(om))
 
end function om2cu
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function eu2qu(eu) result(qu)
 
  real(preal), intent(in), dimension(3) :: eu
  real(preal),             dimension(4) :: qu
  real(preal),             dimension(3) :: ee
  real(preal)                           :: cphi, sphi
 
  ee = 0.5_preal*eu
  
  cphi = cos(ee(2))
  sphi = sin(ee(2))
 
  qu = [   cphi*cos(ee(1)+ee(3)), &
        -p*sphi*cos(ee(1)-ee(3)), &
        -p*sphi*sin(ee(1)-ee(3)), &
        -p*cphi*sin(ee(1)+ee(3))]
  if(qu(1) < 0.0_preal) qu = qu * (-1.0_preal)
 
end function eu2qu
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function eu2om(eu) result(om)
  
  real(preal), intent(in), dimension(3)   :: eu
  real(preal),             dimension(3,3) :: om
  
  real(preal),             dimension(3)   :: c, s      
 
  c = cos(eu)
  s = sin(eu)
 
  om(1,1) =  c(1)*c(3)-s(1)*s(3)*c(2)
  om(1,2) =  s(1)*c(3)+c(1)*s(3)*c(2)
  om(1,3) =  s(3)*s(2)
  om(2,1) = -c(1)*s(3)-s(1)*c(3)*c(2)
  om(2,2) = -s(1)*s(3)+c(1)*c(3)*c(2)
  om(2,3) =  c(3)*s(2)
  om(3,1) =  s(1)*s(2)
  om(3,2) = -c(1)*s(2)
  om(3,3) =  c(2)
 
  where(deq0(om)) om = 0.0_preal
 
end function eu2om
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function eu2ax(eu) result(ax)
 
  real(preal), intent(in), dimension(3) :: eu
  real(preal),             dimension(4) :: ax
  
  real(preal)                           :: t, delta, tau, alpha, sigma
  
  t     = tan(eu(2)*0.5_preal)
  sigma = 0.5_preal*(eu(1)+eu(3))
  delta = 0.5_preal*(eu(1)-eu(3))
  tau   = sqrt(t**2+sin(sigma)**2)
  
  alpha = merge(pi, 2.0_preal*atan(tau/cos(sigma)), deq(sigma,pi*0.5_preal,tol=1.0e-15_preal))
  
  if (deq0(alpha)) then                                                                             ! return a default identity axis-angle pair
    ax = [ 0.0_preal, 0.0_preal, 1.0_preal, 0.0_preal ]
  else
    ax(1:3) = -p/tau * [ t*cos(delta), t*sin(delta), sin(sigma) ]                                   ! passive axis-angle pair so a minus sign in front
    ax(4) = alpha
    if (alpha < 0.0_preal) ax = -ax                                                                 ! ensure alpha is positive
  end if
 
end function eu2ax
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function eu2ro(eu) result(ro)
 
  real(preal), intent(in), dimension(3) :: eu
  real(preal),             dimension(4) :: ro
  
  ro = eu2ax(eu)
  if (ro(4) >= pi) then
    ro(4) = ieee_value(ro(4),ieee_positive_inf)
  elseif(deq0(ro(4))) then
    ro = [ 0.0_preal, 0.0_preal, p, 0.0_preal ]
  else
    ro(4) = tan(ro(4)*0.5_preal)
  end if
 
end function eu2ro
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function eu2ho(eu) result(ho)
 
  real(preal), intent(in), dimension(3) :: eu
  real(preal),             dimension(3) :: ho
 
  ho = ax2ho(eu2ax(eu))
 
end function eu2ho
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
function eu2cu(eu) result(cu)
 
  real(preal), intent(in), dimension(3) :: eu
  real(preal),             dimension(3) :: cu
 
  cu = ho2cu(eu2ho(eu))
 
end function eu2cu
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function ax2qu(ax) result(qu)
    
  real(preal), intent(in), dimension(4) :: ax
  real(preal),             dimension(4) :: qu
 
  real(preal)                           :: c, s
 
 
  if (deq0(ax(4))) then
    qu = [ 1.0_preal, 0.0_preal, 0.0_preal, 0.0_preal ]
  else
    c = cos(ax(4)*0.5_preal)
    s = sin(ax(4)*0.5_preal)
    qu = [ c, ax(1)*s, ax(2)*s, ax(3)*s ]
  end if
 
end function ax2qu
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function ax2om(ax) result(om)
 
  real(preal), intent(in), dimension(4)   :: ax
  real(preal),             dimension(3,3) :: om
  
  real(preal)                             :: q, c, s, omc
 
  c = cos(ax(4))
  s = sin(ax(4))
  omc = 1.0_preal-c
 
  om(1,1) = ax(1)**2*omc + c
  om(2,2) = ax(2)**2*omc + c
  om(3,3) = ax(3)**2*omc + c
 
  q = omc*ax(1)*ax(2)
  om(1,2) = q + s*ax(3)
  om(2,1) = q - s*ax(3)
  
  q = omc*ax(2)*ax(3)
  om(2,3) = q + s*ax(1)
  om(3,2) = q - s*ax(1)
  
  q = omc*ax(3)*ax(1)
  om(3,1) = q + s*ax(2)
  om(1,3) = q - s*ax(2)
 
  if (p > 0.0_preal) om = transpose(om)
 
end function ax2om
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function ax2eu(ax) result(eu)
 
  real(preal), intent(in), dimension(4) :: ax
  real(preal),             dimension(3) :: eu
 
  eu = om2eu(ax2om(ax))
 
end function ax2eu
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function ax2ro(ax) result(ro)
 
  real(preal), intent(in), dimension(4) :: ax
  real(preal),             dimension(4) :: ro
  
  real(preal), parameter                :: thr = 1.0e-7_preal
  
  if (deq0(ax(4))) then
    ro = [ 0.0_preal, 0.0_preal, p, 0.0_preal ]
  else 
    ro(1:3) =  ax(1:3)
    ! we need to deal with the 180 degree case
    ro(4) = merge(ieee_value(ro(4),ieee_positive_inf),tan(ax(4)*0.5_preal),abs(ax(4)-pi) < thr)
  end if
 
end function ax2ro
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function ax2ho(ax) result(ho)
 
  real(preal), intent(in), dimension(4) :: ax
  real(preal),             dimension(3) :: ho
  
  real(preal)                           :: f
  
  f = 0.75_preal * ( ax(4) - sin(ax(4)) )
  f = f**(1.0_preal/3.0_preal)
  ho = ax(1:3) * f
 
end function ax2ho
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
function ax2cu(ax) result(cu)
 
  real(preal), intent(in), dimension(4) :: ax
  real(preal),             dimension(3) :: cu
 
  cu  = ho2cu(ax2ho(ax))
 
end function ax2cu
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function ro2qu(ro) result(qu)
 
  real(preal), intent(in), dimension(4) :: ro
  real(preal),             dimension(4) :: qu
  
  qu = ax2qu(ro2ax(ro))
 
end function ro2qu
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function ro2om(ro) result(om)
 
  real(preal), intent(in), dimension(4)   :: ro
  real(preal),             dimension(3,3) :: om
 
  om = ax2om(ro2ax(ro))
 
end function ro2om
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function ro2eu(ro) result(eu)
 
  real(preal), intent(in), dimension(4) :: ro
  real(preal),             dimension(3) :: eu
         
  eu = om2eu(ro2om(ro))
 
end function ro2eu
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function ro2ax(ro) result(ax)
 
  real(preal), intent(in), dimension(4) :: ro
  real(preal),             dimension(4) :: ax
  
  real(preal)                           :: ta, angle
  
  ta = ro(4)
  
  if (.not. ieee_is_finite(ta)) then
    ax = [ ro(1), ro(2), ro(3), pi ]
  elseif (deq0(ta))  then 
    ax = [ 0.0_preal, 0.0_preal, 1.0_preal, 0.0_preal ]
  else
    angle = 2.0_preal*atan(ta)
    ta = 1.0_preal/norm2(ro(1:3))
    ax = [ ro(1)/ta, ro(2)/ta, ro(3)/ta, angle ]
  end if
 
end function ro2ax
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function ro2ho(ro) result(ho)
 
  real(preal), intent(in), dimension(4) :: ro
  real(preal),             dimension(3) :: ho
  
  real(preal)                           :: f
  
  if (deq0(norm2(ro(1:3)))) then
    ho = [ 0.0_preal, 0.0_preal, 0.0_preal ]
  else
    f = merge(2.0_preal*atan(ro(4)) - sin(2.0_preal*atan(ro(4))),pi, ieee_is_finite(ro(4)))
    ho = ro(1:3) * (0.75_preal*f)**(1.0_preal/3.0_preal)
  end if
 
end function ro2ho
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function ro2cu(ro) result(cu)
 
  real(preal), intent(in), dimension(4) :: ro
  real(preal),             dimension(3) :: cu
 
  cu = ho2cu(ro2ho(ro))
 
end function ro2cu
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function ho2qu(ho) result(qu)
 
  real(preal), intent(in), dimension(3) :: ho
  real(preal),             dimension(4) :: qu
 
  qu = ax2qu(ho2ax(ho))
 
end function ho2qu
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function ho2om(ho) result(om)
 
  real(preal), intent(in), dimension(3)   :: ho
  real(preal),             dimension(3,3) :: om
 
  om = ax2om(ho2ax(ho))
 
end function ho2om
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function ho2eu(ho) result(eu)
 
  real(preal), intent(in), dimension(3) :: ho
  real(preal),             dimension(3) :: eu
 
  eu = ax2eu(ho2ax(ho))
 
end function ho2eu
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function ho2ax(ho) result(ax)
 
  real(preal), intent(in), dimension(3) :: ho
  real(preal),             dimension(4) :: ax
  
  integer                               :: i
  real(preal)                           :: hmag_squared, s, hm
  real(preal), parameter, dimension(16) :: &
    tfit = [ 1.0000000000018852_preal,      -0.5000000002194847_preal, & 
            -0.024999992127593126_preal,    -0.003928701544781374_preal, & 
            -0.0008152701535450438_preal,   -0.0002009500426119712_preal, & 
            -0.00002397986776071756_preal,  -0.00008202868926605841_preal, & 
            +0.00012448715042090092_preal,  -0.0001749114214822577_preal, & 
            +0.0001703481934140054_preal,   -0.00012062065004116828_preal, & 
            +0.000059719705868660826_preal, -0.00001980756723965647_preal, & 
            +0.000003953714684212874_preal, -0.00000036555001439719544_preal ]
  
  ! normalize h and store the magnitude
  hmag_squared = sum(ho**2.0_preal)
  if (deq0(hmag_squared)) then
    ax = [ 0.0_preal, 0.0_preal, 1.0_preal, 0.0_preal ]
  else
    hm = hmag_squared
  
  ! convert the magnitude to the rotation angle
    s = tfit(1) + tfit(2) * hmag_squared
    do i=3,16
      hm = hm*hmag_squared
      s  = s + tfit(i) * hm
    end do
    ax = [ho/sqrt(hmag_squared), 2.0_preal*acos(s)]
  end if
 
end function ho2ax
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function ho2ro(ho) result(ro)
 
  real(preal), intent(in), dimension(3) :: ho
  real(preal),             dimension(4) :: ro
 
  ro = ax2ro(ho2ax(ho))
 
end function ho2ro
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function ho2cu(ho) result(cu)
 
  real(preal), intent(in), dimension(3) :: ho
  real(preal),             dimension(3) :: cu
 
  cu = lambert_balltocube(ho)
 
end function ho2cu
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function cu2qu(cu) result(qu)
 
  real(preal), intent(in), dimension(3) :: cu
  real(preal),             dimension(4) :: qu
 
  qu = ho2qu(cu2ho(cu))
 
end function cu2qu
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function cu2om(cu) result(om)
 
  real(preal), intent(in), dimension(3)   :: cu
  real(preal),             dimension(3,3) :: om
 
  om = ho2om(cu2ho(cu))
 
end function cu2om
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function cu2eu(cu) result(eu)
 
  real(preal), intent(in), dimension(3) :: cu
  real(preal),             dimension(3) :: eu
 
  eu = ho2eu(cu2ho(cu))
 
end function cu2eu
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
function cu2ax(cu) result(ax)
 
  real(preal), intent(in), dimension(3) :: cu
  real(preal),             dimension(4) :: ax
 
  ax = ho2ax(cu2ho(cu))
 
end function cu2ax
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function cu2ro(cu) result(ro)
 
  real(preal), intent(in), dimension(3) :: cu
  real(preal),             dimension(4) :: ro
 
  ro = ho2ro(cu2ho(cu))
 
end function cu2ro
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
pure function cu2ho(cu) result(ho)
 
  real(preal), intent(in), dimension(3) :: cu
  real(preal),             dimension(3) :: ho
 
  ho = lambert_cubetoball(cu)
 
end function cu2ho
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine unittest
  
  type(rotation)                  :: R
  real(pReal), dimension(4)       :: qu, ax, ro
  real(pReal), dimension(3)       :: x, eu, ho, v3
  real(pReal), dimension(3,3)     :: om, t33
  real(pReal), dimension(3,3,3,3) :: t3333
  character(len=pStringLen)       :: msg
  real    :: A,B
  integer :: i
 
  do i=1,10
  
    msg = ''
 
 
    if(i<7) cycle
 
 
    if(i==1) then
      qu = om2qu(math_i3)
    elseif(i==2) then
      qu = eu2qu([0.0_preal,0.0_preal,0.0_preal])
    elseif(i==3) then
      qu = eu2qu([2.0_preal*pi,pi,2.0_preal*pi])
    elseif(i==4) then
      qu = [0.0_preal,0.0_preal,1.0_preal,0.0_preal]
    elseif(i==5) then
      qu = ro2qu([1.0_preal,0.0_preal,0.0_preal,ieee_value(1.0_preal, ieee_positive_inf)])
    elseif(i==6) then
      qu = ax2qu([1.0_preal,0.0_preal,0.0_preal,0.0_preal])
    else
      call random_number(x)
      a = sqrt(x(3))
      b = sqrt(1-0_preal -x(3))
      qu = [cos(2.0_preal*pi*x(1))*a,&
            sin(2.0_preal*pi*x(2))*b,&
            cos(2.0_preal*pi*x(2))*b,&
            sin(2.0_preal*pi*x(1))*a]
      if(qu(1)<0.0_preal) qu = qu * (-1.0_preal)
    endif
 
    if(dneq0(norm2(om2qu(qu2om(qu))-qu),1.0e-12_preal)) msg = trim(msg)//'om2qu/qu2om,'
    if(dneq0(norm2(eu2qu(qu2eu(qu))-qu),1.0e-12_preal)) msg = trim(msg)//'eu2qu/qu2eu,'
    if(dneq0(norm2(ax2qu(qu2ax(qu))-qu),1.0e-12_preal)) msg = trim(msg)//'ax2qu/qu2ax,'
    if(dneq0(norm2(ro2qu(qu2ro(qu))-qu),1.0e-12_preal)) msg = trim(msg)//'ro2qu/qu2ro,'
    if(dneq0(norm2(ho2qu(qu2ho(qu))-qu),1.0e-7_preal))  msg = trim(msg)//'ho2qu/qu2ho,'
    if(dneq0(norm2(cu2qu(qu2cu(qu))-qu),1.0e-7_preal))  msg = trim(msg)//'cu2qu/qu2cu,'
 
 
    om = qu2om(qu)
 
    if(dneq0(norm2(om2qu(eu2om(om2eu(om)))-qu),1.0e-7_preal))  msg = trim(msg)//'eu2om/om2eu,'
    if(dneq0(norm2(om2qu(ax2om(om2ax(om)))-qu),1.0e-7_preal))  msg = trim(msg)//'ax2om/om2ax,'
    if(dneq0(norm2(om2qu(ro2om(om2ro(om)))-qu),1.0e-12_preal)) msg = trim(msg)//'ro2om/om2ro,'
    if(dneq0(norm2(om2qu(ho2om(om2ho(om)))-qu),1.0e-7_preal))  msg = trim(msg)//'ho2om/om2ho,'
    if(dneq0(norm2(om2qu(cu2om(om2cu(om)))-qu),1.0e-7_preal))  msg = trim(msg)//'cu2om/om2cu,'
 
 
    eu = qu2eu(qu)
 
    if(dneq0(norm2(eu2qu(ax2eu(eu2ax(eu)))-qu),1.0e-12_preal)) msg = trim(msg)//'ax2eu/eu2ax,'
    if(dneq0(norm2(eu2qu(ro2eu(eu2ro(eu)))-qu),1.0e-12_preal)) msg = trim(msg)//'ro2eu/eu2ro,'
    if(dneq0(norm2(eu2qu(ho2eu(eu2ho(eu)))-qu),1.0e-7_preal))  msg = trim(msg)//'ho2eu/eu2ho,'
    if(dneq0(norm2(eu2qu(cu2eu(eu2cu(eu)))-qu),1.0e-7_preal))  msg = trim(msg)//'cu2eu/eu2cu,'
 
 
    ax = qu2ax(qu)
 
    if(dneq0(norm2(ax2qu(ro2ax(ax2ro(ax)))-qu),1.0e-12_preal)) msg = trim(msg)//'ro2ax/ax2ro,'
    if(dneq0(norm2(ax2qu(ho2ax(ax2ho(ax)))-qu),1.0e-7_preal))  msg = trim(msg)//'ho2ax/ax2ho,'
    if(dneq0(norm2(ax2qu(cu2ax(ax2cu(ax)))-qu),1.0e-7_preal))  msg = trim(msg)//'cu2ax/ax2cu,'
 
 
    ro = qu2ro(qu)
 
    if(dneq0(norm2(ro2qu(ho2ro(ro2ho(ro)))-qu),1.0e-7_preal))  msg = trim(msg)//'ho2ro/ro2ho,'
    if(dneq0(norm2(ro2qu(cu2ro(ro2cu(ro)))-qu),1.0e-7_preal))  msg = trim(msg)//'cu2ro/ro2cu,'
 
 
    ho = qu2ho(qu)
 
    if(dneq0(norm2(ho2qu(cu2ho(ho2cu(ho)))-qu),1.0e-7_preal))  msg = trim(msg)//'cu2ho/ho2cu,'
 
 
    call r%fromMatrix(om)
    
    call random_number(v3)
    if(all(dneq(r%rotVector(r%rotVector(v3),active=.true.),v3,1.0e-12_preal))) &
      msg = trim(msg)//'rotVector,'
    
    call random_number(t33)
    if(all(dneq(r%rotTensor2(r%rotTensor2(t33),active=.true.),t33,1.0e-12_preal))) &
      msg = trim(msg)//'rotTensor2,'
    
    call random_number(t3333)
    if(all(dneq(r%rotTensor4(r%rotTensor4(t3333),active=.true.),t3333,1.0e-12_preal))) &
      msg = trim(msg)//'rotTensor4,'
 
    if(len_trim(msg) /= 0) call io_error(0,ext_msg=msg)
 
  enddo
 
end subroutine unittest
 
 
end module rotations
# 16 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/FEsolving.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module fesolving
   
  implicit none
  public
 
  logical :: &
    terminallyill = .false.                                                                         
 
  integer, dimension(2) :: &
    fesolving_execelem, &                                                                           !< for ping-pong scheme always whole range, otherwise one specific element
    fesolving_execip
    
 
  logical, dimension(:,:), allocatable :: &
    calcmode
 
 
end module fesolving
# 17 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/element.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module element
  use io
 
  implicit none
  private 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
  type, public :: telement
    integer :: &
      elemtype, &
      geomtype, &                                                                                   !< geometry type (same for same dimension and same number of integration points)
      celltype, &
      nnodes, &
      ncellnodes, &
      ncellnodespercell, &
      nips, &
      nipneighbors
    character(len=:),        allocatable :: &
      vtktype
    integer, dimension(:,:), allocatable :: &
      cell, &                                                                                       !< intra-element (cell) nodes that constitute a cell
      ipneighbor, &
      cellface
    integer, dimension(:,:), allocatable :: &
      ! center of gravity of the weighted nodes gives the position of the cell node.
      ! example: face-centered cell node with face nodes 1,2,5,6 to be used in,
      !          e.g., an 8 node element, would be encoded: 1, 1, 0, 0, 1, 1, 0, 0
      cellnodeparentnodeweights
    contains
      procedure :: init => telement_init
  end type telement
 
 
  integer, parameter :: &
    nelemtype = 13
 
  integer, dimension(NELEMTYPE), parameter :: nnode = &
    [ &
        3, & ! 2D, 1 IP
        6, & ! 2D, 3 IP
        4, & ! 2D, 4 IP
        8, & ! 2D, 9 IP
        8, & ! 2D, 4 IP
        !----------------------
        4, & ! 3D, 1 IP
        5, & ! 3D, 4 IP
       10, & ! 3D, 4 IP
        6, & ! 3D, 6 IP
        8, & ! 3D, 1 IP
        8, & ! 3D, 8 IP
       20, & ! 3D, 8 IP
       20  & ! 3D, 27 IP
    ]                                                                                               
 
  integer, dimension(NELEMTYPE), parameter :: geomtype = &
    [ &
        1, & ! 1 triangle
        2, & ! 3 quadrilaterals
        3, & ! 4 quadrilaterals
        4, & ! 9 quadrilaterals
        3, & ! 4 quadrilaterals
        !----------------------
        5, & ! 1 tetrahedron
        6, & ! 4 hexahedrons
        6, & ! 4 hexahedrons
        7, & ! 6 hexahedrons
        8, & ! 1 hexahedron
        9, & ! 8 hexahedrons
        9, & ! 8 hexahedrons
       10  & ! 27 hexahedrons
    ]                                                                                               
 
  integer, dimension(maxval(GEOMTYPE)), parameter :: ncellnode = &
    [ &
        3, &
        7, &
        9, &
       16, &
        4, &
       15, &
       21, &
        8, &
       27, &
       64  &
    ]
 
  integer, dimension(maxval(GEOMTYPE)), parameter :: nip = &
    [ &
        1, & 
        3, & 
        4, & 
        9, & 
        1, & 
        4, & 
        6, & 
        1, & 
        8, & 
       27  & 
    ]
 
  integer, dimension(maxval(GEOMTYPE)), parameter :: celltype = &
    [ &
       1, & ! 2D, 3 node (Triangle)
       2, & ! 2D, 4 node (Quadrilateral)
       2, & !   - " -
       2, & !   - " -
       3, & ! 3D, 4 node (Tetrahedron)
       4, & ! 3D, 4 node (Hexahedron)
       4, & !   - " -
       4, & !   - " -
       4, & !   - " -
       4  & !   - " -
    ]
 
  integer, dimension(maxval(CELLTYPE)), parameter :: nipneighbor = &
    [ &
       3, &
       4, &
       4, &
       6  &
    ]
 
  integer, dimension(maxval(CELLTYPE)), parameter :: ncellnodepercellface = &
    [ &
       2, &
       2, &
       3, &
       4  &
    ]
 
  integer, dimension(maxval(CELLTYPE)), parameter  :: ncellnodepercell = &
    [ &
       3, &
       4, &
       4, &
       8  &
    ]
 
  ! *** IPneighbor ***
  ! list of the neighborhood of each IP.
  ! It is sorted in (local) +x,-x, +y,-y, +z,-z direction.
  ! Positive integers denote an intra-element IP identifier.
  ! Negative integers denote the interface behind which the neighboring (extra-element) IP will be located.
 
  integer, dimension(NIPNEIGHBOR(CELLTYPE(1)),NIP(1)),   parameter :: ipneighbor1 = &
    reshape([&
      -2,-3,-1  &
 
 
 
    ],[nipneighbor(celltype(1)),nip(1)])
 
 
  integer, dimension(NIPNEIGHBOR(CELLTYPE(2)),NIP(2)),   parameter :: ipneighbor2 = &
    reshape([&
       2,-3, 3,-1, &
      -2, 1, 3,-1, &
       2,-3,-2, 1  &
 
 
 
    ],[nipneighbor(celltype(2)),nip(2)])
 
  
  integer, dimension(NIPNEIGHBOR(CELLTYPE(3)),NIP(3)),   parameter :: ipneighbor3 = &
    reshape([&
       2,-4, 3,-1, &
      -2, 1, 4,-1, &
       4,-4,-3, 1, &
      -2, 3,-3, 2  &
 
 
 
    ],[nipneighbor(celltype(3)),nip(3)])
 
  
  integer, dimension(NIPNEIGHBOR(CELLTYPE(4)),NIP(4)),   parameter :: ipneighbor4 = &
    reshape([&
       2,-4, 4,-1, &
       3, 1, 5,-1, &
      -2, 2, 6,-1, &
       5,-4, 7, 1, &
       6, 4, 8, 2, &
      -2, 5, 9, 3, &
       8,-4,-3, 4, &
       9, 7,-3, 5, &
      -2, 8,-3, 6  &
 
 
 
    ],[nipneighbor(celltype(4)),nip(4)])
 
  
  integer, dimension(NIPNEIGHBOR(CELLTYPE(5)),NIP(5)),   parameter :: ipneighbor5 = &
    reshape([&
      -1,-2,-3,-4 &
 
 
 
    ],[nipneighbor(celltype(5)),nip(5)])
 
  
  integer, dimension(NIPNEIGHBOR(CELLTYPE(6)),NIP(6)),   parameter :: ipneighbor6 = &
    reshape([&
       2,-4, 3,-2, 4,-1, &
      -2, 1, 3,-2, 4,-1, &
       2,-4,-3, 1, 4,-1, &
       2,-4, 3,-2,-3, 1  &
 
 
 
    ],[nipneighbor(celltype(6)),nip(6)])
 
  
  integer, dimension(NIPNEIGHBOR(CELLTYPE(7)),NIP(7)),   parameter :: ipneighbor7 = &
    reshape([&
       2,-4, 3,-2, 4,-1, &
      -3, 1, 3,-2, 5,-1, &
       2,-4,-3, 1, 6,-1, &
       5,-4, 6,-2,-5, 1, &
      -3, 4, 6,-2,-5, 2, &
       5,-4,-3, 4,-5, 3  &
 
 
 
    ],[nipneighbor(celltype(7)),nip(7)])
 
  
  integer, dimension(NIPNEIGHBOR(CELLTYPE(8)),NIP(8)),   parameter :: ipneighbor8 = &
    reshape([&
      -3,-5,-4,-2,-6,-1  &
 
 
 
    ],[nipneighbor(celltype(8)),nip(8)])
 
  
  integer, dimension(NIPNEIGHBOR(CELLTYPE(9)),NIP(9)),   parameter :: ipneighbor9 = &
    reshape([&
       2,-5, 3,-2, 5,-1, &
      -3, 1, 4,-2, 6,-1, &
       4,-5,-4, 1, 7,-1, &
      -3, 3,-4, 2, 8,-1, &
       6,-5, 7,-2,-6, 1, &
      -3, 5, 8,-2,-6, 2, &
       8,-5,-4, 5,-6, 3, &
      -3, 7,-4, 6,-6, 4  &
 
 
 
    ],[nipneighbor(celltype(9)),nip(9)])
 
  
  integer, dimension(NIPNEIGHBOR(CELLTYPE(10)),NIP(10)), parameter :: ipneighbor10 = &
    reshape([&
       2,-5, 4,-2,10,-1, &
       3, 1, 5,-2,11,-1, &
      -3, 2, 6,-2,12,-1, &
       5,-5, 7, 1,13,-1, &
       6, 4, 8, 2,14,-1, &
      -3, 5, 9, 3,15,-1, &
       8,-5,-4, 4,16,-1, &
       9, 7,-4, 5,17,-1, &
      -3, 8,-4, 6,18,-1, &
      11,-5,13,-2,19, 1, &
      12,10,14,-2,20, 2, &
      -3,11,15,-2,21, 3, &
      14,-5,16,10,22, 4, &
      15,13,17,11,23, 5, &
      -3,14,18,12,24, 6, &
      17,-5,-4,13,25, 7, &
      18,16,-4,14,26, 8, &
      -3,17,-4,15,27, 9, &
      20,-5,22,-2,-6,10, &
      21,19,23,-2,-6,11, &
      -3,20,24,-2,-6,12, &
      23,-5,25,19,-6,13, &
      24,22,26,20,-6,14, &
      -3,23,27,21,-6,15, &
      26,-5,-4,22,-6,16, &
      27,25,-4,23,-6,17, &
      -3,26,-4,24,-6,18  &
 
 
 
    ],[nipneighbor(celltype(10)),nip(10)])
 
 
 
  integer, dimension(NNODE(1),NCELLNODE(GEOMTYPE(1))),   parameter :: cellnodeparentnodeweights1 = &
    reshape([&
      1, 0, 0, &
      0, 1, 0, &
      0, 0, 1  &
 
 
 
    ],[nnode(1),ncellnode(geomtype(1))])
 
 
  integer, dimension(NNODE(2),NCELLNODE(GEOMTYPE(2))),   parameter :: cellnodeparentnodeweights2 = &
    reshape([&
      1, 0, 0, 0, 0, 0, &
      0, 1, 0, 0, 0, 0, &
      0, 0, 1, 0, 0, 0, &
      0, 0, 0, 1, 0, 0, &
      0, 0, 0, 0, 1, 0, &
      0, 0, 0, 0, 0, 1, &
      1, 1, 1, 2, 2, 2  &
 
 
 
    ],[nnode(2),ncellnode(geomtype(2))])
 
 
  integer, dimension(NNODE(3),NCELLNODE(GEOMTYPE(3))),   parameter :: cellnodeparentnodeweights3 = &
    reshape([&
      1, 0, 0, 0, &
      0, 1, 0, 0, &
      0, 0, 1, 0, &
      0, 0, 0, 1, &
      1, 1, 0, 0, &
      0, 1, 1, 0, &
      0, 0, 1, 1, &
      1, 0, 0, 1, &
      1, 1, 1, 1  &
 
 
 
    ],[nnode(3),ncellnode(geomtype(3))])
 
 
  integer, dimension(NNODE(4),NCELLNODE(GEOMTYPE(4))),   parameter :: cellnodeparentnodeweights4 = &
    reshape([&
      1, 0, 0, 0, 0, 0, 0, 0, &
      0, 1, 0, 0, 0, 0, 0, 0, &
      0, 0, 1, 0, 0, 0, 0, 0, &
      0, 0, 0, 1, 0, 0, 0, 0, &
      1, 0, 0, 0, 2, 0, 0, 0, &
      0, 1, 0, 0, 2, 0, 0, 0, &
      0, 1, 0, 0, 0, 2, 0, 0, &
      0, 0, 1, 0, 0, 2, 0, 0, &
      0, 0, 1, 0, 0, 0, 2, 0, &
      0, 0, 0, 1, 0, 0, 2, 0, &
      0, 0, 0, 1, 0, 0, 0, 2, &
      1, 0, 0, 0, 0, 0, 0, 2, &
      4, 1, 1, 1, 8, 2, 2, 8, &
      1, 4, 1, 1, 8, 8, 2, 2, &
      1, 1, 4, 1, 2, 8, 8, 2, &
      1, 1, 1, 4, 2, 2, 8, 8  &
 
 
 
    ],[nnode(4),ncellnode(geomtype(4))])
 
 
  integer, dimension(NNODE(5),NCELLNODE(GEOMTYPE(5))),   parameter :: cellnodeparentnodeweights5 = &
    reshape([&
      1, 0, 0, 0, 0, 0, 0, 0, &
      0, 1, 0, 0, 0, 0, 0, 0, &
      0, 0, 1, 0, 0, 0, 0, 0, &
      0, 0, 0, 1, 0, 0, 0, 0, &
      0, 0, 0, 0, 1, 0, 0, 0, &
      0, 0, 0, 0, 0, 1, 0, 0, &
      0, 0, 0, 0, 0, 0, 1, 0, &
      0, 0, 0, 0, 0, 0, 0, 1, &
      1, 1, 1, 1, 2, 2, 2, 2  &
 
 
 
    ],[nnode(5),ncellnode(geomtype(5))])
 
 
  integer, dimension(NNODE(6),NcellNode(GEOMTYPE(6))),   parameter :: cellnodeparentnodeweights6 = &
    reshape([&
      1, 0, 0, 0, &
      0, 1, 0, 0, &
      0, 0, 1, 0, &
      0, 0, 0, 1  &
 
 
 
    ],[nnode(6),ncellnode(geomtype(6))])
 
 
  integer, dimension(NNODE(7),NCELLNODE(GEOMTYPE(7))),   parameter :: cellnodeparentnodeweights7 = &
    reshape([&
      1, 0, 0, 0, 0, &
      0, 1, 0, 0, 0, &
      0, 0, 1, 0, 0, &
      0, 0, 0, 1, 0, &
      1, 1, 0, 0, 0, &
      0, 1, 1, 0, 0, &
      1, 0, 1, 0, 0, &
      1, 0, 0, 1, 0, &
      0, 1, 0, 1, 0, &
      0, 0, 1, 1, 0, &
      1, 1, 1, 0, 0, &
      1, 1, 0, 1, 0, &
      0, 1, 1, 1, 0, &
      1, 0, 1, 1, 0, &
      0, 0, 0, 0, 1  &
 
 
 
    ],[nnode(7),ncellnode(geomtype(7))])
 
 
  integer, dimension(NNODE(8),NCELLNODE(GEOMTYPE(8))),   parameter :: cellnodeparentnodeweights8 = &
    reshape([&
      1, 0, 0, 0, 0, 0, 0, 0, 0, 0, &
      0, 1, 0, 0, 0, 0, 0, 0, 0, 0, &
      0, 0, 1, 0, 0, 0, 0, 0, 0, 0, &
      0, 0, 0, 1, 0, 0, 0, 0, 0, 0, &
      0, 0, 0, 0, 1, 0, 0, 0, 0, 0, &
      0, 0, 0, 0, 0, 1, 0, 0, 0, 0, &
      0, 0, 0, 0, 0, 0, 1, 0, 0, 0, &
      0, 0, 0, 0, 0, 0, 0, 1, 0, 0, &
      0, 0, 0, 0, 0, 0, 0, 0, 1, 0, &
      0, 0, 0, 0, 0, 0, 0, 0, 0, 1, &
      1, 1, 1, 0, 2, 2, 2, 0, 0, 0, &
      1, 1, 0, 1, 2, 0, 0, 2, 2, 0, &
      0, 1, 1, 1, 0, 2, 0, 0, 2, 2, &
      1, 0, 1, 1, 0, 0, 2, 2, 0, 2, &
      3, 3, 3, 3, 4, 4, 4, 4, 4, 4  &
 
 
 
    ],[nnode(8),ncellnode(geomtype(8))])
 
 
  integer, dimension(NNODE(9),NCELLNODE(GEOMTYPE(9))),   parameter :: cellnodeparentnodeweights9 = &
    reshape([&
      1, 0, 0, 0, 0, 0, &
      0, 1, 0, 0, 0, 0, &
      0, 0, 1, 0, 0, 0, &
      0, 0, 0, 1, 0, 0, &
      0, 0, 0, 0, 1, 0, &
      0, 0, 0, 0, 0, 1, &
      1, 1, 0, 0, 0, 0, &
      0, 1, 1, 0, 0, 0, &
      1, 0, 1, 0, 0, 0, &
      1, 0, 0, 1, 0, 0, &
      0, 1, 0, 0, 1, 0, &
      0, 0, 1, 0, 0, 1, &
      0, 0, 0, 1, 1, 0, &
      0, 0, 0, 0, 1, 1, &
      0, 0, 0, 1, 0, 1, &
      1, 1, 1, 0, 0, 0, &
      1, 1, 0, 1, 1, 0, &
      0, 1, 1, 0, 1, 1, &
      1, 0, 1, 1, 0, 1, &
      0, 0, 0, 1, 1, 1, &
      1, 1, 1, 1, 1, 1  &
 
 
 
    ],[nnode(9),ncellnode(geomtype(9))])
 
 
  integer, dimension(NNODE(10),NCELLNODE(GEOMTYPE(10))), parameter :: cellnodeparentnodeweights10 = &
    reshape([&
      1, 0, 0, 0, 0, 0, 0, 0, &
      0, 1, 0, 0, 0, 0, 0, 0, &
      0, 0, 1, 0, 0, 0, 0, 0, &
      0, 0, 0, 1, 0, 0, 0, 0, &
      0, 0, 0, 0, 1, 0, 0, 0, &
      0, 0, 0, 0, 0, 1, 0, 0, &
      0, 0, 0, 0, 0, 0, 1, 0, &
      0, 0, 0, 0, 0, 0, 0, 1  &
 
 
 
    ],[nnode(10),ncellnode(geomtype(10))])
 
  
  integer, dimension(NNODE(11),NCELLNODE(GEOMTYPE(11))), parameter :: cellnodeparentnodeweights11 = &
    reshape([&
      1, 0, 0, 0,  0, 0, 0, 0, &   !
      0, 1, 0, 0,  0, 0, 0, 0, &   !
      0, 0, 1, 0,  0, 0, 0, 0, &   !
      0, 0, 0, 1,  0, 0, 0, 0, &   !
      0, 0, 0, 0,  1, 0, 0, 0, &   !  5
      0, 0, 0, 0,  0, 1, 0, 0, &   !
      0, 0, 0, 0,  0, 0, 1, 0, &   !
      0, 0, 0, 0,  0, 0, 0, 1, &   !
      1, 1, 0, 0,  0, 0, 0, 0, &   !
      0, 1, 1, 0,  0, 0, 0, 0, &   ! 10
      0, 0, 1, 1,  0, 0, 0, 0, &   !
      1, 0, 0, 1,  0, 0, 0, 0, &   !
      0, 0, 0, 0,  1, 1, 0, 0, &   !
      0, 0, 0, 0,  0, 1, 1, 0, &   !
      0, 0, 0, 0,  0, 0, 1, 1, &   ! 15
      0, 0, 0, 0,  1, 0, 0, 1, &   !
      1, 0, 0, 0,  1, 0, 0, 0, &   !
      0, 1, 0, 0,  0, 1, 0, 0, &   !
      0, 0, 1, 0,  0, 0, 1, 0, &   !
      0, 0, 0, 1,  0, 0, 0, 1, &   ! 20
      1, 1, 1, 1,  0, 0, 0, 0, &   !
      1, 1, 0, 0,  1, 1, 0, 0, &   !
      0, 1, 1, 0,  0, 1, 1, 0, &   !
      0, 0, 1, 1,  0, 0, 1, 1, &   !
      1, 0, 0, 1,  1, 0, 0, 1, &   ! 25
      0, 0, 0, 0,  1, 1, 1, 1, &   !
      1, 1, 1, 1,  1, 1, 1, 1  &   !
 
 
 
    ],[nnode(11),ncellnode(geomtype(11))])
 
  
  integer, dimension(NNODE(12),NCELLNODE(GEOMTYPE(12))), parameter :: cellnodeparentnodeweights12 = &
    reshape([&
      1, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0, &   !
      0, 1, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0, &   !
      0, 0, 1, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0, &   !
      0, 0, 0, 1,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0, &   !
      0, 0, 0, 0,  1, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0, &   !  5
      0, 0, 0, 0,  0, 1, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0, &   !
      0, 0, 0, 0,  0, 0, 1, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0, &   !
      0, 0, 0, 0,  0, 0, 0, 1,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0, &   !
      0, 0, 0, 0,  0, 0, 0, 0,  1, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0, &   !
      0, 0, 0, 0,  0, 0, 0, 0,  0, 1, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0, &   ! 10
      0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 1, 0,  0, 0, 0, 0,  0, 0, 0, 0, &   !
      0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 1,  0, 0, 0, 0,  0, 0, 0, 0, &   !
      0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  1, 0, 0, 0, &   !
      0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 1, 0, 0, &   !
      0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 1, 0, &   ! 15
      0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 1, &   !
      0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  1, 0, 0, 0,  0, 0, 0, 0, &   !
      0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 1, 0, 0,  0, 0, 0, 0, &   !
      0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 1, 0,  0, 0, 0, 0, &   !
      0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 1,  0, 0, 0, 0, &   ! 20
      1, 1, 1, 1,  0, 0, 0, 0,  2, 2, 2, 2,  0, 0, 0, 0,  0, 0, 0, 0, &   !
      1, 1, 0, 0,  1, 1, 0, 0,  2, 0, 0, 0,  2, 0, 0, 0,  2, 2, 0, 0, &   !
      0, 1, 1, 0,  0, 1, 1, 0,  0, 2, 0, 0,  0, 2, 0, 0,  0, 2, 2, 0, &   !
      0, 0, 1, 1,  0, 0, 1, 1,  0, 0, 2, 0,  0, 0, 2, 0,  0, 0, 2, 2, &   !
      1, 0, 0, 1,  1, 0, 0, 1,  0, 0, 0, 2,  0, 0, 0, 2,  2, 0, 0, 2, &   ! 25
      0, 0, 0, 0,  1, 1, 1, 1,  0, 0, 0, 0,  2, 2, 2, 2,  0, 0, 0, 0, &   !
      3, 3, 3, 3,  3, 3, 3, 3,  4, 4, 4, 4,  4, 4, 4, 4,  4, 4, 4, 4  &   !
 
 
 
    ],[nnode(12),ncellnode(geomtype(12))])
 
  
  integer, dimension(NNODE(13),NCELLNODE(GEOMTYPE(13))), parameter :: cellnodeparentnodeweights13 = &
    reshape([&
       1, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0, &   !
       0, 1, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0, &   !
       0, 0, 1, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0, &   !
       0, 0, 0, 1,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0, &   !
       0, 0, 0, 0,  1, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0, &   !  5
       0, 0, 0, 0,  0, 1, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0, &   !
       0, 0, 0, 0,  0, 0, 1, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0, &   !
       0, 0, 0, 0,  0, 0, 0, 1,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0, &   !
       1, 0, 0, 0,  0, 0, 0, 0,  2, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0, &   !
       0, 1, 0, 0,  0, 0, 0, 0,  2, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0, &   ! 10
       0, 1, 0, 0,  0, 0, 0, 0,  0, 2, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0, &   !
       0, 0, 1, 0,  0, 0, 0, 0,  0, 2, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0, &   !
       0, 0, 1, 0,  0, 0, 0, 0,  0, 0, 2, 0,  0, 0, 0, 0,  0, 0, 0, 0, &   !
       0, 0, 0, 1,  0, 0, 0, 0,  0, 0, 2, 0,  0, 0, 0, 0,  0, 0, 0, 0, &   !
       0, 0, 0, 1,  0, 0, 0, 0,  0, 0, 0, 2,  0, 0, 0, 0,  0, 0, 0, 0, &   ! 15
       1, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 2,  0, 0, 0, 0,  0, 0, 0, 0, &   !
       1, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  2, 0, 0, 0, &   !
       0, 1, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 2, 0, 0, &   !
       0, 0, 1, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 2, 0, &   !
       0, 0, 0, 1,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 2, &   ! 20
       0, 0, 0, 0,  1, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  2, 0, 0, 0, &   !
       0, 0, 0, 0,  0, 1, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 2, 0, 0, &   !
       0, 0, 0, 0,  0, 0, 1, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 2, 0, &   !
       0, 0, 0, 0,  0, 0, 0, 1,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 2, &   !
       0, 0, 0, 0,  1, 0, 0, 0,  0, 0, 0, 0,  2, 0, 0, 0,  0, 0, 0, 0, &   ! 25
       0, 0, 0, 0,  0, 1, 0, 0,  0, 0, 0, 0,  2, 0, 0, 0,  0, 0, 0, 0, &   !
       0, 0, 0, 0,  0, 1, 0, 0,  0, 0, 0, 0,  0, 2, 0, 0,  0, 0, 0, 0, &   !
       0, 0, 0, 0,  0, 0, 1, 0,  0, 0, 0, 0,  0, 2, 0, 0,  0, 0, 0, 0, &   !
       0, 0, 0, 0,  0, 0, 1, 0,  0, 0, 0, 0,  0, 0, 2, 0,  0, 0, 0, 0, &   !
       0, 0, 0, 0,  0, 0, 0, 1,  0, 0, 0, 0,  0, 0, 2, 0,  0, 0, 0, 0, &   ! 30
       0, 0, 0, 0,  0, 0, 0, 1,  0, 0, 0, 0,  0, 0, 0, 2,  0, 0, 0, 0, &   !
       0, 0, 0, 0,  1, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 2,  0, 0, 0, 0, &   !
       4, 1, 1, 1,  0, 0, 0, 0,  8, 2, 2, 8,  0, 0, 0, 0,  0, 0, 0, 0, &   !
       1, 4, 1, 1,  0, 0, 0, 0,  8, 8, 2, 2,  0, 0, 0, 0,  0, 0, 0, 0, &   !
       1, 1, 4, 1,  0, 0, 0, 0,  2, 8, 8, 2,  0, 0, 0, 0,  0, 0, 0, 0, &   ! 35
       1, 1, 1, 4,  0, 0, 0, 0,  2, 2, 8, 8,  0, 0, 0, 0,  0, 0, 0, 0, &   !
       4, 1, 0, 0,  1, 1, 0, 0,  8, 0, 0, 0,  2, 0, 0, 0,  8, 2, 0, 0, &   !
       1, 4, 0, 0,  1, 1, 0, 0,  8, 0, 0, 0,  2, 0, 0, 0,  2, 8, 0, 0, &   !
       0, 4, 1, 0,  0, 1, 1, 0,  0, 8, 0, 0,  0, 2, 0, 0,  0, 8, 2, 0, &   !
       0, 1, 4, 0,  0, 1, 1, 0,  0, 8, 0, 0,  0, 2, 0, 0,  0, 2, 8, 0, &   ! 40
       0, 0, 4, 1,  0, 0, 1, 1,  0, 0, 8, 0,  0, 0, 2, 0,  0, 0, 8, 2, &   !
       0, 0, 1, 4,  0, 0, 1, 1,  0, 0, 8, 0,  0, 0, 2, 0,  0, 0, 2, 8, &   !
       1, 0, 0, 4,  1, 0, 0, 1,  0, 0, 0, 8,  0, 0, 0, 2,  2, 0, 0, 8, &   !
       4, 0, 0, 1,  1, 0, 0, 1,  0, 0, 0, 8,  0, 0, 0, 2,  8, 0, 0, 2, &   !
       1, 1, 0, 0,  4, 1, 0, 0,  2, 0, 0, 0,  8, 0, 0, 0,  8, 2, 0, 0, &   ! 45
       1, 1, 0, 0,  1, 4, 0, 0,  2, 0, 0, 0,  8, 0, 0, 0,  2, 8, 0, 0, &   !
       0, 1, 1, 0,  0, 4, 1, 0,  0, 2, 0, 0,  0, 8, 0, 0,  0, 8, 2, 0, &   !
       0, 1, 1, 0,  0, 1, 4, 0,  0, 2, 0, 0,  0, 8, 0, 0,  0, 2, 8, 0, &   !
       0, 0, 1, 1,  0, 0, 4, 1,  0, 0, 2, 0,  0, 0, 8, 0,  0, 0, 8, 2, &   !
       0, 0, 1, 1,  0, 0, 1, 4,  0, 0, 2, 0,  0, 0, 8, 0,  0, 0, 2, 8, &   ! 50
       1, 0, 0, 1,  1, 0, 0, 4,  0, 0, 0, 2,  0, 0, 0, 8,  2, 0, 0, 8, &   !
       1, 0, 0, 1,  4, 0, 0, 1,  0, 0, 0, 2,  0, 0, 0, 8,  8, 0, 0, 2, &   !
       0, 0, 0, 0,  4, 1, 1, 1,  0, 0, 0, 0,  8, 2, 2, 8,  0, 0, 0, 0, &   !
       0, 0, 0, 0,  1, 4, 1, 1,  0, 0, 0, 0,  8, 8, 2, 2,  0, 0, 0, 0, &   !
       0, 0, 0, 0,  1, 1, 4, 1,  0, 0, 0, 0,  2, 8, 8, 2,  0, 0, 0, 0, &   ! 55
       0, 0, 0, 0,  1, 1, 1, 4,  0, 0, 0, 0,  2, 2, 8, 8,  0, 0, 0, 0, &   !
      24, 8, 4, 8,  8, 4, 3, 4, 32,12,12,32, 12, 4, 4,12, 32,12, 4,12, &   !
       8,24, 8, 4,  4, 8, 4, 3, 32,32,12,12, 12,12, 4, 4, 12,32,12, 4, &   !
       4, 8,24, 8,  3, 4, 8, 4, 12,32,32,12,  4,12,12, 4,  4,12,32,12, &   !
       8, 4, 8,24,  4, 3, 4, 8, 12,12,32,32,  4, 4,12,12, 12, 4,12,32, &   ! 60
       8, 4, 3, 4, 24, 8, 4, 8, 12, 4, 4,12, 32,12,12,32, 32,12, 4,12, &   !
       4, 8, 4, 3,  8,24, 8, 4, 12,12, 4, 4, 32,32,12,12, 12,32,12, 4, &   !
       3, 4, 8, 4,  4, 8,24, 8,  4,12,12, 4, 12,32,32,12,  4,12,32,12, &   !
       4, 3, 4, 8,  8, 4, 8,24,  4, 4,12,12, 12,12,32,32, 12, 4,12,32  &   !
 
 
 
    ],[nnode(13),ncellnode(geomtype(13))])
 
 
 
  integer, dimension(NCELLNODEPERCELL(CELLTYPE(1)),NIP(1)),   parameter :: cell1 = &
    reshape([&
      1,2,3 &
 
 
 
    ],[ncellnodepercell(celltype(1)),nip(1)])
 
 
  integer, dimension(NCELLNODEPERCELL(CELLTYPE(2)),NIP(2)),   parameter :: cell2 = &
    reshape([&
      1, 4, 7, 6, &
      2, 5, 7, 4, &
      3, 6, 7, 5  &
 
 
 
    ],[ncellnodepercell(celltype(2)),nip(2)])
 
 
  integer, dimension(NCELLNODEPERCELL(CELLTYPE(3)),NIP(3)),   parameter :: cell3 = &
    reshape([&
      1, 5, 9, 8, &
      5, 2, 6, 9, &
      8, 9, 7, 4, &
      9, 6, 3, 7  &
 
 
 
    ],[ncellnodepercell(celltype(3)),nip(3)])
 
 
  integer, dimension(NCELLNODEPERCELL(CELLTYPE(4)),NIP(4)),   parameter :: cell4 = &
    reshape([&
       1, 5,13,12, &
       5, 6,14,13, &
       6, 2, 7,14, &
      12,13,16,11, &
      13,14,15,16, &
      14, 7, 8,15, &
      11,16,10, 4, &
      16,15, 9,10, &
      15, 8, 3, 9  &
 
 
 
    ],[ncellnodepercell(celltype(4)),nip(4)])
 
 
  integer, dimension(NCELLNODEPERCELL(CELLTYPE(5)),NIP(5)),   parameter :: cell5 = &
    reshape([&
      1, 2, 3, 4 &
 
 
 
    ],[ncellnodepercell(celltype(5)),nip(5)])
 
 
  integer, dimension(NCELLNODEPERCELL(CELLTYPE(6)),NIP(6)),   parameter :: cell6 = &
    reshape([&
      1, 5,11, 7, 8,12,15,14, &
      5, 2, 6,11,12, 9,13,15, &
      7,11, 6, 3,14,15,13,10, &
      8,12,15, 4, 4, 9,13,10  &
 
 
 
    ],[ncellnodepercell(celltype(6)),nip(6)])
 
 
  integer, dimension(NCELLNODEPERCELL(CELLTYPE(7)),NIP(7)),   parameter :: cell7 = &
    reshape([&
      1, 7,16, 9,10,17,21,19, &
      7, 2, 8,16,17,11,18,21, &
      9,16, 8, 3,19,21,18,12, &
     10,17,21,19, 4,13,20,15, &
     17,11,18,21,13, 5,14,20, &
     19,21,18,12,15,20,14, 6  &
 
 
 
    ],[ncellnodepercell(celltype(7)),nip(7)])
 
 
  integer, dimension(NCELLNODEPERCELL(CELLTYPE(8)),NIP(8)),   parameter :: cell8 = &
    reshape([&
      1, 2, 3, 4, 5, 6, 7, 8 &
 
 
 
    ],[ncellnodepercell(celltype(8)),nip(8)])
 
 
  integer, dimension(NCELLNODEPERCELL(CELLTYPE(9)),NIP(9)),   parameter :: cell9 = &
    reshape([&
       1, 9,21,12,17,22,27,25, &
       9, 2,10,21,22,18,23,27, &
      12,21,11, 4,25,27,24,20, &
      21,10, 3,11,27,23,19,24, &
      17,22,27,25, 5,13,26,16, &
      22,18,23,27,13, 6,14,26, &
      25,27,24,20,16,26,15, 8, &
      27,23,19,24,26,14, 7,15  &
 
 
 
    ],[ncellnodepercell(celltype(9)),nip(9)])
 
 
  integer, dimension(NCELLNODEPERCELL(CELLTYPE(10)),NIP(10)), parameter :: cell10 = &
    reshape([&
       1, 9,33,16,17,37,57,44, &
       9,10,34,33,37,38,58,57, &
      10, 2,11,34,38,18,39,58, &
      16,33,36,15,44,57,60,43, &
      33,34,35,36,57,58,59,60, &
      34,11,12,35,58,39,40,59, &
      15,36,14, 4,43,60,42,20, &
      36,35,13,14,60,59,41,42, &
      35,12, 3,13,59,40,19,41, &
      17,37,57,44,21,45,61,52, &
      37,38,58,57,45,46,62,61, &
      38,18,39,58,46,22,47,62, &
      44,57,60,43,52,61,64,51, &
      57,58,59,60,61,62,63,64, &
      58,39,40,59,62,47,48,63, &
      43,60,42,20,51,64,50,24, &
      60,59,41,42,64,63,49,50, &
      59,40,19,41,63,48,23,49, &
      21,45,61,52, 5,25,53,32, &
      45,46,62,61,25,26,54,53, &
      46,22,47,62,26, 6,27,54, &
      52,61,64,51,32,53,56,31, &
      61,62,63,64,53,54,55,56, &
      62,47,48,63,54,27,28,55, &
      51,64,50,24,31,56,30, 8, &
      64,63,49,50,56,55,29,30, &
      63,48,23,49,55,28, 7,29  &
 
 
 
    ],[ncellnodepercell(celltype(10)),nip(10)])
 
 
 
  integer, dimension(NCELLNODEPERCELLFACE(1),NIPNEIGHBOR(1)), parameter :: cellface1 = &
    reshape([&
      2,3, &
      3,1, &
      1,2  &
 
 
 
    ],[ncellnodepercellface(1),nipneighbor(1)])
 
 
  integer, dimension(NCELLNODEPERCELLFACE(2),NIPNEIGHBOR(2)), parameter :: cellface2 = &
    reshape([&
      2,3, &
      4,1, &
      3,4, &
      1,2  &
 
 
 
    ],[ncellnodepercellface(2),nipneighbor(2)])
 
 
  integer, dimension(NCELLNODEPERCELLFACE(3),NIPNEIGHBOR(3)), parameter :: cellface3 = &
    reshape([&
      1,3,2, &
      1,2,4, &
      2,3,4, &
      1,4,3  &
 
 
 
    ],[ncellnodepercellface(3),nipneighbor(3)])
 
 
  integer, dimension(NCELLNODEPERCELLFACE(4),NIPNEIGHBOR(4)), parameter :: cellface4 = &
    reshape([&
      2,3,7,6, &
      4,1,5,8, &
      3,4,8,7, &
      1,2,6,5, &
      5,6,7,8, &
      1,4,3,2  &
 
 
 
    ],[ncellnodepercellface(4),nipneighbor(4)])
 
 
 
contains
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
subroutine telement_init(self,elemType)
 
  class(telement)     :: self
  integer, intent(in) :: elemType
  
  self%elemType = elemtype
 
  self%Nnodes     = nnode(self%elemType)
  self%geomType   = geomtype(self%elemType)
 
  select case (self%elemType)
    case(1)
      self%cellNodeParentNodeWeights = cellnodeparentnodeweights1
    case(2)
      self%cellNodeParentNodeWeights = cellnodeparentnodeweights2
    case(3)
      self%cellNodeParentNodeWeights = cellnodeparentnodeweights3
    case(4)
      self%cellNodeParentNodeWeights = cellnodeparentnodeweights4
    case(5)
      self%cellNodeParentNodeWeights = cellnodeparentnodeweights5
    case(6)
      self%cellNodeParentNodeWeights = cellnodeparentnodeweights6
    case(7)
      self%cellNodeParentNodeWeights = cellnodeparentnodeweights7
    case(8)
      self%cellNodeParentNodeWeights = cellnodeparentnodeweights8
    case(9)
      self%cellNodeParentNodeWeights = cellnodeparentnodeweights9
    case(10)
      self%cellNodeParentNodeWeights = cellnodeparentnodeweights10
    case(11)
      self%cellNodeParentNodeWeights = cellnodeparentnodeweights11
    case(12)
      self%cellNodeParentNodeWeights = cellnodeparentnodeweights12
    case(13)
      self%cellNodeParentNodeWeights = cellnodeparentnodeweights13
    case default
      call io_error(0,ext_msg='invalid element type')
  end select
  
 
  self%NcellNodes = ncellnode(self%geomType)
  self%nIPs       = nip(self%geomType)
  self%cellType   = celltype(self%geomType)
 
  select case (self%geomType)
    case(1)
      self%IPneighbor = ipneighbor1
      self%cell       = cell1
    case(2)
      self%IPneighbor = ipneighbor2
      self%cell       = cell2
    case(3)
      self%IPneighbor = ipneighbor3
      self%cell       = cell3
    case(4)
      self%IPneighbor = ipneighbor4
      self%cell       = cell4
    case(5)
      self%IPneighbor = ipneighbor5
      self%cell       = cell5
    case(6)
      self%IPneighbor = ipneighbor6
      self%cell       = cell6
    case(7)
      self%IPneighbor = ipneighbor7
      self%cell       = cell7
    case(8)
      self%IPneighbor = ipneighbor8
      self%cell       = cell8
    case(9)
      self%IPneighbor = ipneighbor9
      self%cell       = cell9
    case(10)
      self%IPneighbor = ipneighbor10
      self%cell       = cell10
  end select
 
  self%NcellnodesPerCell = ncellnodepercell(self%cellType)
  
  select case(self%cellType)
    case(1)
      self%cellFace = cellface1
      self%vtkType  = 'TRIANGLE'
    case(2)
      self%cellFace = cellface2
      self%vtkType  = 'QUAD'
    case(3)
      self%cellFace = cellface3
      self%vtkType  = 'TETRA'
    case(4)
      self%cellFace = cellface4
      self%vtkType  = 'HEXAHEDRON'
  end select
  
  self%nIPneighbors = size(self%IPneighbor,1)
  
  write(6,'(/,a)') ' <<<+-  element_init  -+>>>'; flush(6)
  
  write(6,*) ' element type:      ',self%elemType
  write(6,*) '   geom type:       ',self%geomType
  write(6,*) '   cell type:       ',self%cellType
  write(6,*) '   # node:          ',self%Nnodes
  write(6,*) '   # IP:            ',self%nIPs
  write(6,*) '   # cellnode:      ',self%Ncellnodes
  write(6,*) '   # cellnode/cell: ',self%NcellnodesPerCell
  write(6,*) '   # IP neighbor:   ',self%nIPneighbors
   
end subroutine telement_init
 
end module element
# 18 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/HDF5_utilities.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module hdf5_utilities
  use hdf5
 
 
 
 
  use prec
  use io
  use rotations
  use numerics
 
 implicit none
 public
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
  interface hdf5_read
    module procedure hdf5_read_real1
    module procedure hdf5_read_real2
    module procedure hdf5_read_real3
    module procedure hdf5_read_real4
    module procedure hdf5_read_real5
    module procedure hdf5_read_real6
    module procedure hdf5_read_real7
 
    module procedure hdf5_read_int1
    module procedure hdf5_read_int2
    module procedure hdf5_read_int3
    module procedure hdf5_read_int4
    module procedure hdf5_read_int5
    module procedure hdf5_read_int6
    module procedure hdf5_read_int7
 
  end interface hdf5_read
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
  interface hdf5_write
    module procedure hdf5_write_real1
    module procedure hdf5_write_real2
    module procedure hdf5_write_real3
    module procedure hdf5_write_real4
    module procedure hdf5_write_real5
    module procedure hdf5_write_real6
    module procedure hdf5_write_real7
 
    module procedure hdf5_write_int1
    module procedure hdf5_write_int2
    module procedure hdf5_write_int3
    module procedure hdf5_write_int4
    module procedure hdf5_write_int5
    module procedure hdf5_write_int6
    module procedure hdf5_write_int7
 
    module procedure hdf5_write_rotation
 
  end interface hdf5_write
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
  interface hdf5_addattribute
    module procedure hdf5_addattribute_str
    module procedure hdf5_addattribute_int
    module procedure hdf5_addattribute_real
    module procedure hdf5_addattribute_int_array
    module procedure hdf5_addattribute_real_array
  end interface hdf5_addattribute
 
contains
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_utilities_init
 
  integer         :: hdferr
  integer(SIZE_T) :: typeSize
 
  write(6,'(/,a)') ' <<<+-  HDF5_Utilities init  -+>>>'
 
!--------------------------------------------------------------------------------------------------
!initialize HDF5 library and check if integer and float type size match
  call h5open_f(hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_Utilities_init: h5open_f')
 
  call h5tget_size_f(h5t_native_integer,typesize, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_Utilities_init: h5tget_size_f (int)')
  if (int(bit_size(0),size_t)/=typesize*8) &
    call io_error(0,ext_msg='Default integer size does not match H5T_NATIVE_INTEGER')
 
  call h5tget_size_f(h5t_native_double,typesize, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_Utilities_init: h5tget_size_f (double)')
  if (int(storage_size(0.0_preal),size_t)/=typesize*8) &
    call io_error(0,ext_msg='pReal does not match H5T_NATIVE_DOUBLE')
 
end subroutine hdf5_utilities_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
integer(HID_T) function hdf5_openfile(fileName,mode,parallel)
 
  character(len=*), intent(in)           :: filename
  character,        intent(in), optional :: mode
  logical,          intent(in), optional :: parallel
 
  character                              :: m
  integer(HID_T)                         :: plist_id
  integer                 :: hdferr
 
  if (present(mode)) then
    m = mode
  else
    m = 'r'
  endif
 
  call h5pcreate_f(h5p_file_access_f, plist_id, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_openFile: h5pcreate_f')
 
 
 
 
 
 
 
 
  if    (m == 'w') then
    call h5fcreate_f(filename,h5f_acc_trunc_f,hdf5_openfile,hdferr,access_prp = plist_id)
    if (hdferr < 0) call io_error(1,ext_msg='HDF5_openFile: h5fcreate_f (w)')
  elseif(m == 'a') then
    call h5fopen_f(filename,h5f_acc_rdwr_f,hdf5_openfile,hdferr,access_prp = plist_id)
    if (hdferr < 0) call io_error(1,ext_msg='HDF5_openFile: h5fopen_f (a)')
  elseif(m == 'r') then
    call h5fopen_f(filename,h5f_acc_rdonly_f,hdf5_openfile,hdferr,access_prp = plist_id)
    if (hdferr < 0) call io_error(1,ext_msg='HDF5_openFile: h5fopen_f (r)')
  else
    call io_error(1,ext_msg='HDF5_openFile: h5fopen_f unknown access mode: '//trim(m))
  endif
 
  call h5pclose_f(plist_id, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_openFile: h5pclose_f')
 
end function hdf5_openfile
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_closefile(fileHandle)
 
  integer(HID_T), intent(in) :: fileHandle
 
  integer     :: hdferr
 
  call h5fclose_f(filehandle,hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_closeFile: h5fclose_f')
 
end subroutine hdf5_closefile
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
integer(HID_T) function hdf5_addgroup(fileHandle,groupName)
 
  integer(HID_T), intent(in)   :: filehandle
  character(len=*), intent(in) :: groupname
 
  integer        :: hdferr
  integer(HID_T) :: aplist_id
 
!-------------------------------------------------------------------------------------------------
! creating a property list for data access properties
  call h5pcreate_f(h5p_group_access_f, aplist_id, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg = 'HDF5_addGroup: h5pcreate_f ('//trim(groupname)//')')
 
!-------------------------------------------------------------------------------------------------
! setting I/O mode to collective
 
 
 
 
 
!-------------------------------------------------------------------------------------------------
! Create group
  call h5gcreate_f(filehandle, trim(groupname), hdf5_addgroup, hdferr, object_namelen_default_f,gapl_id = aplist_id)
  if (hdferr < 0) call io_error(1,ext_msg = 'HDF5_addGroup: h5gcreate_f ('//trim(groupname)//')')
 
  call h5pclose_f(aplist_id,hdferr)
 
end function hdf5_addgroup
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
integer(HID_T) function hdf5_opengroup(fileHandle,groupName)
 
  integer(HID_T),   intent(in) :: filehandle
  character(len=*), intent(in) :: groupname
 
 
  integer        :: hdferr
  integer(HID_T) :: aplist_id
  logical        :: is_collective
 
 
 !-------------------------------------------------------------------------------------------------
 ! creating a property list for data access properties
  call h5pcreate_f(h5p_group_access_f, aplist_id, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg = 'HDF5_openGroup: h5pcreate_f ('//trim(groupname)//')')
 
 !-------------------------------------------------------------------------------------------------
 ! setting I/O mode to collective
 
 
 
 
 
 !-------------------------------------------------------------------------------------------------
 ! opening the group
  call h5gopen_f(filehandle, trim(groupname), hdf5_opengroup, hdferr, gapl_id = aplist_id)
  if (hdferr < 0) call io_error(1,ext_msg = 'HDF5_openGroup: h5gopen_f ('//trim(groupname)//')')
 
  call h5pclose_f(aplist_id,hdferr)
 
end function hdf5_opengroup
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_closegroup(group_id)
 
  integer(HID_T), intent(in) :: group_id
  integer                    :: hdferr
 
  call h5gclose_f(group_id, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg = 'HDF5_closeGroup: h5gclose_f (el is ID)', el = int(group_id))
 
end subroutine hdf5_closegroup
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
logical function hdf5_objectexists(loc_id,path)
 
  integer(HID_T),   intent(in)            :: loc_id
  character(len=*), intent(in), optional  :: path
 
  integer                   :: hdferr
  character(len=pStringLen) :: p
 
  if (present(path)) then
    p = trim(path)
  else
    p = '.'
  endif
 
  call h5lexists_f(loc_id, p, hdf5_objectexists, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg = 'HDF5_objectExists: h5oexists_by_name_f')
 
  if(hdf5_objectexists) then
    call h5oexists_by_name_f(loc_id, p, hdf5_objectexists, hdferr)
    if (hdferr < 0) call io_error(1,ext_msg = 'HDF5_objectExists: h5oexists_by_name_f')
  endif
 
end function hdf5_objectexists
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_addattribute_str(loc_id,attrLabel,attrValue,path)
 
  integer(HID_T),   intent(in)           :: loc_id
  character(len=*), intent(in)           :: attrLabel, attrValue
  character(len=*), intent(in), optional :: path
 
  integer                   :: hdferr
  integer(HID_T)            :: attr_id, space_id, type_id
  logical                   :: attrExists
  character(len=pStringLen) :: p
 
  if (present(path)) then
    p = trim(path)
  else
    p = '.'
  endif
 
  call h5screate_f(h5s_scalar_f,space_id,hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_str: h5screate_f')
  call h5tcopy_f(h5t_native_character, type_id, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_str: h5tcopy_f')
  call h5tset_size_f(type_id, int(len_trim(attrvalue),hsize_t), hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_str: h5tset_size_f')
  call h5aexists_by_name_f(loc_id,trim(p),attrlabel,attrexists,hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_str: h5aexists_by_name_f')
  if (attrexists) then
    call h5adelete_by_name_f(loc_id, trim(p), attrlabel, hdferr)
    if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_str: h5adelete_by_name_f')
  endif
  call h5acreate_by_name_f(loc_id,trim(p),trim(attrlabel),type_id,space_id,attr_id,hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_str: h5acreate_f')
  call h5awrite_f(attr_id, type_id, trim(attrvalue), int([1],hsize_t), hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_str: h5awrite_f')
  call h5aclose_f(attr_id,hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_str: h5aclose_f')
  call h5tclose_f(type_id,hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_str: h5tclose_f')
  call h5sclose_f(space_id,hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_str: h5sclose_f')
 
end subroutine hdf5_addattribute_str
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_addattribute_int(loc_id,attrLabel,attrValue,path)
 
  integer(HID_T),   intent(in)            :: loc_id
  character(len=*), intent(in)            :: attrLabel
  integer,          intent(in)            :: attrValue
  character(len=*), intent(in), optional  :: path
 
  integer                   :: hdferr
  integer(HID_T)            :: attr_id, space_id
  logical                   :: attrExists
  character(len=pStringLen) :: p
 
  if (present(path)) then
    p = trim(path)
  else
    p = '.'
  endif
 
  call h5screate_f(h5s_scalar_f,space_id,hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_int: h5screate_f')
  call h5aexists_by_name_f(loc_id,trim(p),attrlabel,attrexists,hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_int: h5aexists_by_name_f')
  if (attrexists) then
    call h5adelete_by_name_f(loc_id, trim(p), attrlabel, hdferr)
    if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_int: h5adelete_by_name_f')
  endif
  call h5acreate_by_name_f(loc_id,trim(p),trim(attrlabel),h5t_native_integer,space_id,attr_id,hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_int: h5acreate_f')
  call h5awrite_f(attr_id, h5t_native_integer, attrvalue, int([1],hsize_t), hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_int: h5awrite_f')
  call h5aclose_f(attr_id,hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_int: h5tclose_f')
  call h5sclose_f(space_id,hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_int: h5sclose_f')
 
end subroutine hdf5_addattribute_int
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_addattribute_real(loc_id,attrLabel,attrValue,path)
 
  integer(HID_T),   intent(in)           :: loc_id
  character(len=*), intent(in)           :: attrLabel
  real(pReal),      intent(in)           :: attrValue
  character(len=*), intent(in), optional :: path
 
  integer                   :: hdferr
  integer(HID_T)            :: attr_id, space_id
  logical                   :: attrExists
  character(len=pStringLen) :: p
 
  if (present(path)) then
    p = trim(path)
  else
    p = '.'
  endif
 
  call h5screate_f(h5s_scalar_f,space_id,hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_real: h5screate_f')
  call h5aexists_by_name_f(loc_id,trim(p),attrlabel,attrexists,hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_real: h5aexists_by_name_f')
  if (attrexists) then
    call h5adelete_by_name_f(loc_id, trim(p), attrlabel, hdferr)
    if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_real: h5adelete_by_name_f')
  endif
  call h5acreate_by_name_f(loc_id,trim(p),trim(attrlabel),h5t_native_double,space_id,attr_id,hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_real: h5acreate_f')
  call h5awrite_f(attr_id, h5t_native_double, attrvalue, int([1],hsize_t), hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_real: h5awrite_f')
  call h5aclose_f(attr_id,hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_real: h5tclose_f')
  call h5sclose_f(space_id,hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_real: h5sclose_f')
 
end subroutine hdf5_addattribute_real
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_addattribute_int_array(loc_id,attrLabel,attrValue,path)
 
  integer(HID_T),   intent(in)               :: loc_id
  character(len=*), intent(in)               :: attrLabel
  integer,          intent(in), dimension(:) :: attrValue
  character(len=*), intent(in), optional     :: path
 
  integer                       :: hdferr
  integer(HID_T)                :: attr_id, space_id
  integer(HSIZE_T),dimension(1) :: array_size
  logical                       :: attrExists
  character(len=pStringLen)     :: p
 
  if (present(path)) then
    p = trim(path)
  else
    p = '.'
  endif
 
  array_size = size(attrvalue,kind=hsize_t)
 
  call h5screate_simple_f(1, array_size, space_id, hdferr, array_size)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_int_array: h5screate_f')
  call h5aexists_by_name_f(loc_id,trim(p),attrlabel,attrexists,hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_int_array: h5aexists_by_name_f')
  if (attrexists) then
    call h5adelete_by_name_f(loc_id, trim(p), attrlabel, hdferr)
    if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_int_array: h5adelete_by_name_f')
  endif
  call h5acreate_by_name_f(loc_id,trim(p),trim(attrlabel),h5t_native_integer,space_id,attr_id,hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_int_array: h5acreate_f')
  call h5awrite_f(attr_id, h5t_native_integer, attrvalue, array_size, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_int_array: h5awrite_f')
  call h5aclose_f(attr_id,hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_int_array: h5tclose_f')
  call h5sclose_f(space_id,hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_int_array: h5sclose_f')
 
end subroutine hdf5_addattribute_int_array
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_addattribute_real_array(loc_id,attrLabel,attrValue,path)
 
  integer(HID_T),   intent(in)               :: loc_id
  character(len=*), intent(in)               :: attrLabel
  real(pReal),      intent(in), dimension(:) :: attrValue
  character(len=*), intent(in), optional     :: path
 
  integer                       :: hdferr
  integer(HID_T)                :: attr_id, space_id
  integer(HSIZE_T),dimension(1) :: array_size
  logical                       :: attrExists
  character(len=pStringLen)     :: p
 
  if (present(path)) then
    p = trim(path)
  else
    p = '.'
  endif
 
  array_size = size(attrvalue,kind=hsize_t)
 
  call h5screate_simple_f(1, array_size, space_id, hdferr, array_size)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_int_array: h5screate_f')
  call h5aexists_by_name_f(loc_id,trim(p),attrlabel,attrexists,hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_int_array: h5aexists_by_name_f')
  if (attrexists) then
    call h5adelete_by_name_f(loc_id, trim(p), attrlabel, hdferr)
    if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_int_array: h5adelete_by_name_f')
  endif
  call h5acreate_by_name_f(loc_id,trim(p),trim(attrlabel),h5t_native_double,space_id,attr_id,hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_int_array: h5acreate_f')
  call h5awrite_f(attr_id, h5t_native_double, attrvalue, array_size, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_int_array: h5awrite_f')
  call h5aclose_f(attr_id,hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_int_array: h5tclose_f')
  call h5sclose_f(space_id,hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_addAttribute_int_array: h5sclose_f')
 
end subroutine hdf5_addattribute_real_array
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_setlink(loc_id,target_name,link_name)
 
  character(len=*), intent(in) :: target_name, link_name
  integer(HID_T),   intent(in) :: loc_id
  integer                      :: hdferr
  logical                      :: linkExists
 
  call h5lexists_f(loc_id, link_name,linkexists, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg = 'HDF5_setLink: h5lexists_soft_f ('//trim(link_name)//')')
  if (linkexists) then
    call h5ldelete_f(loc_id,link_name, hdferr)
    if (hdferr < 0) call io_error(1,ext_msg = 'HDF5_setLink: h5ldelete_soft_f ('//trim(link_name)//')')
  endif
  call h5lcreate_soft_f(target_name, loc_id, link_name, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg = 'HDF5_setLink: h5lcreate_soft_f ('//trim(target_name)//' '//trim(link_name)//')')
 
end subroutine hdf5_setlink
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_read_real1(loc_id,dataset,datasetName,parallel)
 
  real(pReal),      intent(out), dimension(:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical, intent(in), optional :: parallel
 
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id, aplist_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &                                            ! ToDo: Fortran 2018 size(shape(A)) = rank(A)
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
  integer :: hdferr
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
  myshape = int(shape(dataset),hsize_t)
  if (any(myshape(1:size(myshape)-1) == 0)) return                                                  
 
!---------------------------------------------------------------------------------------------------
! initialize HDF5 data structures
  if (present(parallel)) then
    call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                         mystart, totalshape, loc_id,myshape,datasetname,parallel)
  else
    call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                         mystart, totalshape, loc_id,myshape,datasetname,.false.)
  endif
 
  call h5dread_f(dset_id, h5t_native_double,dataset,totalshape, hdferr,&
                 file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_read_real1: h5dread_f')
 
  call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
 
end subroutine hdf5_read_real1
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_read_real2(loc_id,dataset,datasetName,parallel)
 
  real(pReal),      intent(out), dimension(:,:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical, intent(in), optional :: parallel
 
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id, aplist_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
  integer :: hdferr
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
  myshape = int(shape(dataset),hsize_t)
  if (any(myshape(1:size(myshape)-1) == 0)) return                                                  
 
!---------------------------------------------------------------------------------------------------
! initialize HDF5 data structures
  if (present(parallel)) then
    call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                         mystart, totalshape, loc_id,myshape,datasetname,parallel)
  else
    call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                         mystart, totalshape, loc_id,myshape,datasetname,.false.)
  endif
 
  call h5dread_f(dset_id, h5t_native_double,dataset,totalshape, hdferr,&
                 file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_read_real2: h5dread_f')
 
  call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
 
end subroutine hdf5_read_real2
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_read_real3(loc_id,dataset,datasetName,parallel)
 
  real(pReal),      intent(out), dimension(:,:,:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical, intent(in), optional :: parallel
 
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id, aplist_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
  integer :: hdferr
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
  myshape = int(shape(dataset),hsize_t)
  if (any(myshape(1:size(myshape)-1) == 0)) return                                                  
 
!---------------------------------------------------------------------------------------------------
! initialize HDF5 data structures
  if (present(parallel)) then
    call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                         mystart, totalshape, loc_id,myshape,datasetname,parallel)
  else
    call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                         mystart, totalshape, loc_id,myshape,datasetname,.false.)
  endif
 
  call h5dread_f(dset_id, h5t_native_double,dataset,totalshape, hdferr,&
                 file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_read_real3: h5dread_f')
 
  call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
 
end subroutine hdf5_read_real3
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_read_real4(loc_id,dataset,datasetName,parallel)
 
  real(pReal),      intent(out), dimension(:,:,:,:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical, intent(in), optional :: parallel
 
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id, aplist_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
  integer :: hdferr
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
  myshape = int(shape(dataset),hsize_t)
  if (any(myshape(1:size(myshape)-1) == 0)) return                                                  
 
!---------------------------------------------------------------------------------------------------
! initialize HDF5 data structures
  if (present(parallel)) then
    call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                         mystart, totalshape, loc_id,myshape,datasetname,parallel)
  else
    call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                         mystart, totalshape, loc_id,myshape,datasetname,.false.)
  endif
 
  call h5dread_f(dset_id, h5t_native_double,dataset,totalshape, hdferr,&
                 file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_read_real4: h5dread_f')
 
  call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
 
end subroutine hdf5_read_real4
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_read_real5(loc_id,dataset,datasetName,parallel)
 
  real(pReal),      intent(out), dimension(:,:,:,:,:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical, intent(in), optional :: parallel
 
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id, aplist_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
  integer :: hdferr
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
  myshape = int(shape(dataset),hsize_t)
  if (any(myshape(1:size(myshape)-1) == 0)) return                                                  
 
!---------------------------------------------------------------------------------------------------
! initialize HDF5 data structures
  if (present(parallel)) then
    call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                         mystart, totalshape, loc_id,myshape,datasetname,parallel)
  else
    call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                         mystart, totalshape, loc_id,myshape,datasetname,.false.)
  endif
 
  call h5dread_f(dset_id, h5t_native_double,dataset,totalshape, hdferr,&
                 file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_read_real5: h5dread_f')
 
  call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
 
end subroutine hdf5_read_real5
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_read_real6(loc_id,dataset,datasetName,parallel)
 
  real(pReal),      intent(out), dimension(:,:,:,:,:,:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical, intent(in), optional :: parallel
 
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id, aplist_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
  integer :: hdferr
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
  myshape = int(shape(dataset),hsize_t)
  if (any(myshape(1:size(myshape)-1) == 0)) return                                                  
 
!---------------------------------------------------------------------------------------------------
! initialize HDF5 data structures
  if (present(parallel)) then
    call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                         mystart, totalshape, loc_id,myshape,datasetname,parallel)
  else
    call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                         mystart, totalshape, loc_id,myshape,datasetname,.false.)
  endif
 
  call h5dread_f(dset_id, h5t_native_double,dataset,totalshape, hdferr,&
                 file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_read_real6: h5dread_f')
 
  call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
 
end subroutine hdf5_read_real6
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_read_real7(loc_id,dataset,datasetName,parallel)
 
  real(pReal),      intent(out), dimension(:,:,:,:,:,:,:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical, intent(in), optional :: parallel
 
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id, aplist_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
  integer :: hdferr
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
  myshape = int(shape(dataset),hsize_t)
  if (any(myshape(1:size(myshape)-1) == 0)) return                                                  
 
!---------------------------------------------------------------------------------------------------
! initialize HDF5 data structures
  if (present(parallel)) then
    call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                         mystart, totalshape, loc_id,myshape,datasetname,parallel)
  else
    call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                         mystart, totalshape, loc_id,myshape,datasetname,.false.)
  endif
 
  call h5dread_f(dset_id, h5t_native_double,dataset,totalshape, hdferr,&
                 file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_read_real7: h5dread_f')
 
  call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
 
end subroutine hdf5_read_real7
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_read_int1(loc_id,dataset,datasetName,parallel)
 
  integer,          intent(out), dimension(:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical, intent(in), optional :: parallel
 
 
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id, aplist_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
  integer :: hdferr
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
  myshape = int(shape(dataset),hsize_t)
  if (any(myshape(1:size(myshape)-1) == 0)) return                                                  
 
!---------------------------------------------------------------------------------------------------
! initialize HDF5 data structures
  if (present(parallel)) then
    call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                         mystart, totalshape, loc_id,myshape,datasetname,parallel)
  else
    call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                         mystart, totalshape, loc_id,myshape,datasetname,.false.)
  endif
 
  call h5dread_f(dset_id, h5t_native_integer,dataset,totalshape, hdferr,&
                 file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_read_int1: h5dread_f')
 
  call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
 
end subroutine hdf5_read_int1
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_read_int2(loc_id,dataset,datasetName,parallel)
 
  integer,          intent(out), dimension(:,:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical, intent(in), optional :: parallel
 
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id, aplist_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
  integer :: hdferr
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
  myshape = int(shape(dataset),hsize_t)
  if (any(myshape(1:size(myshape)-1) == 0)) return                                                  
 
!---------------------------------------------------------------------------------------------------
! initialize HDF5 data structures
  if (present(parallel)) then
    call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                         mystart, totalshape, loc_id,myshape,datasetname,parallel)
  else
    call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                         mystart, totalshape, loc_id,myshape,datasetname,.false.)
  endif
 
  call h5dread_f(dset_id, h5t_native_integer,dataset,totalshape, hdferr,&
                 file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_read_int2: h5dread_f')
 
  call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
 
end subroutine hdf5_read_int2
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_read_int3(loc_id,dataset,datasetName,parallel)
 
  integer,          intent(out), dimension(:,:,:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical, intent(in), optional :: parallel
 
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id, aplist_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
  integer :: hdferr
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
  myshape = int(shape(dataset),hsize_t)
  if (any(myshape(1:size(myshape)-1) == 0)) return                                                  
 
!---------------------------------------------------------------------------------------------------
! initialize HDF5 data structures
  if (present(parallel)) then
    call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                         mystart, totalshape, loc_id,myshape,datasetname,parallel)
  else
   call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                        mystart, totalshape, loc_id,myshape,datasetname,.false.)
  endif
 
  call h5dread_f(dset_id, h5t_native_integer,dataset,totalshape, hdferr,&
                 file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_read_int3: h5dread_f')
 
  call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
 
end subroutine hdf5_read_int3
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_read_int4(loc_id,dataset,datasetName,parallel)
 
  integer,          intent(out), dimension(:,:,:,:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical, intent(in), optional :: parallel
 
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id, aplist_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
  integer :: hdferr
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
  myshape = int(shape(dataset),hsize_t)
  if (any(myshape(1:size(myshape)-1) == 0)) return                                                  
 
!---------------------------------------------------------------------------------------------------
! initialize HDF5 data structures
  if (present(parallel)) then
    call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                         mystart, totalshape, loc_id,myshape,datasetname,parallel)
  else
    call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                         mystart, totalshape, loc_id,myshape,datasetname,.false.)
  endif
 
  call h5dread_f(dset_id, h5t_native_integer,dataset,totalshape, hdferr,&
                 file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_read_int4: h5dread_f')
 
  call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
 
end subroutine hdf5_read_int4
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_read_int5(loc_id,dataset,datasetName,parallel)
 
  integer,          intent(out), dimension(:,:,:,:,:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical, intent(in), optional :: parallel
 
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id, aplist_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
  integer :: hdferr
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
  myshape = int(shape(dataset),hsize_t)
  if (any(myshape(1:size(myshape)-1) == 0)) return                                                  
 
!---------------------------------------------------------------------------------------------------
! initialize HDF5 data structures
  if (present(parallel)) then
    call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                         mystart, totalshape, loc_id,myshape,datasetname,parallel)
  else
    call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                         mystart, totalshape, loc_id,myshape,datasetname,.false.)
  endif
 
  call h5dread_f(dset_id, h5t_native_integer,dataset,totalshape, hdferr,&
                 file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_read_int5: h5dread_f')
 
  call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
 
end subroutine hdf5_read_int5
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_read_int6(loc_id,dataset,datasetName,parallel)
 
  integer,          intent(out), dimension(:,:,:,:,:,:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical, intent(in), optional :: parallel
 
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id, aplist_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
  integer :: hdferr
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
  myshape = int(shape(dataset),hsize_t)
  if (any(myshape(1:size(myshape)-1) == 0)) return                                                  
 
!---------------------------------------------------------------------------------------------------
! initialize HDF5 data structures
  if (present(parallel)) then
    call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                         mystart, totalshape, loc_id,myshape,datasetname,parallel)
  else
    call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                         mystart, totalshape, loc_id,myshape,datasetname,.false.)
  endif
 
  call h5dread_f(dset_id, h5t_native_integer,dataset,totalshape, hdferr,&
                 file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_read_int6: h5dread_f')
 
  call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
 
end subroutine hdf5_read_int6
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_read_int7(loc_id,dataset,datasetName,parallel)
 
  integer,          intent(out), dimension(:,:,:,:,:,:,:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical, intent(in), optional :: parallel
 
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id, aplist_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
  integer :: hdferr
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
  myshape = int(shape(dataset),hsize_t)
  if (any(myshape(1:size(myshape)-1) == 0)) return                                                  
 
!---------------------------------------------------------------------------------------------------
! initialize HDF5 data structures
  if (present(parallel)) then
    call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                         mystart, totalshape, loc_id,myshape,datasetname,parallel)
  else
    call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                         mystart, totalshape, loc_id,myshape,datasetname,.false.)
  endif
 
  call h5dread_f(dset_id, h5t_native_integer,dataset,totalshape, hdferr,&
                 file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id)
  if (hdferr < 0) call io_error(1,ext_msg='HDF5_read_int7: h5dread_f')
 
  call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
 
end subroutine hdf5_read_int7
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_write_real1(loc_id,dataset,datasetName,parallel)
 
  real(pReal),      intent(inout), dimension(:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical, intent(in), optional :: parallel
 
 
  integer :: hdferr
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
  myshape = int(shape(dataset),hsize_t)
  if (any(myshape(1:size(myshape)-1) == 0)) return                                                  
 
  if (present(parallel)) then
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape,loc_id,myshape,datasetname,h5t_native_double,parallel)
  else
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape,loc_id,myshape,datasetname,h5t_native_double,.false.)
  endif
 
  if (product(totalshape) /= 0) then
    call h5dwrite_f(dset_id, h5t_native_double,dataset,int(totalshape,hsize_t), hdferr,&
                   file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
    if (hdferr < 0) call io_error(1,ext_msg='HDF5_write_real1: h5dwrite_f')
  endif
 
  call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
 
end subroutine hdf5_write_real1
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_write_real2(loc_id,dataset,datasetName,parallel)
 
  real(pReal),      intent(inout), dimension(:,:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical, intent(in), optional :: parallel
 
 
  integer :: hdferr
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
  myshape = int(shape(dataset),hsize_t)
  if (any(myshape(1:size(myshape)-1) == 0)) return                                                  
 
  if (present(parallel)) then
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape, loc_id,myshape,datasetname,h5t_native_double,parallel)
  else
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape, loc_id,myshape,datasetname,h5t_native_double,.false.)
  endif
 
  if (product(totalshape) /= 0) then
    call h5dwrite_f(dset_id, h5t_native_double,dataset,int(totalshape,hsize_t), hdferr,&
                   file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
    if (hdferr < 0) call io_error(1,ext_msg='HDF5_write_real2: h5dwrite_f')
  endif
 
  call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
 
end subroutine hdf5_write_real2
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_write_real3(loc_id,dataset,datasetName,parallel)
 
  real(pReal),      intent(inout), dimension(:,:,:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical, intent(in), optional :: parallel
 
 
  integer :: hdferr
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
  myshape = int(shape(dataset),hsize_t)
  if (any(myshape(1:size(myshape)-1) == 0)) return                                                  
 
  if (present(parallel)) then
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape, loc_id,myshape,datasetname,h5t_native_double,parallel)
  else
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape, loc_id,myshape,datasetname,h5t_native_double,.false.)
  endif
 
  if (product(totalshape) /= 0) then
    call h5dwrite_f(dset_id, h5t_native_double,dataset,int(totalshape,hsize_t), hdferr,&
                   file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
    if (hdferr < 0) call io_error(1,ext_msg='HDF5_write_real3: h5dwrite_f')
  endif
 
  call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
 
end subroutine hdf5_write_real3
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_write_real4(loc_id,dataset,datasetName,parallel)
 
  real(pReal),      intent(inout), dimension(:,:,:,:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical, intent(in), optional :: parallel
 
 
  integer :: hdferr
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
  myshape = int(shape(dataset),hsize_t)
  if (any(myshape(1:size(myshape)-1) == 0)) return                                                  
 
  if (present(parallel)) then
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape, loc_id,myshape,datasetname,h5t_native_double,parallel)
  else
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape, loc_id,myshape,datasetname,h5t_native_double,.false.)
  endif
 
  if (product(totalshape) /= 0) then
    call h5dwrite_f(dset_id, h5t_native_double,dataset,int(totalshape,hsize_t), hdferr,&
                   file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
    if (hdferr < 0) call io_error(1,ext_msg='HDF5_write_real4: h5dwrite_f')
  endif
 
  call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
 
end subroutine hdf5_write_real4
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_write_real5(loc_id,dataset,datasetName,parallel)
 
  real(pReal),      intent(inout), dimension(:,:,:,:,:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical, intent(in), optional :: parallel
 
 
  integer :: hdferr
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
  myshape = int(shape(dataset),hsize_t)
  if (any(myshape(1:size(myshape)-1) == 0)) return                                                  
 
  if (present(parallel)) then
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape, loc_id,myshape,datasetname,h5t_native_double,parallel)
  else
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape, loc_id,myshape,datasetname,h5t_native_double,.false.)
  endif
 
  if (product(totalshape) /= 0) then
    call h5dwrite_f(dset_id, h5t_native_double,dataset,int(totalshape,hsize_t), hdferr,&
                   file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
    if (hdferr < 0) call io_error(1,ext_msg='HDF5_write_real5: h5dwrite_f')
  endif
 
  call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
 
end subroutine hdf5_write_real5
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_write_real6(loc_id,dataset,datasetName,parallel)
 
  real(pReal),      intent(inout), dimension(:,:,:,:,:,:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical, intent(in), optional :: parallel
 
 
  integer :: hdferr
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
  myshape = int(shape(dataset),hsize_t)
  if (any(myshape(1:size(myshape)-1) == 0)) return                                                  
 
  if (present(parallel)) then
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape, loc_id,myshape,datasetname,h5t_native_double,parallel)
  else
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape, loc_id,myshape,datasetname,h5t_native_double,.false.)
  endif
 
  if (product(totalshape) /= 0) then
    call h5dwrite_f(dset_id, h5t_native_double,dataset,int(totalshape,hsize_t), hdferr,&
                   file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
    if (hdferr < 0) call io_error(1,ext_msg='HDF5_write_real6: h5dwrite_f')
  endif
 
  call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
 
end subroutine hdf5_write_real6
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_write_real7(loc_id,dataset,datasetName,parallel)
 
  real(pReal),      intent(inout), dimension(:,:,:,:,:,:,:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical, intent(in), optional :: parallel
 
 
  integer :: hdferr
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
  myshape = int(shape(dataset),hsize_t)
  if (any(myshape(1:size(myshape)-1) == 0)) return                                                  
 
  if (present(parallel)) then
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape, loc_id,myshape,datasetname,h5t_native_double,parallel)
  else
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape, loc_id,myshape,datasetname,h5t_native_double,.false.)
  endif
 
  if (product(totalshape) /= 0) then
    call h5dwrite_f(dset_id, h5t_native_double,dataset,int(totalshape,hsize_t), hdferr,&
                   file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
    if (hdferr < 0) call io_error(1,ext_msg='HDF5_write_real7: h5dwrite_f')
  endif
 
  call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
 
end subroutine hdf5_write_real7
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_write_int1(loc_id,dataset,datasetName,parallel)
 
  integer,          intent(inout), dimension(:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical, intent(in), optional :: parallel
 
 
  integer :: hdferr
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
  myshape = int(shape(dataset),hsize_t)
  if (any(myshape(1:size(myshape)-1) == 0)) return                                                  
 
  if (present(parallel)) then
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape, loc_id,myshape,datasetname,h5t_native_integer,parallel)
  else
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape, loc_id,myshape,datasetname,h5t_native_integer,.false.)
  endif
 
  if (product(totalshape) /= 0) then
    call h5dwrite_f(dset_id, h5t_native_integer,dataset,int(totalshape,hsize_t), hdferr,&
                   file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
    if (hdferr < 0) call io_error(1,ext_msg='HDF5_write_int1: h5dwrite_f')
  endif
 
  call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
 
end subroutine hdf5_write_int1
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_write_int2(loc_id,dataset,datasetName,parallel)
 
  integer,          intent(inout), dimension(:,:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical, intent(in), optional :: parallel
 
 
  integer :: hdferr
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
  myshape = int(shape(dataset),hsize_t)
  if (any(myshape(1:size(myshape)-1) == 0)) return                                                  
 
  if (present(parallel)) then
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape, loc_id,myshape,datasetname,h5t_native_integer,parallel)
  else
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape, loc_id,myshape,datasetname,h5t_native_integer,.false.)
  endif
 
  if (product(totalshape) /= 0) then
    call h5dwrite_f(dset_id, h5t_native_integer,dataset,int(totalshape,hsize_t), hdferr,&
                   file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
    if (hdferr < 0) call io_error(1,ext_msg='HDF5_write_int2: h5dwrite_f')
  endif
 
  call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
 
end subroutine hdf5_write_int2
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_write_int3(loc_id,dataset,datasetName,parallel)
 
  integer,          intent(inout), dimension(:,:,:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical, intent(in), optional :: parallel
 
 
  integer :: hdferr
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
  myshape = int(shape(dataset),hsize_t)
  if (any(myshape(1:size(myshape)-1) == 0)) return                                                  
 
  if (present(parallel)) then
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape, loc_id,myshape,datasetname,h5t_native_integer,parallel)
  else
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape, loc_id,myshape,datasetname,h5t_native_integer,.false.)
  endif
 
  if (product(totalshape) /= 0) then
    call h5dwrite_f(dset_id, h5t_native_integer,dataset,int(totalshape,hsize_t), hdferr,&
                   file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
    if (hdferr < 0) call io_error(1,ext_msg='HDF5_write_int3: h5dwrite_f')
  endif
 
  call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
 
end subroutine hdf5_write_int3
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_write_int4(loc_id,dataset,datasetName,parallel)
 
  integer,          intent(inout), dimension(:,:,:,:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical, intent(in), optional :: parallel
 
 
  integer :: hdferr
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
  myshape = int(shape(dataset),hsize_t)
  if (any(myshape(1:size(myshape)-1) == 0)) return                                                  
 
  if (present(parallel)) then
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape, loc_id,myshape,datasetname,h5t_native_integer,parallel)
  else
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape, loc_id,myshape,datasetname,h5t_native_integer,.false.)
  endif
 
  if (product(totalshape) /= 0) then
    call h5dwrite_f(dset_id, h5t_native_integer,dataset,int(totalshape,hsize_t), hdferr,&
                   file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
    if (hdferr < 0) call io_error(1,ext_msg='HDF5_write_int4: h5dwrite_f')
  endif
 
  call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
 
end subroutine hdf5_write_int4
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_write_int5(loc_id,dataset,datasetName,parallel)
 
  integer,          intent(inout), dimension(:,:,:,:,:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical, intent(in), optional :: parallel
 
 
  integer :: hdferr
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
  myshape = int(shape(dataset),hsize_t)
  if (any(myshape(1:size(myshape)-1) == 0)) return                                                  
 
  if (present(parallel)) then
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape, loc_id,myshape,datasetname,h5t_native_integer,parallel)
  else
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape, loc_id,myshape,datasetname,h5t_native_integer,.false.)
  endif
 
  if (product(totalshape) /= 0) then
    call h5dwrite_f(dset_id, h5t_native_integer,dataset,int(totalshape,hsize_t), hdferr,&
                   file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
   if (hdferr < 0) call io_error(1,ext_msg='HDF5_write_int5: h5dwrite_f')
  endif
 
  call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
 
end subroutine hdf5_write_int5
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_write_int6(loc_id,dataset,datasetName,parallel)
 
  integer,          intent(inout), dimension(:,:,:,:,:,:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical, intent(in), optional :: parallel
 
 
  integer :: hdferr
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
  myshape = int(shape(dataset),hsize_t)
  if (any(myshape(1:size(myshape)-1) == 0)) return                                                  
 
  if (present(parallel)) then
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape, loc_id,myshape,datasetname,h5t_native_integer,parallel)
  else
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape, loc_id,myshape,datasetname,h5t_native_integer,.false.)
  endif
 
  if (product(totalshape) /= 0) then
    call h5dwrite_f(dset_id, h5t_native_integer,dataset,int(totalshape,hsize_t), hdferr,&
                   file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
    if (hdferr < 0) call io_error(1,ext_msg='HDF5_write_int6: h5dwrite_f')
  endif
 
  call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
 
end subroutine hdf5_write_int6
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hdf5_write_int7(loc_id,dataset,datasetName,parallel)
 
  integer,          intent(inout), dimension(:,:,:,:,:,:,:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical, intent(in), optional :: parallel
 
 
  integer :: hdferr
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
  myshape = int(shape(dataset),hsize_t)
  if (any(myshape(1:size(myshape)-1) == 0)) return                                                  
 
  if (present(parallel)) then
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape, loc_id,myshape,datasetname,h5t_native_integer,parallel)
  else
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape, loc_id,myshape,datasetname,h5t_native_integer,.false.)
  endif
 
  if (product(totalshape) /= 0) then
    call h5dwrite_f(dset_id, h5t_native_integer,dataset,int(totalshape,hsize_t), hdferr,&
                   file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
    if (hdferr < 0) call io_error(1,ext_msg='HDF5_write_int7: h5dwrite_f')
  endif
 
  call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
 
end subroutine hdf5_write_int7
 
 
!--------------------------------------------------------------------------------------------------
! ToDo: It might be possible to write the dataset as a whole
! ToDo: We could optionally write out other representations (axis angle, euler, ...)
!--------------------------------------------------------------------------------------------------
subroutine hdf5_write_rotation(loc_id,dataset,datasetName,parallel)
 
  type(rotation),   intent(in), dimension(:) :: dataset
  integer(HID_T),   intent(in) :: loc_id
  character(len=*), intent(in) :: datasetName
  logical,          intent(in), optional :: parallel
 
  integer :: hdferr
  real(pReal),      dimension(4,size(dataset)) :: dataset_asArray
  integer(HID_T)   :: dset_id, filespace_id, memspace_id, plist_id,dtype_id,w_id,x_id,y_id,z_id
  integer(HSIZE_T), dimension(size(shape(dataset))) :: &
    myStart, &
    myShape, &                                                                                      !< shape of the dataset (this process)
    totalShape
   integer(SIZE_T) :: type_size_real
   integer :: i
 
   do i = 1, size(dataset)
     dataset_asarray(1:4,i) = dataset(i)%asQuaternion()
   enddo
 
!---------------------------------------------------------------------------------------------------
! determine shape of dataset
   myshape = int(shape(dataset),hsize_t)
 
!---------------------------------------------------------------------------------------------------
! compound type: name of each quaternion component
  call h5tget_size_f(h5t_native_double, type_size_real, hdferr)
 
  call h5tcreate_f(h5t_compound_f, type_size_real*4_size_t, dtype_id, hdferr)
  call h5tinsert_f(dtype_id, "w",  type_size_real*0_size_t, h5t_native_double, hdferr)
  call h5tinsert_f(dtype_id, "x",  type_size_real*1_size_t, h5t_native_double, hdferr)
  call h5tinsert_f(dtype_id, "y",  type_size_real*2_size_t, h5t_native_double, hdferr)
  call h5tinsert_f(dtype_id, "z",  type_size_real*3_size_t, h5t_native_double, hdferr)
 
  if (present(parallel)) then
    call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape, loc_id,myshape,datasetname,dtype_id,parallel)
  else
   call initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                          mystart, totalshape, loc_id,myshape,datasetname,dtype_id,.false.)
  endif
 
  call h5pset_preserve_f(plist_id, .true., hdferr)
 
  if (product(totalshape) /= 0) then
    call h5tcreate_f(h5t_compound_f, type_size_real, x_id, hdferr)
    call h5tinsert_f(x_id, "x", 0_size_t, h5t_native_double, hdferr)
    call h5tcreate_f(h5t_compound_f, type_size_real, w_id, hdferr)
    call h5tinsert_f(w_id, "w", 0_size_t, h5t_native_double, hdferr)
    call h5tcreate_f(h5t_compound_f, type_size_real, y_id, hdferr)
    call h5tinsert_f(y_id, "y", 0_size_t, h5t_native_double, hdferr)
    call h5tcreate_f(h5t_compound_f, type_size_real, z_id, hdferr)
    call h5tinsert_f(z_id, "z", 0_size_t, h5t_native_double, hdferr)
 
    call h5dwrite_f(dset_id, w_id,dataset_asarray(1,:),int(totalshape,hsize_t), hdferr,&
                   file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
    call h5dwrite_f(dset_id, x_id,dataset_asarray(2,:),int(totalshape,hsize_t), hdferr,&
                   file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
    call h5dwrite_f(dset_id, y_id,dataset_asarray(3,:),int(totalshape,hsize_t), hdferr,&
                   file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
    call h5dwrite_f(dset_id, z_id,dataset_asarray(4,:),int(totalshape,hsize_t), hdferr,&
                   file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
    if (hdferr < 0) call io_error(1,ext_msg='HDF5_write_rotation: h5dwrite_f')
  endif
 
  call finalize_write(plist_id, dset_id, filespace_id, memspace_id)
 
end subroutine hdf5_write_rotation
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, &
                           myStart, globalShape, &
                           loc_id,localShape,datasetName,parallel)
 
  integer(HID_T),    intent(in) :: loc_id
  character(len=*),  intent(in) :: datasetName
  logical,           intent(in) :: parallel
  integer(HSIZE_T),  intent(in),   dimension(:) :: &
    localShape
  integer(HSIZE_T),  intent(out), dimension(size(localShape,1)):: &
    myStart, &
    globalShape
  integer(HID_T),    intent(out) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id
 
  integer, dimension(worldsize) :: &
    readSize
  integer :: ierr
  integer :: hdferr
 
!-------------------------------------------------------------------------------------------------
! creating a property list for transfer properties (is collective for MPI)
  call h5pcreate_f(h5p_dataset_xfer_f, plist_id, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='initialize_read: h5pcreate_f')
 
!--------------------------------------------------------------------------------------------------
  readsize = 0
  readsize(worldrank+1) = int(localshape(ubound(localshape,1)))
# 1777 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/HDF5_utilities.f90"
  mystart                   = int(0,hsize_t)
  mystart(ubound(mystart))  = int(sum(readsize(1:worldrank)),hsize_t)
  globalshape = [localshape(1:ubound(localshape,1)-1),int(sum(readsize),hsize_t)]
 
!--------------------------------------------------------------------------------------------------
! create dataspace in memory (local shape)
  call h5screate_simple_f(size(localshape), localshape, memspace_id, hdferr, localshape)
  if (hdferr < 0) call io_error(1,ext_msg='initialize_read: h5screate_simple_f/memspace_id')
 
!--------------------------------------------------------------------------------------------------
! creating a property list for IO and set it to collective
  call h5pcreate_f(h5p_dataset_access_f, aplist_id, hdferr)
    if (hdferr < 0) call io_error(1,ext_msg='initialize_read: h5pcreate_f')
 
 
 
 
 
!--------------------------------------------------------------------------------------------------
! open the dataset in the file and get the space ID
  call h5dopen_f(loc_id,datasetname,dset_id,hdferr, dapl_id = aplist_id)
  if (hdferr < 0) call io_error(1,ext_msg='initialize_read: h5dopen_f')
  call h5dget_space_f(dset_id, filespace_id, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='initialize_read: h5dget_space_f')
 
!--------------------------------------------------------------------------------------------------
! select a hyperslab (the portion of the current process) in the file
  call h5sselect_hyperslab_f(filespace_id, h5s_select_set_f, mystart, localshape, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='initialize_read: h5sselect_hyperslab_f')
 
end subroutine initialize_read
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id)
 
  integer(HID_T), intent(in)   :: dset_id, filespace_id, memspace_id, plist_id, aplist_id
  integer :: hdferr
 
  call h5pclose_f(plist_id, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='finalize_read: plist_id')
  call h5pclose_f(aplist_id, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='finalize_read: aplist_id')
  call h5dclose_f(dset_id, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='finalize_read: h5dclose_f')
  call h5sclose_f(filespace_id, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='finalize_read: h5sclose_f/filespace_id')
  call h5sclose_f(memspace_id, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='finalize_read: h5sclose_f/memspace_id')
 
end subroutine finalize_read
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine initialize_write(dset_id, filespace_id, memspace_id, plist_id, &
                           myStart, totalShape, &
                           loc_id,myShape,datasetName,datatype,parallel)
 
  integer(HID_T),    intent(in) :: loc_id
  character(len=*),  intent(in) :: datasetName
  logical,           intent(in) :: parallel
  integer(HID_T),    intent(in) :: datatype
  integer(HSIZE_T),  intent(in),   dimension(:) :: &
    myShape
  integer(HSIZE_T),  intent(out), dimension(size(myShape,1)):: &
    myStart, &
    totalShape
  integer(HID_T),    intent(out) :: dset_id, filespace_id, memspace_id, plist_id
 
  integer, dimension(worldsize) :: &
    writeSize
  integer :: ierr
  integer :: hdferr
 
!-------------------------------------------------------------------------------------------------
! creating a property list for transfer properties (is collective when reading in parallel)
  call h5pcreate_f(h5p_dataset_xfer_f, plist_id, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='initialize_write: h5pcreate_f')
 
 
 
 
 
 
 
!--------------------------------------------------------------------------------------------------
! determine the global data layout among all processes
  writesize              = 0
  writesize(worldrank+1) = int(myshape(ubound(myshape,1)))
 
 
 
 
 
 
  mystart                   = int(0,hsize_t)
  mystart(ubound(mystart))  = int(sum(writesize(1:worldrank)),hsize_t)
  totalshape = [myshape(1:ubound(myshape,1)-1),int(sum(writesize),hsize_t)]
 
!--------------------------------------------------------------------------------------------------
! create dataspace in memory (local shape) and in file (global shape)
  call h5screate_simple_f(size(myshape), myshape, memspace_id, hdferr, myshape)
  if (hdferr < 0) call io_error(1,ext_msg='initialize_write: h5dopen_f')
  call h5screate_simple_f(size(totalshape), totalshape, filespace_id, hdferr, totalshape)
  if (hdferr < 0) call io_error(1,ext_msg='initialize_write: h5dget_space_f')
 
!--------------------------------------------------------------------------------------------------
! create dataset in the file and select a hyperslab from it (the portion of the current process)
  call h5dcreate_f(loc_id, trim(datasetname), datatype, filespace_id, dset_id, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='initialize_write: h5dcreate_f')
  call h5sselect_hyperslab_f(filespace_id, h5s_select_set_f, mystart, myshape, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='initialize_write: h5sselect_hyperslab_f')
 
end subroutine initialize_write
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine finalize_write(plist_id, dset_id, filespace_id, memspace_id)
 
  integer(HID_T), intent(in) :: dset_id, filespace_id, memspace_id, plist_id
  integer :: hdferr
 
  call h5pclose_f(plist_id, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='finalize_write: plist_id')
  call h5dclose_f(dset_id, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='finalize_write: h5dclose_f')
  call h5sclose_f(filespace_id, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='finalize_write: h5sclose_f/filespace_id')
  call h5sclose_f(memspace_id, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg='finalize_write: h5sclose_f/memspace_id')
 
end subroutine finalize_write
 
end module hdf5_utilities
# 19 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/results.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module results
  use damask_interface
  use rotations
  use numerics
  use hdf5_utilities
 
 
 
 
  implicit none
  private
  
  integer(HID_T) :: resultsfile
 
  interface results_writedataset
  
    module procedure results_writetensordataset_real
    module procedure results_writevectordataset_real
    module procedure results_writescalardataset_real
    
    module procedure results_writetensordataset_int
    module procedure results_writevectordataset_int
    
    module procedure results_writescalardataset_rotation
    
  end interface results_writedataset
  
  interface results_addattribute
  
    module procedure results_addattribute_real
    module procedure results_addattribute_int
    module procedure results_addattribute_str
    
    module procedure results_addattribute_int_array
    module procedure results_addattribute_real_array
    
  end interface results_addattribute
 
  public :: &
    results_init, &
    results_openjobfile, &
    results_closejobfile, &
    results_addincrement, &
    results_finalizeincrement, &
    results_addgroup, &
    results_opengroup, &
    results_closegroup, &
    results_writedataset, &
    results_setlink, &
    results_addattribute, &
    results_removelink, &
    results_mapping_constituent, &
    results_mapping_materialpoint
contains
 
subroutine results_init
 
  character(len=pStringLen) :: commandline
 
  write(6,'(/,a)') ' <<<+-  results init  -+>>>'
 
  write(6,'(/,a)') ' Diehl et al., Integrating Materials and Manufacturing Innovation 6(1):83–91, 2017'
  write(6,'(a)')   ' https://doi.org/10.1007/s40192-017-0084-5'
 
  resultsfile = hdf5_openfile(trim(getsolverjobname())//'.hdf5','w',.true.)
  call results_addattribute('DADF5_version_major',0)
  call results_addattribute('DADF5_version_minor',6)
  call results_addattribute('DAMASK_version',damaskversion)
  call get_command(commandline)
  call results_addattribute('call',trim(commandline))
  call results_closegroup(results_addgroup('mapping'))
  call results_closegroup(results_addgroup('mapping/cellResults'))
  call results_closejobfile
 
end subroutine results_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine results_openjobfile
 
  resultsfile = hdf5_openfile(trim(getsolverjobname())//'.hdf5','a',.true.)
 
end subroutine results_openjobfile
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine results_closejobfile
 
  call hdf5_closefile(resultsfile)
 
end subroutine results_closejobfile
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine results_addincrement(inc,time)
 
  integer,       intent(in) :: inc
  real(preal),   intent(in) :: time
  character(len=pStringLen) :: incchar
 
  write(incchar,'(i10)') inc
  call results_closegroup(results_addgroup(trim('inc'//trim(adjustl(incchar)))))
  call results_setlink(trim('inc'//trim(adjustl(incchar))),'current')
  call results_addattribute('time/s',time,trim('inc'//trim(adjustl(incchar))))
  call results_closegroup(results_addgroup('current/constituent'))
  call results_closegroup(results_addgroup('current/materialpoint'))
 
end subroutine results_addincrement
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine results_finalizeincrement
 
  call results_removelink('current')
 
end subroutine results_finalizeincrement
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
integer(HID_T) function results_opengroup(groupName)
 
  character(len=*), intent(in) :: groupname
  
  results_opengroup = hdf5_opengroup(resultsfile,groupname)
 
end function results_opengroup
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
integer(HID_T) function results_addgroup(groupName)
 
  character(len=*), intent(in) :: groupname
  
  results_addgroup = hdf5_addgroup(resultsfile,groupname)
 
end function results_addgroup
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine results_closegroup(group_id)
 
  integer(HID_T), intent(in) :: group_id
  
  call hdf5_closegroup(group_id)
 
end subroutine results_closegroup
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine results_setlink(path,link)
 
  character(len=*), intent(in) :: path, link
 
  call hdf5_setlink(resultsfile,path,link)
 
end subroutine results_setlink
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine results_addattribute_str(attrLabel,attrValue,path)
 
  character(len=*), intent(in)           :: attrLabel, attrValue
  character(len=*), intent(in), optional :: path
 
  if (present(path)) then
    call hdf5_addattribute(resultsfile,attrlabel, attrvalue, path)
  else
    call hdf5_addattribute(resultsfile,attrlabel, attrvalue)
  endif
 
end subroutine results_addattribute_str
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine results_addattribute_int(attrLabel,attrValue,path)
 
  character(len=*), intent(in)           :: attrLabel
  integer,          intent(in)           :: attrValue
  character(len=*), intent(in), optional :: path
 
  if (present(path)) then
    call hdf5_addattribute(resultsfile,attrlabel, attrvalue, path)
  else
    call hdf5_addattribute(resultsfile,attrlabel, attrvalue)
  endif
 
end subroutine results_addattribute_int
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine results_addattribute_real(attrLabel,attrValue,path)
 
  character(len=*), intent(in)           :: attrLabel
  real(pReal),      intent(in)           :: attrValue
  character(len=*), intent(in), optional :: path
 
  if (present(path)) then
    call hdf5_addattribute(resultsfile,attrlabel, attrvalue, path)
  else
    call hdf5_addattribute(resultsfile,attrlabel, attrvalue)
  endif
 
end subroutine results_addattribute_real
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine results_addattribute_int_array(attrLabel,attrValue,path)
 
  character(len=*), intent(in)               :: attrLabel
  integer,          intent(in), dimension(:) :: attrValue
  character(len=*), intent(in), optional     :: path
 
  if (present(path)) then
    call hdf5_addattribute(resultsfile,attrlabel, attrvalue, path)
  else
    call hdf5_addattribute(resultsfile,attrlabel, attrvalue)
  endif
 
end subroutine results_addattribute_int_array
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine results_addattribute_real_array(attrLabel,attrValue,path)
 
  character(len=*), intent(in)               :: attrLabel
  real(pReal),      intent(in), dimension(:) :: attrValue
  character(len=*), intent(in), optional     :: path
 
  if (present(path)) then
    call hdf5_addattribute(resultsfile,attrlabel, attrvalue, path)
  else
    call hdf5_addattribute(resultsfile,attrlabel, attrvalue)
  endif
 
end subroutine results_addattribute_real_array
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine results_removelink(link)
 
  character(len=*), intent(in) :: link
  integer                      :: hdferr
 
  call h5ldelete_f(resultsfile,link, hdferr)
  if (hdferr < 0) call io_error(1,ext_msg = 'results_removeLink: h5ldelete_soft_f ('//trim(link)//')')
 
end subroutine results_removelink
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine results_writescalardataset_real(group,dataset,label,description,SIunit)
 
  character(len=*), intent(in)                  :: label,group,description
  character(len=*), intent(in),    optional     :: SIunit
  real(pReal),      intent(inout), dimension(:) :: dataset
  
  integer(HID_T) :: groupHandle
 
  grouphandle = results_opengroup(group)
  
 
 
 
  call hdf5_write(grouphandle,dataset,label,.false.)
 
  
  if (hdf5_objectexists(grouphandle,label)) &
    call hdf5_addattribute(grouphandle,'Description',description,label)
  if (hdf5_objectexists(grouphandle,label) .and. present(siunit)) &
    call hdf5_addattribute(grouphandle,'Unit',siunit,label)
  if (hdf5_objectexists(grouphandle,label)) &
    call hdf5_addattribute(grouphandle,'Creator','DAMASK '//damaskversion,label)
  call hdf5_closegroup(grouphandle)
 
end subroutine results_writescalardataset_real
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine results_writevectordataset_real(group,dataset,label,description,SIunit)
 
  character(len=*), intent(in)                    :: label,group,description
  character(len=*), intent(in),    optional       :: SIunit
  real(pReal),      intent(inout), dimension(:,:) :: dataset
  
  integer(HID_T) :: groupHandle
 
  grouphandle = results_opengroup(group)
  
 
 
 
  call hdf5_write(grouphandle,dataset,label,.false.)
 
  
  if (hdf5_objectexists(grouphandle,label)) &
    call hdf5_addattribute(grouphandle,'Description',description,label)
  if (hdf5_objectexists(grouphandle,label) .and. present(siunit)) &
    call hdf5_addattribute(grouphandle,'Unit',siunit,label)
  if (hdf5_objectexists(grouphandle,label)) &
    call hdf5_addattribute(grouphandle,'Creator','DAMASK '//damaskversion,label)
  call hdf5_closegroup(grouphandle)
 
end subroutine results_writevectordataset_real
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine results_writetensordataset_real(group,dataset,label,description,SIunit,transposed)
 
  character(len=*), intent(in)                   :: label,group,description
  character(len=*), intent(in), optional         :: SIunit
  logical,          intent(in), optional         :: transposed
  real(pReal),      intent(in), dimension(:,:,:) :: dataset
  
  integer :: i 
  logical :: transposed_
  integer(HID_T) :: groupHandle
  real(pReal), dimension(:,:,:), allocatable :: dataset_transposed
 
  
  if(present(transposed)) then
    transposed_ = transposed
  else
    transposed_ = .true.
  endif
 
  if(transposed_) then
    if(size(dataset,1) /= size(dataset,2)) call io_error(0,ext_msg='transpose non-symmetric tensor')
    allocate(dataset_transposed,mold=dataset)
    do i=1,size(dataset_transposed,3)
      dataset_transposed(:,:,i) = transpose(dataset(:,:,i))
    enddo
  else
    allocate(dataset_transposed,source=dataset)
  endif
 
  grouphandle = results_opengroup(group)
  
 
 
 
  call hdf5_write(grouphandle,dataset_transposed,label,.false.)
 
  
  if (hdf5_objectexists(grouphandle,label)) &
    call hdf5_addattribute(grouphandle,'Description',description,label)
  if (hdf5_objectexists(grouphandle,label) .and. present(siunit)) &
    call hdf5_addattribute(grouphandle,'Unit',siunit,label)
  if (hdf5_objectexists(grouphandle,label)) &
    call hdf5_addattribute(grouphandle,'Creator','DAMASK '//damaskversion,label)
  call hdf5_closegroup(grouphandle)
 
end subroutine results_writetensordataset_real
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine results_writevectordataset_int(group,dataset,label,description,SIunit)
 
  character(len=*), intent(in)                :: label,group,description
  character(len=*), intent(in), optional      :: SIunit
  integer,      intent(inout), dimension(:,:) :: dataset
  
  integer(HID_T) :: groupHandle
 
  grouphandle = results_opengroup(group)
  
 
 
 
  call hdf5_write(grouphandle,dataset,label,.false.)
 
  
  if (hdf5_objectexists(grouphandle,label)) &
    call hdf5_addattribute(grouphandle,'Description',description,label)
  if (hdf5_objectexists(grouphandle,label) .and. present(siunit)) &
    call hdf5_addattribute(grouphandle,'Unit',siunit,label)
  if (hdf5_objectexists(grouphandle,label)) &
    call hdf5_addattribute(grouphandle,'Creator','DAMASK '//damaskversion,label)
  call hdf5_closegroup(grouphandle)
 
end subroutine results_writevectordataset_int
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine results_writetensordataset_int(group,dataset,label,description,SIunit)
 
  character(len=*), intent(in)                  :: label,group,description
  character(len=*), intent(in), optional        :: SIunit
  integer,      intent(inout), dimension(:,:,:) :: dataset
  
  integer(HID_T) :: groupHandle
 
  grouphandle = results_opengroup(group)
  
 
 
 
  call hdf5_write(grouphandle,dataset,label,.false.)
 
  
  if (hdf5_objectexists(grouphandle,label)) &
    call hdf5_addattribute(grouphandle,'Description',description,label)
  if (hdf5_objectexists(grouphandle,label) .and. present(siunit)) &
    call hdf5_addattribute(grouphandle,'Unit',siunit,label)
  if (hdf5_objectexists(grouphandle,label)) &
    call hdf5_addattribute(grouphandle,'Creator','DAMASK '//damaskversion,label)
  call hdf5_closegroup(grouphandle)
 
end subroutine results_writetensordataset_int
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine results_writescalardataset_rotation(group,dataset,label,description,lattice_structure)
 
  character(len=*), intent(in)                  :: label,group,description
  character(len=*), intent(in), optional        :: lattice_structure
  type(rotation),   intent(inout), dimension(:) :: dataset
  
  integer(HID_T) :: groupHandle
 
  grouphandle = results_opengroup(group)
  
 
 
 
  call hdf5_write(grouphandle,dataset,label,.false.)
 
  
  if (hdf5_objectexists(grouphandle,label)) &
    call hdf5_addattribute(grouphandle,'Description',description,label)
  if (hdf5_objectexists(grouphandle,label) .and. present(lattice_structure)) &
    call hdf5_addattribute(grouphandle,'Lattice',lattice_structure,label)
  if (hdf5_objectexists(grouphandle,label)) &
    call hdf5_addattribute(grouphandle,'Creator','DAMASK '//damaskversion,label)
  call hdf5_closegroup(grouphandle)
 
end subroutine results_writescalardataset_rotation
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine results_mapping_constituent(phaseAt,memberAtLocal,label)
    
  integer,          dimension(:,:),   intent(in) :: phaseat
  integer,                   dimension(:,:,:), intent(in) :: memberatlocal
  character(len=pStringLen), dimension(:),     intent(in) :: label
  
  integer, dimension(size(memberAtLocal,1),size(memberAtLocal,2),size(memberAtLocal,3)) :: &
    phaseatmaterialpoint, &
    memberatglobal
  integer, dimension(size(label),0:worldsize-1) :: memberoffset
  integer, dimension(0:worldsize-1)             :: writesize
  integer(HSIZE_T), dimension(2) :: &
    myshape, &                                                                                      !< shape of the dataset (this process)
    myoffset, &
    totalshape
  
  integer(HID_T) :: &
    loc_id, &                                                                                       !< identifier of group in file
    dtype_id, &                                                                                     !< identifier of compound data type
    name_id, &                                                                                      !< identifier of name (string) in compound data type
    position_id, &                                                                                  !< identifier of position/index (integer) in compound data type
    dset_id, &
    memspace_id, &
    filespace_id, &
    plist_id, &
    dt_id
 
  
  integer(SIZE_T) :: type_size_string, type_size_int
  integer         :: ierr, i
  
!---------------------------------------------------------------------------------------------------
! compound type: name of phase section + position/index within results array
  call h5tcopy_f(h5t_native_character, dt_id, ierr)
  call h5tset_size_f(dt_id, int(len(label(1)),size_t), ierr)
  call h5tget_size_f(dt_id, type_size_string, ierr)
  
  call h5tget_size_f(h5t_native_integer, type_size_int, ierr)
  
  call h5tcreate_f(h5t_compound_f, type_size_string + type_size_int, dtype_id, ierr)
  call h5tinsert_f(dtype_id, "Name", 0_size_t, dt_id,ierr)
  call h5tinsert_f(dtype_id, "Position", type_size_string, h5t_native_integer, ierr)
  
!--------------------------------------------------------------------------------------------------
! create memory types for each component of the compound type
  call h5tcreate_f(h5t_compound_f, type_size_string, name_id, ierr)
  call h5tinsert_f(name_id, "Name", 0_size_t, dt_id, ierr)
  
  call h5tcreate_f(h5t_compound_f, type_size_int, position_id, ierr)
  call h5tinsert_f(position_id, "Position", 0_size_t, h5t_native_integer, ierr)
  
  call h5tclose_f(dt_id, ierr)
 
!--------------------------------------------------------------------------------------------------
! prepare MPI communication (transparent for non-MPI runs)
  call h5pcreate_f(h5p_dataset_xfer_f, plist_id, ierr)
  memberoffset = 0
  do i=1, size(label)
    memberoffset(i,worldrank) = count(phaseat == i)*size(memberatlocal,2)                                ! number of points/instance of this process
  enddo
  writesize = 0
  writesize(worldrank) = size(memberatlocal(1,:,:))                                                      ! total number of points by this process
 
!--------------------------------------------------------------------------------------------------
! MPI settings and communication
# 563 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/results.f90"
 
  myshape    = int([size(phaseat,1),writesize(worldrank)],  hsize_t)
  myoffset   = int([0,sum(writesize(0:worldrank-1))],       hsize_t)
  totalshape = int([size(phaseat,1),sum(writesize)],        hsize_t)
  
!--------------------------------------------------------------------------------------------------
! create dataspace in memory (local shape = hyperslab) and in file (global shape)
  call h5screate_simple_f(2,myshape,memspace_id,ierr,myshape)
  if (ierr < 0) call io_error(1,ext_msg='results_mapping_constituent: h5screate_simple_f/memspace_id')
  
  call h5screate_simple_f(2,totalshape,filespace_id,ierr,totalshape)
  if (ierr < 0) call io_error(1,ext_msg='results_mapping_constituent: h5screate_simple_f/filespace_id')
  
  call h5sselect_hyperslab_f(filespace_id, h5s_select_set_f, myoffset, myshape, ierr)
  if (ierr < 0) call io_error(1,ext_msg='results_mapping_constituent: h5sselect_hyperslab_f')
 
!---------------------------------------------------------------------------------------------------
! expand phaseAt to consider IPs (is not stored per IP)
  do i = 1, size(phaseatmaterialpoint,2)
    phaseatmaterialpoint(:,i,:) = phaseat
  enddo
  
!---------------------------------------------------------------------------------------------------
! renumber member from my process to all processes
  do i = 1, size(label)
    where(phaseatmaterialpoint == i) memberatglobal = memberatlocal + sum(memberoffset(i,0:worldrank-1)) -1     ! convert to 0-based
  enddo
 
!--------------------------------------------------------------------------------------------------
! write the components of the compound type individually
  call h5pset_preserve_f(plist_id, .true., ierr)
  
  loc_id = results_opengroup('/mapping/cellResults')
  call h5dcreate_f(loc_id, 'constituent', dtype_id, filespace_id, dset_id, ierr)
  if (ierr < 0) call io_error(1,ext_msg='results_mapping_constituent: h5dcreate_f')
  
  call h5dwrite_f(dset_id, name_id, reshape(label(pack(phaseatmaterialpoint,.true.)),myshape), &
                  myshape, ierr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
  if (ierr < 0) call io_error(1,ext_msg='results_mapping_constituent: h5dwrite_f/name_id')
  call h5dwrite_f(dset_id, position_id, reshape(pack(memberatglobal,.true.),myshape), &
                  myshape, ierr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
  if (ierr < 0) call io_error(1,ext_msg='results_mapping_constituent: h5dwrite_f/position_id')
 
!--------------------------------------------------------------------------------------------------
! close all
  call hdf5_closegroup(loc_id)
  call h5pclose_f(plist_id, ierr)
  call h5sclose_f(filespace_id, ierr)
  call h5sclose_f(memspace_id, ierr)
  call h5dclose_f(dset_id, ierr)
  call h5tclose_f(dtype_id, ierr)
  call h5tclose_f(name_id, ierr)
  call h5tclose_f(position_id, ierr)
 
end subroutine results_mapping_constituent
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine results_mapping_materialpoint(homogenizationAt,memberAtLocal,label)
    
  integer,          dimension(:),   intent(in) :: homogenizationat
  integer,                   dimension(:,:), intent(in) :: memberatlocal
  character(len=pStringLen), dimension(:),   intent(in) :: label
  
  integer, dimension(size(memberAtLocal,1),size(memberAtLocal,2)) :: &
    homogenizationatmaterialpoint, &
    memberatglobal
  integer, dimension(size(label),0:worldsize-1) :: memberoffset
  integer, dimension(0:worldsize-1)             :: writesize
  integer(HSIZE_T), dimension(1) :: &
    myshape, &                                                                                      !< shape of the dataset (this process)
    myoffset, &
    totalshape
  
  integer(HID_T) :: &
    loc_id, &                                                                                       !< identifier of group in file
    dtype_id, &                                                                                     !< identifier of compound data type
    name_id, &                                                                                      !< identifier of name (string) in compound data type
    position_id, &                                                                                  !< identifier of position/index (integer) in compound data type
    dset_id, &
    memspace_id, &
    filespace_id, &
    plist_id, &
    dt_id
 
  
  integer(SIZE_T) :: type_size_string, type_size_int
  integer         :: ierr, i
  
!---------------------------------------------------------------------------------------------------
! compound type: name of phase section + position/index within results array
  call h5tcopy_f(h5t_native_character, dt_id, ierr)
  call h5tset_size_f(dt_id, int(len(label(1)),size_t), ierr)
  call h5tget_size_f(dt_id, type_size_string, ierr)
  
  call h5tget_size_f(h5t_native_integer, type_size_int, ierr)
  
  call h5tcreate_f(h5t_compound_f, type_size_string + type_size_int, dtype_id, ierr)
  call h5tinsert_f(dtype_id, "Name", 0_size_t, dt_id,ierr)
  call h5tinsert_f(dtype_id, "Position", type_size_string, h5t_native_integer, ierr)
  
!--------------------------------------------------------------------------------------------------
! create memory types for each component of the compound type
  call h5tcreate_f(h5t_compound_f, type_size_string, name_id, ierr)
  call h5tinsert_f(name_id, "Name", 0_size_t, dt_id, ierr)
  
  call h5tcreate_f(h5t_compound_f, type_size_int, position_id, ierr)
  call h5tinsert_f(position_id, "Position", 0_size_t, h5t_native_integer, ierr)
  
  call h5tclose_f(dt_id, ierr)
 
!--------------------------------------------------------------------------------------------------
! prepare MPI communication (transparent for non-MPI runs)
  call h5pcreate_f(h5p_dataset_xfer_f, plist_id, ierr)
  memberoffset = 0
  do i=1, size(label)
    memberoffset(i,worldrank) = count(homogenizationat == i)*size(memberatlocal,1)                       ! number of points/instance of this process
  enddo
  writesize = 0
  writesize(worldrank) = size(memberatlocal)                                                             ! total number of points by this process
 
!--------------------------------------------------------------------------------------------------
! MPI settings and communication
# 698 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/results.f90"
 
  myshape    = int([writesize(worldrank)],          hsize_t)
  myoffset   = int([sum(writesize(0:worldrank-1))], hsize_t)
  totalshape = int([sum(writesize)],                hsize_t)
  
!--------------------------------------------------------------------------------------------------
! create dataspace in memory (local shape = hyperslab) and in file (global shape)
  call h5screate_simple_f(1,myshape,memspace_id,ierr,myshape)
  if (ierr < 0) call io_error(1,ext_msg='results_mapping_materialpoint: h5screate_simple_f/memspace_id')
  
  call h5screate_simple_f(1,totalshape,filespace_id,ierr,totalshape)
  if (ierr < 0) call io_error(1,ext_msg='results_mapping_materialpoint: h5screate_simple_f/filespace_id')
  
  call h5sselect_hyperslab_f(filespace_id, h5s_select_set_f, myoffset, myshape, ierr)
  if (ierr < 0) call io_error(1,ext_msg='results_mapping_materialpoint: h5sselect_hyperslab_f')
 
!---------------------------------------------------------------------------------------------------
! expand phaseAt to consider IPs (is not stored per IP)
  do i = 1, size(homogenizationatmaterialpoint,1)
    homogenizationatmaterialpoint(i,:) = homogenizationat
  enddo
  
!---------------------------------------------------------------------------------------------------
! renumber member from my process to all processes
  do i = 1, size(label)
    where(homogenizationatmaterialpoint == i) memberatglobal = memberatlocal + sum(memberoffset(i,0:worldrank-1)) - 1  ! convert to 0-based
  enddo
 
!--------------------------------------------------------------------------------------------------
! write the components of the compound type individually
  call h5pset_preserve_f(plist_id, .true., ierr)
  
  loc_id = results_opengroup('/mapping/cellResults')
  call h5dcreate_f(loc_id, 'materialpoint', dtype_id, filespace_id, dset_id, ierr)
  if (ierr < 0) call io_error(1,ext_msg='results_mapping_materialpoint: h5dcreate_f')
  
  call h5dwrite_f(dset_id, name_id, reshape(label(pack(homogenizationatmaterialpoint,.true.)),myshape), &
                  myshape, ierr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
  if (ierr < 0) call io_error(1,ext_msg='results_mapping_materialpoint: h5dwrite_f/name_id')
  call h5dwrite_f(dset_id, position_id, reshape(pack(memberatglobal,.true.),myshape), &
                  myshape, ierr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
  if (ierr < 0) call io_error(1,ext_msg='results_mapping_materialpoint: h5dwrite_f/position_id')
 
!--------------------------------------------------------------------------------------------------
! close all
  call hdf5_closegroup(loc_id)
  call h5pclose_f(plist_id, ierr)
  call h5sclose_f(filespace_id, ierr)
  call h5sclose_f(memspace_id, ierr)
  call h5dclose_f(dset_id, ierr)
  call h5tclose_f(dtype_id, ierr)
  call h5tclose_f(name_id, ierr)
  call h5tclose_f(position_id, ierr)
 
end subroutine results_mapping_materialpoint
 
 
!!--------------------------------------------------------------------------------------------------
!!> @brief adds the backward mapping from spatial position and constituent ID to results
!!--------------------------------------------------------------------------------------------------
!subroutine HDF5_backwardMappingPhase(material_phase,phasememberat,phase_name,dataspace_size,mpiOffset,mpiOffset_phase)
 
! integer(pInt),    intent(in), dimension(:,:,:) :: material_phase, phasememberat
! character(len=*), intent(in), dimension(:)     :: phase_name
! integer(pInt),    intent(in), dimension(:)     :: dataspace_size, mpiOffset_phase
! integer(pInt),    intent(in)                   :: mpiOffset
 
! integer(pInt)   :: hdferr, NmatPoints, Nconstituents, i, j
! integer(HID_T)  :: mapping_id, dtype_id, dset_id, space_id, position_id, plist_id, memspace
! integer(SIZE_T) :: type_size
 
! integer(pInt), dimension(:,:), allocatable :: arr
 
! integer(HSIZE_T),  dimension(1) :: counter
! integer(HSSIZE_T), dimension(1) :: fileOffset
 
! character(len=64) :: phaseID
 
! Nconstituents = size(phasememberat,1)
! NmatPoints = count(material_phase /=0)/Nconstituents
 
! allocate(arr(2,NmatPoints*Nconstituents))
 
! do i=1, NmatPoints
!   do j=Nconstituents-1, 0, -1
!     arr(1,Nconstituents*i-j) = i-1
!   enddo
! enddo
! arr(2,:) = pack(material_phase,material_phase/=0)
 
! do i=1, size(phase_name)
!   write(phaseID, '(i0)') i
!   mapping_ID = results_openGroup('/current/constitutive/'//trim(phaseID)//'_'//phase_name(i))
!   NmatPoints = count(material_phase == i)
 
!!--------------------------------------------------------------------------------------------------
!  ! create dataspace
!   call h5screate_simple_f(1, int([dataspace_size(i)],HSIZE_T), space_id, hdferr, &
!                              int([dataspace_size(i)],HSIZE_T))
!   if (hdferr < 0) call IO_error(1,ext_msg='HDF5_writeBackwardMapping')
 
!!--------------------------------------------------------------------------------------------------
!  ! compound type
!   call h5tget_size_f(H5T_STD_I32LE, type_size, hdferr)
!   call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='HDF5_writeBackwardMapping: h5tcreate_f dtype_id')
 
!   call h5tinsert_f(dtype_id, "Position",          0_SIZE_T, H5T_STD_I32LE, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5tinsert_f 0')
 
!!--------------------------------------------------------------------------------------------------
!  ! create Dataset
!   call h5dcreate_f(mapping_id, 'mapGeometry', dtype_id, space_id, dset_id, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase')
 
!!--------------------------------------------------------------------------------------------------
!  ! Create memory types (one compound datatype for each member)
!   call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5tcreate_f position_id')
!   call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5tinsert_f position_id')
 
!!--------------------------------------------------------------------------------------------------
!  ! Define and select hyperslabs
!   counter = NmatPoints                       ! how big i am
!   fileOffset = mpiOffset_phase(i)            ! where i start to write my data
 
!   call h5screate_simple_f(1, counter, memspace, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5screate_simple_f')
!   call h5dget_space_f(dset_id, space_id, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5dget_space_f')
!   call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5sselect_hyperslab_f')
 
!!--------------------------------------------------------------------------------------------------
! ! Create property list for collective dataset write
!#ifdef PETSc
!   call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5pcreate_f')
!   call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5pset_dxpl_mpio_f')
!#endif
 
!!--------------------------------------------------------------------------------------------------
!  ! write data by fields in the datatype. Fields order is not important.
!   call h5dwrite_f(dset_id, position_id, pack(arr(1,:),arr(2,:)==i)+mpiOffset, int([dataspace_size(i)],HSIZE_T),&
!                              hdferr, file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5dwrite_f instance_id')
 
!!--------------------------------------------------------------------------------------------------
!  !close types, dataspaces
!   call h5tclose_f(dtype_id, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5tclose_f dtype_id')
!   call h5tclose_f(position_id, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5tclose_f position_id')
!   call h5dclose_f(dset_id, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5dclose_f')
!   call h5sclose_f(space_id, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5sclose_f space_id')
!   call h5sclose_f(memspace, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5sclose_f memspace')
!   call h5pclose_f(plist_id, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5pclose_f')
!   call HDF5_closeGroup(mapping_ID)
 
! enddo
 
!end subroutine HDF5_backwardMappingPhase
 
 
!!--------------------------------------------------------------------------------------------------
!!> @brief adds the backward mapping from spatial position and constituent ID to results
!!--------------------------------------------------------------------------------------------------
!subroutine HDF5_backwardMappingHomog(material_homog,homogmemberat,homogenization_name,dataspace_size,mpiOffset,mpiOffset_homog)
 
! integer(pInt),    intent(in), dimension(:,:) :: material_homog, homogmemberat
! character(len=*), intent(in), dimension(:)   :: homogenization_name
! integer(pInt),    intent(in), dimension(:)   :: dataspace_size, mpiOffset_homog
! integer(pInt),    intent(in)                 :: mpiOffset
 
! integer(pInt)   :: hdferr, NmatPoints, i
! integer(HID_T)  :: mapping_id, dtype_id, dset_id, space_id, position_id, plist_id, memspace
! integer(SIZE_T) :: type_size
 
! integer(pInt),     dimension(:,:), allocatable :: arr
 
! integer(HSIZE_T),  dimension(1) :: counter
! integer(HSSIZE_T), dimension(1) :: fileOffset
 
! character(len=64) :: homogID
 
! NmatPoints = count(material_homog /=0)
! allocate(arr(2,NmatPoints))
 
! arr(1,:) = (/(i, i=0,NmatPoints-1)/)
! arr(2,:) = pack(material_homog,material_homog/=0)
 
! do i=1, size(homogenization_name)
!   write(homogID, '(i0)') i
!   mapping_ID = results_openGroup('/current/homogenization/'//trim(homogID)//'_'//homogenization_name(i))
 
!!--------------------------------------------------------------------------------------------------
!  ! create dataspace
!   call h5screate_simple_f(1, int([dataspace_size(i)],HSIZE_T), space_id, hdferr, &
!                              int([dataspace_size(i)],HSIZE_T))
!   if (hdferr < 0) call IO_error(1,ext_msg='HDF5_writeBackwardMapping')
 
!!--------------------------------------------------------------------------------------------------
!  ! compound type
!   call h5tget_size_f(H5T_STD_I32LE, type_size, hdferr)
!   call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='HDF5_writeBackwardMapping: h5tcreate_f dtype_id')
 
!   call h5tinsert_f(dtype_id, "Position",          0_SIZE_T, H5T_STD_I32LE, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5tinsert_f 0')
 
!!--------------------------------------------------------------------------------------------------
!  ! create Dataset
!   call h5dcreate_f(mapping_id, 'mapGeometry', dtype_id, space_id, dset_id, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog')
 
!!--------------------------------------------------------------------------------------------------
!  ! Create memory types (one compound datatype for each member)
!   call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5tcreate_f position_id')
!   call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5tinsert_f position_id')
 
!!--------------------------------------------------------------------------------------------------
!  ! Define and select hyperslabs
!   counter = NmatPoints                           ! how big i am
!   fileOffset = mpiOffset_homog(i)                ! where i start to write my data
 
!   call h5screate_simple_f(1, counter, memspace, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5screate_simple_f')
!   call h5dget_space_f(dset_id, space_id, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5dget_space_f')
!   call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5sselect_hyperslab_f')
 
!!--------------------------------------------------------------------------------------------------
! ! Create property list for collective dataset write
!#ifdef PETSc
!   call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5pcreate_f')
!   call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5pset_dxpl_mpio_f')
!#endif
 
!!--------------------------------------------------------------------------------------------------
!  ! write data by fields in the datatype. Fields order is not important.
!   call h5dwrite_f(dset_id, position_id, pack(arr(1,:),arr(2,:)==i)+mpiOffset,int([dataspace_size(i)],HSIZE_T),&
!                   hdferr, file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5dwrite_f instance_id')
 
!!--------------------------------------------------------------------------------------------------
!  !close types, dataspaces
!   call h5tclose_f(dtype_id, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5tclose_f dtype_id')
!   call h5tclose_f(position_id, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5tclose_f position_id')
!   call h5dclose_f(dset_id, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5dclose_f')
!   call h5sclose_f(space_id, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5sclose_f space_id')
!   call h5sclose_f(memspace, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5sclose_f memspace')
!   call h5pclose_f(plist_id, hdferr)
!   if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5pclose_f')
!   call HDF5_closeGroup(mapping_ID)
 
! enddo
 
!end subroutine HDF5_backwardMappingHomog
 
 
!!--------------------------------------------------------------------------------------------------
!!> @brief adds the unique cell to node mapping
!!--------------------------------------------------------------------------------------------------
!subroutine HDF5_mappingCells(mapping)
 
! integer(pInt), intent(in), dimension(:) :: mapping
 
! integer        :: hdferr, Nnodes
! integer(HID_T) :: mapping_id, dset_id, space_id
 
! Nnodes=size(mapping)
! mapping_ID = results_openGroup("mapping")
 
!!--------------------------------------------------------------------------------------------------
!! create dataspace
! call h5screate_simple_f(1, int([Nnodes],HSIZE_T), space_id, hdferr, &
!                            int([Nnodes],HSIZE_T))
! if (hdferr < 0) call IO_error(1,ext_msg='IO_mappingCells: h5screate_simple_f')
 
!!--------------------------------------------------------------------------------------------------
!! create Dataset
! call h5dcreate_f(mapping_id, "Cell",H5T_NATIVE_INTEGER, space_id, dset_id, hdferr)
! if (hdferr < 0) call IO_error(1,ext_msg='IO_mappingCells')
 
!!--------------------------------------------------------------------------------------------------
!! write data by fields in the datatype. Fields order is not important.
! call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, mapping, int([Nnodes],HSIZE_T), hdferr)
! if (hdferr < 0) call IO_error(1,ext_msg='IO_mappingCells: h5dwrite_f instance_id')
 
!!--------------------------------------------------------------------------------------------------
!!close types, dataspaces
! call h5dclose_f(dset_id, hdferr)
! if (hdferr < 0) call IO_error(1,ext_msg='IO_mappingConstitutive: h5dclose_f')
! call h5sclose_f(space_id, hdferr)
! if (hdferr < 0) call IO_error(1,ext_msg='IO_mappingConstitutive: h5sclose_f')
! call HDF5_closeGroup(mapping_ID)
 
!end subroutine HDF5_mappingCells
 
end module results
# 20 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/geometry_plastic_nonlocal.f90" 1
!--------------------------------------------------------------------------------------------------
! plasticity model
!--------------------------------------------------------------------------------------------------
module geometry_plastic_nonlocal
  use prec
  use results
 
  implicit none
  public
  
  integer, protected :: &
    geometry_plastic_nonlocal_nipneighbors
  
  integer,     dimension(:,:,:,:), allocatable, protected :: &
    geometry_plastic_nonlocal_ipneighborhood
 
  real(preal), dimension(:,:),     allocatable, protected :: &
    geometry_plastic_nonlocal_ipvolume0
 
  real(preal), dimension(:,:,:),   allocatable, protected :: &
    geometry_plastic_nonlocal_iparea0
  
  real(preal), dimension(:,:,:,:), allocatable, protected :: &
    geometry_plastic_nonlocal_ipareanormal0
  
 
contains
 
!---------------------------------------------------------------------------------------------------
!            face ID (second index) gives the element ID (1 @ first index), IP ID (2 @ first index)
!            and face ID (3 @ first index).
!            A triangle (2D) has 3 faces, a quadrilateral (2D) had 4 faces, a tetrahedron (3D) has
!            4 faces, and a hexahedron (3D) has 6 faces.
!---------------------------------------------------------------------------------------------------
subroutine geometry_plastic_nonlocal_setipneighborhood(IPneighborhood)
 
  integer, dimension(:,:,:,:), intent(in) :: IPneighborhood
 
  geometry_plastic_nonlocal_ipneighborhood = ipneighborhood
  geometry_plastic_nonlocal_nipneighbors   = size(ipneighborhood,2)
  
 
end subroutine geometry_plastic_nonlocal_setipneighborhood
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
subroutine geometry_plastic_nonlocal_setipvolume(IPvolume)
 
  real(pReal), dimension(:,:), intent(in) :: IPvolume
 
  geometry_plastic_nonlocal_ipvolume0 = ipvolume
 
end subroutine geometry_plastic_nonlocal_setipvolume
 
 
!---------------------------------------------------------------------------------------------------
!         encompassing an integration point
!---------------------------------------------------------------------------------------------------
subroutine geometry_plastic_nonlocal_setiparea(IParea)
 
  real(pReal), dimension(:,:,:), intent(in) :: IParea
 
  geometry_plastic_nonlocal_iparea0 = iparea
 
end subroutine geometry_plastic_nonlocal_setiparea
 
 
!---------------------------------------------------------------------------------------------------
!         encompassing an integration point
!---------------------------------------------------------------------------------------------------
subroutine geometry_plastic_nonlocal_setipareanormal(IPareaNormal)
 
  real(pReal), dimension(:,:,:,:), intent(in) :: IPareaNormal
 
  geometry_plastic_nonlocal_ipareanormal0 = ipareanormal
 
end subroutine geometry_plastic_nonlocal_setipareanormal
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
subroutine geometry_plastic_nonlocal_disable
 
  if(allocated(geometry_plastic_nonlocal_ipneighborhood)) &
    deallocate(geometry_plastic_nonlocal_ipneighborhood)
    
  if(allocated(geometry_plastic_nonlocal_ipvolume0)) &
    deallocate(geometry_plastic_nonlocal_ipvolume0)
    
  if(allocated(geometry_plastic_nonlocal_iparea0)) &
    deallocate(geometry_plastic_nonlocal_iparea0)
    
  if(allocated(geometry_plastic_nonlocal_ipareanormal0)) &
    deallocate(geometry_plastic_nonlocal_ipareanormal0)
  
end subroutine geometry_plastic_nonlocal_disable
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
subroutine geometry_plastic_nonlocal_results
  
  integer,     dimension(:),   allocatable :: shp
 
  call results_openjobfile
 
  writevolume: block
    real(pReal), dimension(:), allocatable :: temp
    shp = shape(geometry_plastic_nonlocal_ipvolume0)
    temp = reshape(geometry_plastic_nonlocal_ipvolume0,[shp(1)*shp(2)])
    call results_writedataset('geometry',temp,'v_0',&
                              'initial cell volume','m³')
  end block writevolume
 
  writeareas: block
    real(pReal), dimension(:,:), allocatable :: temp
    shp = shape(geometry_plastic_nonlocal_iparea0)
    temp = reshape(geometry_plastic_nonlocal_iparea0,[shp(1),shp(2)*shp(3)])
    call results_writedataset('geometry',temp,'a_0',&
                              'initial cell face area','m²')
  end block writeareas
 
  writenormals: block
    real(pReal), dimension(:,:,:), allocatable :: temp
    shp = shape(geometry_plastic_nonlocal_ipareanormal0)
    temp = reshape(geometry_plastic_nonlocal_ipareanormal0,[shp(1),shp(2),shp(3)*shp(4)])
    call results_writedataset('geometry',temp,'n_0',&
                              'initial cell face normals','-',transposed=.false.)
  end block writenormals
 
 
  call results_closejobfile
  
end subroutine geometry_plastic_nonlocal_results
 
end module geometry_plastic_nonlocal
# 21 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/discretization.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module discretization
 
  use prec
  use results
 
  implicit none
  private
  
  integer,     public, protected :: &
    discretization_nip, &
    discretization_nelem
    
  integer,     public, protected, dimension(:),   allocatable :: &
    discretization_homogenizationat, &
    discretization_microstructureat   
 
  real(preal), public, protected, dimension(:,:), allocatable :: & 
    discretization_ipcoords0, &
    discretization_ipcoords, &
    discretization_nodecoords0, &
    discretization_nodecoords
    
  integer :: &
    discretization_sharednodesbegin
 
  public :: &
    discretization_init, &
    discretization_results, &
    discretization_setipcoords, &
    discretization_setnodecoords
 
contains
  
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine discretization_init(homogenizationAt,microstructureAt,&
                               IPcoords0,NodeCoords0,&
                               sharedNodesBegin)
 
  integer,     dimension(:),   intent(in) :: &
    homogenizationat, &
    microstructureat
  real(preal), dimension(:,:), intent(in) :: &
    ipcoords0, &
    nodecoords0
  integer, optional,           intent(in) :: &
    sharednodesbegin
 
  write(6,'(/,a)') ' <<<+-  discretization init  -+>>>'; flush(6)
 
  discretization_nelem = size(microstructureat,1)
  discretization_nip   = size(ipcoords0,2)/discretization_nelem
 
  discretization_homogenizationat = homogenizationat
  discretization_microstructureat = microstructureat  
 
  discretization_ipcoords0   = ipcoords0
  discretization_ipcoords    = ipcoords0
 
  discretization_nodecoords0 = nodecoords0
  discretization_nodecoords  = nodecoords0
  
  if(present(sharednodesbegin)) then
    discretization_sharednodesbegin = sharednodesbegin
  else
    discretization_sharednodesbegin = size(discretization_nodecoords0,2)
  endif
  
end subroutine discretization_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine discretization_results
 
  real(preal), dimension(:,:), allocatable :: u
  
  call results_closegroup(results_addgroup('current/geometry'))
  
  u = discretization_nodecoords(1:3,:discretization_sharednodesbegin) &
    - discretization_nodecoords0(1:3,:discretization_sharednodesbegin)
  call results_writedataset('current/geometry',u,'u_n','displacements of the nodes','m')
  
  u = discretization_ipcoords &
    - discretization_ipcoords0
  call results_writedataset('current/geometry',u,'u_p','displacements of the materialpoints','m')
 
end subroutine discretization_results
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine discretization_setipcoords(IPcoords)
 
  real(preal), dimension(:,:), intent(in) :: ipcoords
  
  discretization_ipcoords = ipcoords
 
end subroutine discretization_setipcoords
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine discretization_setnodecoords(NodeCoords)
 
  real(preal), dimension(:,:), intent(in) :: nodecoords
  
  discretization_nodecoords = nodecoords
 
end subroutine discretization_setnodecoords
 
 
end module discretization
# 22 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/marc/discretization_marc.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module discretization_marc
  use io
  use prec
  use math
  use damask_interface
  use io
  use debug
  use numerics
  use fesolving
  use element
  use discretization
  use geometry_plastic_nonlocal
  use results
 
  implicit none
  private
  
  type tcellnodedefinition
    integer, dimension(:,:), allocatable :: parents
    integer, dimension(:,:), allocatable :: weights
  end type tcellnodedefinition
  
  type(tcellnodedefinition), dimension(:), allocatable :: cellnodedefinition
  
  real(preal), public, protected :: &
    mesh_unitlength
 
  integer, dimension(:),   allocatable, public :: &
    mesh_fem2damask_elem, &                                                                          !< DAMASK element ID for Marc element ID
    mesh_fem2damask_node
 
  public :: &
    discretization_marc_init
 
contains
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine discretization_marc_init(ip,el)
 
  integer, intent(in) :: el, ip
   
  real(preal), dimension(:,:), allocatable :: &
   node0_elem, &                                                                                    !< node x,y,z coordinates (initially!)
   node0_cell
  type(telement) :: elem
 
  integer,     dimension(:),   allocatable :: &
    microstructureat, &
    homogenizationat
  integer:: &
    nnodes, &                                                                                       !< total number of nodes in the mesh
    nelems
   
  real(preal), dimension(:,:), allocatable :: &
    ip_reshaped
  integer,dimension(:,:,:), allocatable :: &
    connectivity_cell
  integer, dimension(:,:), allocatable :: &
    connectivity_elem
  real(preal), dimension(:,:,:,:),allocatable :: &
    unscalednormals
 
  write(6,'(/,a)') ' <<<+-  mesh init  -+>>>'; flush(6)
 
  mesh_unitlength = numerics_unitlength                                                             ! set physical extent of a length unit in mesh
 
  call inputread(elem,node0_elem,connectivity_elem,microstructureat,homogenizationat)
  nelems = size(connectivity_elem,2)
 
  if (debug_e < 1 .or. debug_e > nelems)    call io_error(602,ext_msg='element')
  if (debug_i < 1 .or. debug_i > elem%nIPs) call io_error(602,ext_msg='IP')
 
  fesolving_execelem = [1,nelems]
  fesolving_execip   = [1,elem%nIPs]
 
  allocate(calcmode(elem%nIPs,nelems),source=.false.)                                               ! pretend to have collected what first call is asking (F = I)
  calcmode(ip,mesh_fem2damask_elem(el)) = .true.                                                    ! first ip,el needs to be already pingponged to "calc"
 
 
  allocate(cellnodedefinition(elem%nNodes-1))
  allocate(connectivity_cell(elem%NcellNodesPerCell,elem%nIPs,nelems))
  call buildcells(connectivity_cell,cellnodedefinition,&
                  elem,connectivity_elem)
  allocate(node0_cell(3,maxval(connectivity_cell)))
  call buildcellnodes(node0_cell,&
                      cellnodedefinition,node0_elem)
  allocate(ip_reshaped(3,elem%nIPs*nelems),source=0.0_preal)
  call buildipcoordinates(ip_reshaped,reshape(connectivity_cell,[elem%NcellNodesPerCell,&
                          elem%nIPs*nelems]),node0_cell)
 
  call discretization_init(microstructureat,homogenizationat,&
                           ip_reshaped,&
                           node0_cell)
                           
  call writegeometry(elem,connectivity_elem,&
                     reshape(connectivity_cell,[elem%NcellNodesPerCell,elem%nIPs*nelems]),&
                     node0_cell,ip_reshaped)
 
!--------------------------------------------------------------------------------------------------
! geometry information required by the nonlocal CP model
  call geometry_plastic_nonlocal_setipvolume(ipvolume(elem,node0_cell,connectivity_cell))
  unscalednormals = ipareanormal(elem,nelems,connectivity_cell,node0_cell)
  call geometry_plastic_nonlocal_setiparea(norm2(unscalednormals,1))
  call geometry_plastic_nonlocal_setipareanormal(unscalednormals/spread(norm2(unscalednormals,1),1,3))
  call geometry_plastic_nonlocal_results
  
end subroutine discretization_marc_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine writegeometry(elem, &
                         connectivity_elem,connectivity_cell, &
                         coordinates_nodes,coordinates_points)
 
  type(telement),              intent(in) :: &
    elem
  integer, dimension(:,:),     intent(in) :: &
    connectivity_elem, &
    connectivity_cell
  real(pReal), dimension(:,:), intent(in) :: &
    coordinates_nodes, &
    coordinates_points
  
  integer,     dimension(:,:), allocatable :: &
    connectivity_temp
  real(pReal), dimension(:,:), allocatable :: &
    coordinates_temp
 
  call results_openjobfile
  call results_closegroup(results_addgroup('geometry'))
  
  connectivity_temp = connectivity_elem
  call results_writedataset('geometry',connectivity_temp,'T_e',&
                            'connectivity of the elements','-')
                            
  connectivity_temp = connectivity_cell
  call results_writedataset('geometry',connectivity_temp,'T_c', &
                            'connectivity of the cells','-')
  call results_addattribute('VTK_TYPE',elem%vtkType,'geometry/T_c')
                            
  coordinates_temp = coordinates_nodes
  call results_writedataset('geometry',coordinates_temp,'x_n', &
                            'initial coordinates of the nodes','m')
                            
  coordinates_temp = coordinates_points
  call results_writedataset('geometry',coordinates_temp,'x_p', &
                            'initial coordinates of the materialpoints','m')
                      
  call results_closejobfile
 
end subroutine writegeometry
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine inputread(elem,node0_elem,connectivity_elem,microstructureAt,homogenizationAt)
 
  type(telement), intent(out) :: elem
  real(pReal), dimension(:,:), allocatable, intent(out) :: &
    node0_elem
  integer, dimension(:,:),     allocatable, intent(out) :: &
    connectivity_elem
  integer,     dimension(:),   allocatable, intent(out) :: &
    microstructureAt, &
    homogenizationAt
   
  integer :: &
    fileFormatVersion, &
    hypoelasticTableStyle, &
    initialcondTableStyle, &
    nNodes, &
    nElems
  integer, dimension(:), allocatable :: &
    matNumber
  character(len=pStringLen), dimension(:), allocatable :: inputFile
  
  character(len=pStringLen), dimension(:), allocatable :: &
    nameElemSet
  integer, dimension(:,:), allocatable :: &
    mapElemSet
 
  inputfile = io_read_ascii(trim(getsolverjobname())//trim(inputfileextension))
  call inputread_fileformat(fileformatversion, &
                            inputfile)
  call inputread_tablestyles(initialcondtablestyle,hypoelastictablestyle, &
                             inputfile)
  if (fileformatversion > 12) &
    call inputread_matnumber(matnumber, &
                             hypoelastictablestyle,inputfile)
  call inputread_nnodesandelements(nnodes,nelems,&
                                   inputfile)
  
  
  call inputread_mapelemsets(nameelemset,mapelemset,&
                             inputfile)
 
  call inputread_elemtype(elem, &
                          nelems,inputfile)
 
  call inputread_mapelems(mesh_fem2damask_elem,&
                          nelems,elem%nNodes,inputfile)
 
  call inputread_mapnodes(mesh_fem2damask_node,&
                          nnodes,inputfile)
 
  call inputread_elemnodes(node0_elem, &
                           nnodes,inputfile)
 
  connectivity_elem = inputread_connectivityelem(nelems,elem%nNodes,inputfile)
 
  call inputread_microstructureandhomogenization(microstructureat,homogenizationat, &
                                                 nelems,elem%nNodes,nameelemset,mapelemset,&
                                                 initialcondtablestyle,inputfile)
end subroutine inputread
 
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine inputread_fileformat(fileFormat,fileContent)
 
  integer,                        intent(out) :: fileFormat
  character(len=*), dimension(:), intent(in)  :: fileContent
  
  integer, allocatable, dimension(:) :: chunkPos
  integer :: l
  
  do l = 1, size(filecontent)
    chunkpos = io_stringpos(filecontent(l))
    if(chunkpos(1) < 2) cycle
    if(io_lc(io_stringvalue(filecontent(l),chunkpos,1)) == 'version') then
      fileformat = io_intvalue(filecontent(l),chunkpos,2)
      exit
    endif
  enddo
 
end subroutine inputread_fileformat
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine inputread_tablestyles(initialcond,hypoelastic,fileContent)
 
  integer,                        intent(out) :: initialcond, hypoelastic
  character(len=*), dimension(:), intent(in)  :: fileContent
 
  integer, allocatable, dimension(:) :: chunkPos
  integer :: l
  
  initialcond = 0
  hypoelastic = 0
 
  do l = 1, size(filecontent)
    chunkpos = io_stringpos(filecontent(l))
    if(chunkpos(1) < 6) cycle
    if(io_lc(io_stringvalue(filecontent(l),chunkpos,1)) == 'table') then
      initialcond = io_intvalue(filecontent(l),chunkpos,4)
      hypoelastic = io_intvalue(filecontent(l),chunkpos,5)
      exit
    endif
  enddo
 
end subroutine inputread_tablestyles
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine inputread_matnumber(matNumber, &
                               tableStyle,fileContent)
 
  integer, allocatable, dimension(:), intent(out) :: matNumber
  integer,                            intent(in)  :: tableStyle
  character(len=*),     dimension(:), intent(in)  :: fileContent
 
  integer, allocatable, dimension(:) :: chunkPos
  integer :: i, j, data_blocks, l
 
  do l = 1, size(filecontent)
    chunkpos = io_stringpos(filecontent(l))
    if(chunkpos(1) < 1) cycle
    if(io_lc(io_stringvalue(filecontent(l),chunkpos,1)) == 'hypoelastic') then
      if (len_trim(filecontent(l+1))/=0) then
        chunkpos = io_stringpos(filecontent(l+1))
        data_blocks = io_intvalue(filecontent(l+1),chunkpos,1)
      else
        data_blocks = 1
      endif
      allocate(matnumber(data_blocks), source = 0)
      do i = 0, data_blocks - 1
        j = i*(2+tablestyle) + 1
        chunkpos = io_stringpos(filecontent(l+1+j))
        matnumber(i+1) = io_intvalue(filecontent(l+1+j),chunkpos,1)
      enddo
      exit
    endif
  enddo
 
end subroutine inputread_matnumber
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine inputread_nnodesandelements(nNodes,nElems,&
                                       fileContent)
  
  integer,                        intent(out) :: nNodes, nElems
  character(len=*), dimension(:), intent(in)  :: fileContent
 
  integer, allocatable, dimension(:) :: chunkPos
  integer :: l
 
  nnodes = 0
  nelems = 0
 
  do l = 1, size(filecontent)
    chunkpos = io_stringpos(filecontent(l))
    if(chunkpos(1) < 1) cycle
    if    (io_lc(io_stringvalue(filecontent(l),chunkpos,1)) == 'sizing') then
      nelems = io_intvalue(filecontent(l),chunkpos,3)
    elseif(io_lc(io_stringvalue(filecontent(l),chunkpos,1)) == 'coordinates') then
      chunkpos = io_stringpos(filecontent(l+1))
      nnodes = io_intvalue(filecontent(l+1),chunkpos,2)
    endif
  enddo
 
end subroutine inputread_nnodesandelements
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine inputread_nelemsets(nElemSets,maxNelemInSet,&
                               fileContent)
 
  integer,                            intent(out) :: nElemSets, maxNelemInSet
  character(len=*),     dimension(:), intent(in)  :: fileContent
 
  integer, allocatable, dimension(:) :: chunkPos
  integer                            :: i,l,elemInCurrentSet
 
  nelemsets     = 0
  maxneleminset = 0
 
  do l = 1, size(filecontent)
    chunkpos = io_stringpos(filecontent(l))
    if(chunkpos(1) < 2) cycle
    if(io_lc(io_stringvalue(filecontent(l),chunkpos,1)) == 'define' .and. &
       io_lc(io_stringvalue(filecontent(l),chunkpos,2)) == 'element') then
      nelemsets = nelemsets + 1
 
      chunkpos = io_stringpos(filecontent(l+1))
      if(containsrange(filecontent(l+1),chunkpos)) then
        elemincurrentset = 1 + abs( io_intvalue(filecontent(l+1),chunkpos,3) &
                                   -io_intvalue(filecontent(l+1),chunkpos,1))
      else
        elemincurrentset = 0
        i = 0
        do while (.true.)
          i = i + 1
          chunkpos = io_stringpos(filecontent(l+i))
          elemincurrentset = elemincurrentset + chunkpos(1) - 1                                     ! add line's count when assuming 'c'
          if(io_lc(io_stringvalue(filecontent(l+i),chunkpos,chunkpos(1))) /= 'c') then              ! line finished, read last value
            elemincurrentset = elemincurrentset + 1                                                 ! data ended
            exit
          endif
        enddo
      endif
      maxneleminset = max(maxneleminset, elemincurrentset)
    endif
  enddo
 
end subroutine inputread_nelemsets
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine inputread_mapelemsets(nameElemSet,mapElemSet,&
                                 fileContent)
 
  character(len=pStringLen), dimension(:),   allocatable, intent(out) :: nameElemSet
  integer,                   dimension(:,:), allocatable, intent(out) :: mapElemSet
  character(len=*),          dimension(:),                intent(in)  :: fileContent
 
  integer, allocatable, dimension(:) :: chunkPos
  integer :: elemSet, NelemSets, maxNelemInSet,l
 
 
  call inputread_nelemsets(nelemsets,maxneleminset,filecontent)
  allocate(nameelemset(nelemsets)); nameelemset = 'n/a'
  allocate(mapelemset(1+maxneleminset,nelemsets),source=0)
  elemset = 0
 
  do l = 1, size(filecontent)
    chunkpos = io_stringpos(filecontent(l))
    if(chunkpos(1) < 2) cycle
    if(io_lc(io_stringvalue(filecontent(l),chunkpos,1)) == 'define' .and. &
       io_lc(io_stringvalue(filecontent(l),chunkpos,2)) == 'element') then
       elemset = elemset+1
       nameelemset(elemset)  = trim(io_stringvalue(filecontent(l),chunkpos,4))
       mapelemset(:,elemset) = continuousintvalues(filecontent(l+1:),size(mapelemset,1)-1,nameelemset,mapelemset,size(nameelemset))
    endif
  enddo
 
end subroutine inputread_mapelemsets
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine inputread_mapelems(FEM2DAMASK, &
                              nElems,nNodesPerElem,fileContent)
 
  integer, allocatable, dimension(:), intent(out) :: FEM2DAMASK
 
  integer,                            intent(in)  :: nElems, &                                      !< number of elements
                                                     nNodesPerElem
  character(len=*),     dimension(:), intent(in)  :: fileContent
 
  integer, dimension(2,nElems)       :: map_unsorted
  integer, allocatable, dimension(:) :: chunkPos
  integer :: i,j,l,nNodesAlreadyRead
 
  do l = 1, size(filecontent)
    chunkpos = io_stringpos(filecontent(l))
    if(chunkpos(1) < 1) cycle
    if(io_lc(io_stringvalue(filecontent(l),chunkpos,1)) == 'connectivity') then
      j = 0
      do i = 1,nelems
        chunkpos = io_stringpos(filecontent(l+1+i+j))
        map_unsorted(:,i) = [io_intvalue(filecontent(l+1+i+j),chunkpos,1),i]
        nnodesalreadyread = chunkpos(1) - 2
        do while(nnodesalreadyread < nnodesperelem)                                                 ! read on if not all nodes in one line
          j = j + 1
          chunkpos = io_stringpos(filecontent(l+1+i+j))
          nnodesalreadyread = nnodesalreadyread + chunkpos(1)
        enddo
      enddo
      exit
    endif
  enddo
 
  call math_sort(map_unsorted)
  allocate(fem2damask(minval(map_unsorted(1,:)):maxval(map_unsorted(1,:))),source=-1)
  do i = 1, nelems
    fem2damask(map_unsorted(1,i)) = map_unsorted(2,i)
  enddo
 
end subroutine inputread_mapelems
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine inputread_mapnodes(FEM2DAMASK, &
                              nNodes,fileContent)
 
  integer, allocatable, dimension(:), intent(out) :: FEM2DAMASK
 
  integer,                            intent(in)  :: nNodes
  character(len=*),     dimension(:), intent(in)  :: fileContent
 
  integer, dimension(2,nNodes)       :: map_unsorted
  integer, allocatable, dimension(:) :: chunkPos
  integer :: i, l
 
  do l = 1, size(filecontent)
    chunkpos = io_stringpos(filecontent(l))
    if(chunkpos(1) < 1) cycle
    if(io_lc(io_stringvalue(filecontent(l),chunkpos,1)) == 'coordinates') then
      do i = 1,nnodes
        chunkpos = io_stringpos(filecontent(l+1+i))
        map_unsorted(:,i) = [io_intvalue(filecontent(l+1+i),chunkpos,1),i]
      enddo
      exit
    endif
  enddo
 
  call math_sort(map_unsorted)
  allocate(fem2damask(minval(map_unsorted(1,:)):maxval(map_unsorted(1,:))),source=-1)
  do i = 1, nnodes
    fem2damask(map_unsorted(1,i)) = map_unsorted(2,i)
  enddo
 
end subroutine inputread_mapnodes
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine inputread_elemnodes(nodes, &
                               nNode,fileContent)
 
  real(pReal), allocatable,  dimension(:,:), intent(out) :: nodes 
  integer,                                   intent(in)  :: nNode
  character(len=*),            dimension(:), intent(in)  :: fileContent
  
  integer, allocatable, dimension(:) :: chunkPos
  integer :: i,j,m,l
 
  allocate(nodes(3,nnode))
 
  do l = 1, size(filecontent)
    chunkpos = io_stringpos(filecontent(l))
    if(chunkpos(1) < 1) cycle
    if(io_lc(io_stringvalue(filecontent(l),chunkpos,1)) == 'coordinates') then
      do i=1,nnode
        chunkpos = io_stringpos(filecontent(l+1+i))
        m = mesh_fem2damask_node(io_intvalue(filecontent(l+1+i),chunkpos,1))
        do j = 1,3
          nodes(j,m) = mesh_unitlength * io_floatvalue(filecontent(l+1+i),chunkpos,j+1)
        enddo
      enddo
      exit
    endif
  enddo
 
end subroutine inputread_elemnodes
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine inputread_elemtype(elem, &
                              nElem,fileContent)
 
  type(telement),                 intent(out) :: elem
  integer,                        intent(in)  :: nElem
  character(len=*), dimension(:), intent(in)  :: fileContent
 
  integer, allocatable, dimension(:) :: chunkPos
  integer :: i,j,t,l,remainingChunks
 
  t = -1
  do l = 1, size(filecontent)
    chunkpos = io_stringpos(filecontent(l))
    if(chunkpos(1) < 1) cycle
    if(io_lc(io_stringvalue(filecontent(l),chunkpos,1)) == 'connectivity') then
      j = 0
      do i=1,nelem                                                                                  ! read all elements
        chunkpos = io_stringpos(filecontent(l+1+i+j))
        if (t == -1) then
          t = mapelemtype(io_stringvalue(filecontent(l+1+i+j),chunkpos,2))
          call elem%init(t)
        else
          if (t /= mapelemtype(io_stringvalue(filecontent(l+1+i+j),chunkpos,2))) call io_error(191,el=t,ip=i)
        endif
        remainingchunks = elem%nNodes - (chunkpos(1) - 2)
        do while(remainingchunks > 0)
          j = j + 1
          chunkpos = io_stringpos(filecontent(l+1+i+j))
          remainingchunks = remainingchunks - chunkpos(1)
        enddo
      enddo
      exit
    endif
  enddo
 
  contains 
 
  !--------------------------------------------------------------------------------------------------
  !--------------------------------------------------------------------------------------------------
  integer function mapelemtype(what)
  
   character(len=*), intent(in) :: what
  
   select case (io_lc(what))
      case (   '6')
        mapelemtype = 1            ! Two-dimensional Plane Strain Triangle
      case ( '125')                ! 155, 128 (need test)
        mapelemtype = 2            ! Two-dimensional Plane Strain triangle (155: cubic shape function, 125/128: second order isoparametric)
      !case ( '11')                ! need test
      !  mapElemtype = 3           ! Arbitrary Quadrilateral Plane-strain
      case ( '27')
        mapelemtype = 4            ! Plane Strain, Eight-node Distorted Quadrilateral
      case ( '54')
        mapelemtype = 5            ! Plane Strain, Eight-node Distorted Quadrilateral with reduced integration
      !case ( '134')               ! need test
      !  mapElemtype = 6           ! Three-dimensional Four-node Tetrahedron
      !case ( '157')               ! need test
      !  mapElemtype = 7           ! Three-dimensional, Low-order, Tetrahedron, Herrmann Formulations
      !case ( '127')               ! need test
      !  mapElemtype = 8           ! Three-dimensional Ten-node Tetrahedron
      !case ( '136')               ! need test
      !  mapElemtype = 9           ! Three-dimensional Arbitrarily Distorted Pentahedral
      case ( '117')                ! 123 (need test)
        mapelemtype = 10           ! Three-dimensional Arbitrarily Distorted linear hexahedral with reduced integration
      case ( '7')
        mapelemtype = 11           ! Three-dimensional Arbitrarily Distorted Brick
      case ( '57')
        mapelemtype = 12           ! Three-dimensional Arbitrarily Distorted quad hexahedral with reduced integration
      case ( '21')
        mapelemtype = 13           ! Three-dimensional Arbitrarily Distorted quadratic hexahedral
      case default
        call io_error(error_id=190,ext_msg=io_lc(what))
   end select
 
  end function mapelemtype
 
 
end subroutine inputread_elemtype
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function inputread_connectivityelem(nElem,nNodes,fileContent)
 
  integer, intent(in) :: &
    nelem, &
    nnodes
  character(len=*), dimension(:), intent(in) :: filecontent
    
  integer, dimension(nNodes,nElem) :: &
    inputread_connectivityelem
 
  integer, allocatable, dimension(:) :: chunkpos
 
  integer, dimension(1+nElem) :: contints
  integer :: i,k,j,t,e,l,nnodesalreadyread
 
  do l = 1, size(filecontent)
    chunkpos = io_stringpos(filecontent(l))
    if(chunkpos(1) < 1) cycle
    if(io_lc(io_stringvalue(filecontent(l),chunkpos,1)) == 'connectivity') then
      j = 0
      do i = 1,nelem
        chunkpos = io_stringpos(filecontent(l+1+i+j))
        e = mesh_fem2damask_elem(io_intvalue(filecontent(l+1+i+j),chunkpos,1))
        if (e /= 0) then                                                                            ! disregard non CP elems
          do k = 1,chunkpos(1)-2
            inputread_connectivityelem(k,e) = &
              mesh_fem2damask_node(io_intvalue(filecontent(l+1+i+j),chunkpos,k+2))
          enddo
          nnodesalreadyread = chunkpos(1) - 2
          do while(nnodesalreadyread < nnodes)                                                      ! read on if not all nodes in one line
            j = j + 1
            chunkpos = io_stringpos(filecontent(l+1+i+j))
            do k = 1,chunkpos(1)
              inputread_connectivityelem(nnodesalreadyread+k,e) = &
                mesh_fem2damask_node(io_intvalue(filecontent(l+1+i+j),chunkpos,k))
            enddo
            nnodesalreadyread = nnodesalreadyread + chunkpos(1)
          enddo
        endif
      enddo
      exit
    endif
  enddo
 
end function inputread_connectivityelem
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine inputread_microstructureandhomogenization(microstructureAt,homogenizationAt, &
                                    nElem,nNodes,nameElemSet,mapElemSet,initialcondTableStyle,fileContent)
 
  integer, dimension(:), allocatable, intent(out) :: &
    microstructureAt, &
    homogenizationAt
  integer, intent(in) :: &
    nElem, &
    nNodes, &                                                                                       !< number of nodes per element
    initialcondTableStyle
  character(len=*), dimension(:), intent(in) :: nameElemSet
  integer, dimension(:,:),        intent(in) :: mapElemSet
  character(len=*), dimension(:), intent(in) :: fileContent
 
  integer, allocatable, dimension(:) :: chunkPos
 
  integer, dimension(1+nElem) :: contInts
  integer :: i,j,t,sv,myVal,e,nNodesAlreadyRead,l,k,m
 
 
  allocate(microstructureat(nelem),source=0)
  allocate(homogenizationat(nelem),source=0)
 
  do l = 1, size(filecontent)
    chunkpos = io_stringpos(filecontent(l))
    if(chunkpos(1) < 2) cycle
    if(io_lc(io_stringvalue(filecontent(l),chunkpos,1)) == 'initial' .and. &
       io_lc(io_stringvalue(filecontent(l),chunkpos,2)) == 'state') then
      k = merge(2,1,initialcondtablestyle == 2)
      chunkpos = io_stringpos(filecontent(l+k))
      sv = io_intvalue(filecontent(l+k),chunkpos,1)                                                 ! figure state variable index
      if( (sv == 2) .or. (sv == 3) ) then                                                           ! only state vars 2 and 3 of interest
        m = 1
        chunkpos = io_stringpos(filecontent(l+k+m))
        do while (scan(io_stringvalue(filecontent(l+k+m),chunkpos,1),'+-',back=.true.)>1)           ! is noEfloat value?
          myval = nint(io_floatvalue(filecontent(l+k+m),chunkpos,1))
          if (initialcondtablestyle == 2) m = m + 2
          contints = continuousintvalues(filecontent(l+k+m+1:),nelem,nameelemset,mapelemset,size(nameelemset)) ! get affected elements
          do i = 1,contints(1)
            e = mesh_fem2damask_elem(contints(1+i))
            if (sv == 2) microstructureat(e) = myval
            if (sv == 3) homogenizationat(e) = myval
          enddo
          if (initialcondtablestyle == 0) m = m + 1
        enddo
      endif
    endif
  enddo
 
end subroutine inputread_microstructureandhomogenization
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine buildcells(connectivity_cell,cellNodeDefinition, &
                      elem,connectivity_elem)
 
  type(tcellnodedefinition), dimension(:),    intent(out) :: cellNodeDefinition                     ! definition of cell nodes for increasing number of parents
  integer,                   dimension(:,:,:),intent(out) :: connectivity_cell
  
  type(telement),                             intent(in)  :: elem                                   ! element definition
  integer,                   dimension(:,:),  intent(in)  :: connectivity_elem                      ! connectivity of the elements
  
  integer,dimension(:),     allocatable :: candidates_local
  integer,dimension(:,:),   allocatable :: parentsAndWeights,candidates_global
  
  integer :: e, n, c, p, s,i,m,j,nParentNodes,nCellNode,Nelem,candidateID
  
  nelem = size(connectivity_elem,2)
 
!---------------------------------------------------------------------------------------------------
! initialize global connectivity to negative local connectivity
  connectivity_cell = -spread(elem%cell,3,nelem)                                                    ! local cell node ID
  
!---------------------------------------------------------------------------------------------------
! set connectivity of cell nodes that coincide with FE nodes (defined by 1 parent node)
! and renumber local (negative) to global (positive) node ID
  do e = 1, nelem
    do c = 1, elem%NcellNodes
      realnode: if (count(elem%cellNodeParentNodeWeights(:,c) /= 0) == 1) then
        where(connectivity_cell(:,:,e) == -c)
          connectivity_cell(:,:,e) = connectivity_elem(c,e)
        end where
      endif realnode
    enddo
  enddo
 
  ncellnode = maxval(connectivity_elem)
 
!---------------------------------------------------------------------------------------------------
! set connectivity of cell nodes that are defined by 2,...,nNodes real nodes
  do nparentnodes = 2, elem%nNodes
  
    ! get IDs of local cell nodes that are defined by the current number of parent nodes
    candidates_local = [integer::]
    do c = 1, elem%NcellNodes
      if (count(elem%cellNodeParentNodeWeights(:,c) /= 0) == nparentnodes) &
        candidates_local = [candidates_local,c]
    enddo
    s = size(candidates_local)
    
    if (allocated(candidates_global)) deallocate(candidates_global)
    allocate(candidates_global(nparentnodes*2+2,s*nelem))                                           ! stores parent node ID + weight together with element ID and cellnode id (local)
    parentsandweights = reshape([(0, i = 1,2*nparentnodes)],[nparentnodes,2])                       ! (re)allocate
    
    do e = 1, nelem
      do i = 1, size(candidates_local)
        candidateid = (e-1)*size(candidates_local)+i                                                ! including duplicates, runs to (Nelem*size(candidates_local))
        c = candidates_local(i)                                                                     ! c is local cellnode ID for connectivity
        p = 0
        do j = 1, size(elem%cellNodeParentNodeWeights(:,c))
          if (elem%cellNodeParentNodeWeights(j,c) /= 0) then                                        ! real node 'j' partly defines cell node 'c'
            p = p + 1                                                               
            parentsandweights(p,1:2) = [connectivity_elem(j,e),elem%cellNodeParentNodeWeights(j,c)]
          endif
        enddo
        ! store (and order) real node IDs and their weights together with the element number and local ID
        do p = 1, nparentnodes
          m = maxloc(parentsandweights(:,1),1)
          
          candidates_global(p,                                candidateid) = parentsandweights(m,1)
          candidates_global(p+nparentnodes,                   candidateid) = parentsandweights(m,2)
          candidates_global(nparentnodes*2+1:nparentnodes*2+2,candidateid) = [e,c]
          
          parentsandweights(m,1) = -huge(parentsandweights(m,1))                                    ! out of the competition
        enddo
      enddo
    enddo
 
    ! sort according to real node IDs + weight (from left to right)
    call math_sort(candidates_global,sortdim=1)                                                     ! sort according to first column
    
    do p = 2, nparentnodes*2
      n = 1
      do while(n <= size(candidates_local)*nelem)
        j=0
        do while (n+j<= size(candidates_local)*nelem)
          if (candidates_global(p-1,n+j)/=candidates_global(p-1,n)) exit
          j = j + 1
        enddo
        e = n+j-1
        if (any(candidates_global(p,n:e)/=candidates_global(p,n))) &
          call math_sort(candidates_global(:,n:e),sortdim=p)
        n = e+1
      enddo
    enddo
    
    i = uniquerows(candidates_global(1:2*nparentnodes,:))
    allocate(cellnodedefinition(nparentnodes-1)%parents(i,nparentnodes))
    allocate(cellnodedefinition(nparentnodes-1)%weights(i,nparentnodes))
    
    i = 1
    n = 1
    do while(n <= size(candidates_local)*nelem)
      j=0
      parentsandweights(:,1) = candidates_global(1:nparentnodes,n+j)
      parentsandweights(:,2) = candidates_global(nparentnodes+1:nparentnodes*2,n+j)
 
      e = candidates_global(nparentnodes*2+1,n+j)
      c = candidates_global(nparentnodes*2+2,n+j)
 
      do while (n+j<= size(candidates_local)*nelem)
        if (any(candidates_global(1:2*nparentnodes,n+j)/=candidates_global(1:2*nparentnodes,n))) exit
        where (connectivity_cell(:,:,candidates_global(nparentnodes*2+1,n+j)) == -candidates_global(nparentnodes*2+2,n+j)) ! still locally defined
          connectivity_cell(:,:,candidates_global(nparentnodes*2+1,n+j)) = ncellnode + 1                                   ! gets current new cell node id
        end where
       
        j = j+1
      enddo
      ncellnode = ncellnode + 1
      cellnodedefinition(nparentnodes-1)%parents(i,:) = parentsandweights(:,1)
      cellnodedefinition(nparentnodes-1)%weights(i,:) = parentsandweights(:,2)
      i = i + 1
      n = n+j
    enddo
 
  enddo
 
  contains
  !------------------------------------------------------------------------------------------------
  !------------------------------------------------------------------------------------------------
  pure function uniquerows(A) result(u)
    
    integer, dimension(:,:), intent(in) :: a
 
    integer :: &
      u, &                                                                                          !< # of unique rows
      r, &                                                                                          !< row counter
      d
 
    u = 0
    r = 1
    do while(r <= size(a,2))
      d = 0
      do while (r+d<= size(a,2))
        if (any(a(:,r)/=a(:,r+d))) exit
        d = d+1
      enddo
      u = u+1
      r = r+d
    enddo
      
  end function uniquerows
 
end subroutine buildcells
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine buildcellnodes(node_cell, &
                          definition,node_elem)
 
  real(pReal),               dimension(:,:), intent(out) :: node_cell
  type(tcellnodedefinition), dimension(:),   intent(in)  :: definition
  real(pReal),               dimension(:,:), intent(in)  :: node_elem
  
  integer :: i, j, k, n
  
  n = size(node_elem,2)
  node_cell(:,1:n) = node_elem                                                                      
 
  do i = 1, size(cellnodedefinition,1)
    do j = 1, size(cellnodedefinition(i)%parents,1)
      n = n+1
      node_cell(:,n) = 0.0_preal
      do k = 1, size(cellnodedefinition(i)%parents,2)
        node_cell(:,n) = node_cell(:,n) &
                       + node_cell(:,definition(i)%parents(j,k)) * real(definition(i)%weights(j,k),preal)
      enddo
      node_cell(:,n) = node_cell(:,n)/real(sum(definition(i)%weights(j,:)),preal)
    enddo
  enddo
  
end subroutine buildcellnodes
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine buildipcoordinates(IPcoordinates, &
                              connectivity_cell,node_cell)
 
  real(pReal), dimension(:,:), intent(out):: IPcoordinates
  integer,     dimension(:,:), intent(in) :: connectivity_cell
  real(pReal), dimension(:,:), intent(in) :: node_cell
  
  integer :: i, n
 
  do i = 1, size(connectivity_cell,2)
    ipcoordinates(:,i) = 0.0_preal
    do n = 1, size(connectivity_cell,1)
      ipcoordinates(:,i) = ipcoordinates(:,i) &
                         + node_cell(:,connectivity_cell(n,i))
    enddo
    ipcoordinates(:,i) = ipcoordinates(:,i)/real(size(connectivity_cell,1),preal)
  enddo
  
end subroutine buildipcoordinates
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
function ipvolume(elem,node,connectivity)
 
  type(telement),                intent(in) :: elem
  real(preal), dimension(:,:),   intent(in) :: node
  integer,     dimension(:,:,:), intent(in) :: connectivity
  
  real(preal), dimension(elem%nIPs,size(connectivity,3)) :: ipvolume
  real(preal), dimension(3) :: x0,x1,x2,x3,x4,x5,x6,x7
 
  integer :: e,i
 
  do e = 1,size(connectivity,3)
    do i = 1,elem%nIPs
 
      select case (elem%cellType)
        case (1)                                                                                    ! 2D 3node
          ipvolume(i,e) = math_areatriangle(node(1:3,connectivity(1,i,e)), &
                                            node(1:3,connectivity(2,i,e)), &
                                            node(1:3,connectivity(3,i,e)))
 
        case (2)                                                                                    ! 2D 4node
          ipvolume(i,e) = math_areatriangle(node(1:3,connectivity(1,i,e)), &                        ! assume planar shape, division in two triangles suffices
                                            node(1:3,connectivity(2,i,e)), &
                                            node(1:3,connectivity(3,i,e))) &
                        + math_areatriangle(node(1:3,connectivity(3,i,e)), &
                                            node(1:3,connectivity(4,i,e)), &
                                            node(1:3,connectivity(1,i,e)))
        case (3)                                                                                    ! 3D 4node
          ipvolume(i,e) = math_voltetrahedron(node(1:3,connectivity(1,i,e)), &
                                              node(1:3,connectivity(2,i,e)), &
                                              node(1:3,connectivity(3,i,e)), &
                                              node(1:3,connectivity(4,i,e)))
        case (4)                                                                                    ! 3D 8node
          ! J. Grandy, Efficient Calculation of Volume of Hexahedral Cells
          ! Lawrence Livermore National Laboratory
          ! https://www.osti.gov/servlets/purl/632793
          x0 = node(1:3,connectivity(1,i,e))
          x1 = node(1:3,connectivity(2,i,e))
          x2 = node(1:3,connectivity(4,i,e))
          x3 = node(1:3,connectivity(3,i,e))
          x4 = node(1:3,connectivity(5,i,e))
          x5 = node(1:3,connectivity(6,i,e))
          x6 = node(1:3,connectivity(8,i,e))
          x7 = node(1:3,connectivity(7,i,e))
          ipvolume(i,e) = dot_product((x7-x1)+(x6-x0),math_cross((x7-x2),        (x3-x0))) &
                        + dot_product((x6-x0),        math_cross((x7-x2)+(x5-x0),(x7-x4))) &
                        + dot_product((x7-x1),        math_cross((x5-x0),        (x7-x4)+(x3-x0)))
          ipvolume(i,e) = ipvolume(i,e)/12.0_preal
      end select
    enddo
  enddo
 
end function ipvolume
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function ipareanormal(elem,nElem,connectivity,node)
 
  type(telement),                intent(in) :: elem
  integer,                       intent(in) :: nelem
  integer,     dimension(:,:,:), intent(in) :: connectivity
  real(preal), dimension(:,:),   intent(in) :: node
  
  real(preal), dimension(3,elem%nIPneighbors,elem%nIPs,nElem) :: ipareanormal
 
  real(preal), dimension (3,size(elem%cellFace,1)) :: nodepos
  integer :: e,i,f,n,m
 
  m = size(elem%cellFace,1)
 
  do e = 1,nelem
    do i = 1,elem%nIPs
      do f = 1,elem%nIPneighbors
        nodepos = node(1:3,connectivity(elem%cellface(1:m,f),i,e))
        
        select case (elem%cellType)
          case (1,2)                                                                                ! 2D 3 or 4 node
            ipareanormal(1,f,i,e) =   nodepos(2,2) - nodepos(2,1)                                   ! x_normal =  y_connectingVector
            ipareanormal(2,f,i,e) = -(nodepos(1,2) - nodepos(1,1))                                  ! y_normal = -x_connectingVector
            ipareanormal(3,f,i,e) = 0.0_preal
          case (3)                                                                                  ! 3D 4node
            ipareanormal(1:3,f,i,e) = math_cross(nodepos(1:3,2) - nodepos(1:3,1), &
                                                 nodepos(1:3,3) - nodepos(1:3,1))
          case (4)                                                                                  ! 3D 8node
            ! for this cell type we get the normal of the quadrilateral face as an average of
            ! four normals of triangular subfaces; since the face consists only of two triangles,
            ! the sum has to be divided by two; this whole prcedure tries to compensate for
            ! probable non-planar cell surfaces
            ipareanormal(1:3,f,i,e) = 0.0_preal
            do n = 1, m 
              ipareanormal(1:3,f,i,e) = ipareanormal(1:3,f,i,e) &
                                      + math_cross(nodepos(1:3,mod(n+0,m)+1) - nodepos(1:3,n), &
                                                   nodepos(1:3,mod(n+1,m)+1) - nodepos(1:3,n)) * 0.5_preal
            enddo
        end select
      enddo
    enddo
  enddo
 
end function ipareanormal
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function continuousintvalues(fileContent,maxN,lookupName,lookupMap,lookupMaxN)
 
  character(len=*), dimension(:),   intent(in) :: filecontent
  integer,                          intent(in) :: maxn
  integer,                          intent(in) :: lookupmaxn
  integer,          dimension(:,:), intent(in) :: lookupmap
  character(len=*), dimension(:),   intent(in) :: lookupname
 
  integer,           dimension(1+maxN)         :: continuousintvalues
 
  integer :: l,i,first,last
  integer, allocatable, dimension(:) :: chunkpos
  logical :: rangegeneration
 
  continuousintvalues = 0
  rangegeneration = .false.
 
  do l = 1, size(filecontent)
    chunkpos = io_stringpos(filecontent(l))
    if (chunkpos(1) < 1) then                                                                       ! empty line
      exit
    elseif (verify(io_stringvalue(filecontent(l),chunkpos,1),'0123456789') > 0) then                ! a non-int, i.e. set name
      do i = 1, lookupmaxn                                                                          ! loop over known set names
        if (io_stringvalue(filecontent(l),chunkpos,1) == lookupname(i)) then                        ! found matching name
          continuousintvalues = lookupmap(:,i)                                                      ! return resp. entity list
          exit
        endif
      enddo
      exit
    elseif(containsrange(filecontent(l),chunkpos)) then
      first = io_intvalue(filecontent(l),chunkpos,1)
      last  = io_intvalue(filecontent(l),chunkpos,3)
      do i = first, last, sign(1,last-first)
        continuousintvalues(1) = continuousintvalues(1) + 1
        continuousintvalues(1+continuousintvalues(1)) = i
      enddo
      exit
    else
      do i = 1,chunkpos(1)-1                                                                        ! interpret up to second to last value
        continuousintvalues(1) = continuousintvalues(1) + 1
        continuousintvalues(1+continuousintvalues(1)) = io_intvalue(filecontent(l),chunkpos,i)
      enddo
      if ( io_lc(io_stringvalue(filecontent(l),chunkpos,chunkpos(1))) /= 'c' ) then                 ! line finished, read last value
        continuousintvalues(1) = continuousintvalues(1) + 1
        continuousintvalues(1+continuousintvalues(1)) = io_intvalue(filecontent(l),chunkpos,chunkpos(1))
        exit
      endif
    endif
  enddo
 
end function continuousintvalues
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
logical function containsrange(str,chunkPos)
 
  character(len=*),      intent(in) :: str
  integer, dimension(:), intent(in) :: chunkpos
 
  containsrange = .false.
  if(chunkpos(1) == 3) then
     if(io_lc(io_stringvalue(str,chunkpos,2)) == 'to') containsrange = .true.
  endif
 
end function containsrange
 
 
end module discretization_marc
# 24 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/material.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module material
  use prec
  use math
  use config
  use results
  use io
  use debug
  use numerics
  use rotations
  use discretization
 
  implicit none
  private
 
  character(len=*), parameter, public :: &
    elasticity_hooke_label               = 'hooke', &
    plasticity_none_label                = 'none', &
    plasticity_isotropic_label           = 'isotropic', &
    plasticity_phenopowerlaw_label       = 'phenopowerlaw', &
    plasticity_kinehardening_label       = 'kinehardening', &
    plasticity_dislotwin_label           = 'dislotwin', &
    plasticity_disloucla_label           = 'disloucla', &
    plasticity_nonlocal_label            = 'nonlocal', &
    source_thermal_dissipation_label     = 'thermal_dissipation', &
    source_thermal_externalheat_label    = 'thermal_externalheat', &
    source_damage_isobrittle_label       = 'damage_isobrittle', &
    source_damage_isoductile_label       = 'damage_isoductile', &
    source_damage_anisobrittle_label     = 'damage_anisobrittle', &
    source_damage_anisoductile_label     = 'damage_anisoductile', &
    kinematics_thermal_expansion_label   = 'thermal_expansion', &
    kinematics_cleavage_opening_label    = 'cleavage_opening', &
    kinematics_slipplane_opening_label   = 'slipplane_opening', &
    stiffness_degradation_damage_label   = 'damage', &
    thermal_isothermal_label             = 'isothermal', &
    thermal_adiabatic_label              = 'adiabatic', &
    thermal_conduction_label             = 'conduction', &
    damage_none_label                    = 'none', &
    damage_local_label                   = 'local', &
    damage_nonlocal_label                = 'nonlocal', &
    homogenization_none_label            = 'none', &
    homogenization_isostrain_label       = 'isostrain', &
    homogenization_rgc_label             = 'rgc'
 
  enum, bind(c); enumerator :: &
    elasticity_undefined_id ,&
    elasticity_hooke_id ,&
    plasticity_undefined_id ,&
    plasticity_none_id, &
    plasticity_isotropic_id, &
    plasticity_phenopowerlaw_id, &
    plasticity_kinehardening_id, &
    plasticity_dislotwin_id, &
    plasticity_disloucla_id, &
    plasticity_nonlocal_id, &
    source_undefined_id ,&
    source_thermal_dissipation_id, &
    source_thermal_externalheat_id, &
    source_damage_isobrittle_id, &
    source_damage_isoductile_id, &
    source_damage_anisobrittle_id, &
    source_damage_anisoductile_id, &
    kinematics_undefined_id ,&
    kinematics_cleavage_opening_id, &
    kinematics_slipplane_opening_id, &
    kinematics_thermal_expansion_id, &
    stiffness_degradation_undefined_id, &
    stiffness_degradation_damage_id, &
    thermal_isothermal_id, &
    thermal_adiabatic_id, &
    thermal_conduction_id, &
    damage_none_id, &
    damage_local_id, &
    damage_nonlocal_id, &
    homogenization_undefined_id, &
    homogenization_none_id, &
    homogenization_isostrain_id, &
    homogenization_rgc_id
  end enum
 
  integer(kind(ELASTICITY_undefined_ID)),     dimension(:),   allocatable, public, protected :: &
    phase_elasticity
  integer(kind(PLASTICITY_undefined_ID)),     dimension(:),   allocatable, public, protected :: &
    phase_plasticity
  integer(kind(THERMAL_isothermal_ID)),       dimension(:),   allocatable, public, protected :: &
    thermal_type
  integer(kind(DAMAGE_none_ID)),              dimension(:),   allocatable, public, protected :: &
    damage_type
  integer(kind(HOMOGENIZATION_undefined_ID)), dimension(:),   allocatable, public, protected :: &
    homogenization_type
 
  integer, public, protected :: &
    material_nphase, &                                                                              !< number of phases
    material_nhomogenization
 
  integer(kind(SOURCE_undefined_ID)),         dimension(:,:), allocatable, public, protected :: &
    phase_source, &                                                                                 !< active sources mechanisms of each phase
    phase_kinematics, &                                                                             !< active kinematic mechanisms of each phase
    phase_stiffnessdegradation
 
  integer, public, protected :: &
    homogenization_maxngrains
 
  integer, dimension(:), allocatable, public, protected :: &
    phase_nsources, &                                                                               !< number of source mechanisms active in each phase
    phase_nkinematics, &                                                                            !< number of kinematic mechanisms active in each phase
    phase_nstiffnessdegradations, &                                                                 !< number of stiffness degradation mechanisms active in each phase
    phase_elasticityinstance, &                                                                     !< instance of particular elasticity of each phase
    phase_plasticityinstance, &                                                                     !< instance of particular plasticity of each phase
    homogenization_ngrains, &                                                                       !< number of grains in each homogenization
    homogenization_typeinstance, &                                                                  !< instance of particular type of each homogenization
    thermal_typeinstance, &                                                                         !< instance of particular type of each thermal transport
    damage_typeinstance
 
  real(preal), dimension(:), allocatable, public, protected :: &
    thermal_initialt, &                                                                             !< initial temperature per each homogenization
    damage_initialphi
 
  integer, dimension(:),     allocatable, public, protected :: &                                    ! (elem)
    material_homogenizationat
  integer, dimension(:,:),   allocatable, public, target :: &                                       ! (ip,elem) ToDo: ugly target for mapping hack
    material_homogenizationmemberat
  integer, dimension(:,:), allocatable, public, protected :: &                                      ! (constituent,elem)
    material_phaseat
  integer, dimension(:,:,:), allocatable, public, protected :: &                                    ! (constituent,elem)
    material_phasememberat
 
  type(tplasticstate), allocatable, dimension(:), public :: &
    plasticstate
  type(tsourcestate),  allocatable, dimension(:), public :: &
    sourcestate
  type(tstate),        allocatable, dimension(:), public :: &
    homogstate, &
    thermalstate, &
    damagestate
 
  integer, dimension(:,:,:), allocatable, public, protected :: &
    material_texture
 
  type(rotation), dimension(:,:,:), allocatable, public, protected :: &
    material_orientation0
 
  logical, dimension(:), allocatable, public, protected :: &
    phase_localplasticity
 
  integer, dimension(:), allocatable, private :: &
    microstructure_nconstituents
 
  integer, dimension(:,:), allocatable, private :: &
    microstructure_phase, &                                                                         !< phase IDs of each microstructure
    microstructure_texture
 
  type(rotation), dimension(:), allocatable, private :: &
    texture_orientation
 
 
! BEGIN DEPRECATED
  integer, dimension(:,:),   allocatable, private, target :: mappinghomogenizationconst
! END DEPRECATED
 
  type(thomogmapping), allocatable, dimension(:), public :: &
    thermalmapping, &                                                                               !< mapping for thermal state/fields
    damagemapping
 
  type(group_float),  allocatable, dimension(:), public :: &
    temperature, &                                                                                  !< temperature field
    damage, &                                                                                       !< damage field
    temperaturerate
 
  public :: &
    material_init, &
    material_allocateplasticstate, &
    material_allocatesourcestate, &
    elasticity_hooke_id ,&
    plasticity_none_id, &
    plasticity_isotropic_id, &
    plasticity_phenopowerlaw_id, &
    plasticity_kinehardening_id, &
    plasticity_dislotwin_id, &
    plasticity_disloucla_id, &
    plasticity_nonlocal_id, &
    source_thermal_dissipation_id, &
    source_thermal_externalheat_id, &
    source_damage_isobrittle_id, &
    source_damage_isoductile_id, &
    source_damage_anisobrittle_id, &
    source_damage_anisoductile_id, &
    kinematics_cleavage_opening_id, &
    kinematics_slipplane_opening_id, &
    kinematics_thermal_expansion_id, &
    stiffness_degradation_damage_id, &
    thermal_isothermal_id, &
    thermal_adiabatic_id, &
    thermal_conduction_id, &
    damage_none_id, &
    damage_local_id, &
    damage_nonlocal_id, &
    homogenization_none_id, &
    homogenization_isostrain_id, &
    homogenization_rgc_id
 
contains
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine material_init
 
  integer            :: i,e,m,c,h, mydebug, myphase, myhomog, mymicro
  integer, dimension(:), allocatable :: &
   counterphase, &
   counterhomogenization
 
  mydebug = debug_level(debug_material)
 
  write(6,'(/,a)') ' <<<+-  material init  -+>>>'; flush(6)
 
  call material_parsephase()
  if (iand(mydebug,debug_levelbasic) /= 0) write(6,'(a)') ' Phase          parsed'; flush(6)
 
  call material_parsemicrostructure()
  if (iand(mydebug,debug_levelbasic) /= 0) write(6,'(a)') ' Microstructure parsed'; flush(6)
 
  call material_parsehomogenization()
  if (iand(mydebug,debug_levelbasic) /= 0) write(6,'(a)') ' Homogenization parsed'; flush(6)
 
  call material_parsetexture()
  if (iand(mydebug,debug_levelbasic) /= 0) write(6,'(a)') ' Texture        parsed'; flush(6)
 
  material_nphase          = size(config_phase)
  material_nhomogenization = size(config_homogenization)
 
 
  allocate(plasticstate(material_nphase))
  allocate(sourcestate(material_nphase))
  do myphase = 1,material_nphase
    allocate(sourcestate(myphase)%p(phase_nsources(myphase)))
  enddo
 
  allocate(homogstate(material_nhomogenization))
  allocate(thermalstate(material_nhomogenization))
  allocate(damagestate(material_nhomogenization))
 
  allocate(thermalmapping(material_nhomogenization))
  allocate(damagemapping(material_nhomogenization))
 
  allocate(temperature(material_nhomogenization))
  allocate(damage(material_nhomogenization))
 
  allocate(temperaturerate(material_nhomogenization))
 
  do m = 1,size(config_microstructure)
    if(minval(microstructure_phase(1:microstructure_nconstituents(m),m)) < 1 .or. &
       maxval(microstructure_phase(1:microstructure_nconstituents(m),m)) > size(config_phase)) &
         call io_error(150,m,ext_msg='phase')
    if(minval(microstructure_texture(1:microstructure_nconstituents(m),m)) < 1 .or. &
       maxval(microstructure_texture(1:microstructure_nconstituents(m),m)) > size(config_texture)) &
         call io_error(150,m,ext_msg='texture')
    if(microstructure_nconstituents(m) < 1) &
         call io_error(151,m)
  enddo
  if(homogenization_maxngrains > size(microstructure_phase,1)) call io_error(148)
 
  debugout: if (iand(mydebug,debug_levelextensive) /= 0) then
    write(6,'(/,a,/)') ' MATERIAL configuration'
    write(6,'(a32,1x,a16,1x,a6)') 'homogenization                  ','type            ','grains'
    do h = 1,size(config_homogenization)
      write(6,'(1x,a32,1x,a16,1x,i6)') config_name_homogenization(h),homogenization_type(h),homogenization_ngrains(h)
    enddo
    write(6,'(/,a14,18x,1x,a11,1x,a12,1x,a13)') 'microstructure','constituents'
    do m = 1,size(config_microstructure)
      write(6,'(1x,a32,1x,i12)') config_name_microstructure(m), microstructure_nconstituents(m)
      if (microstructure_nconstituents(m) > 0) then
        do c = 1,microstructure_nconstituents(m)
          write(6,'(a1,1x,a32,1x,a32)') '>',config_name_phase(microstructure_phase(c,m)),&
                                            config_name_texture(microstructure_texture(c,m))
        enddo
        write(6,*)
      endif
    enddo
  endif debugout
 
  allocate(material_phaseat(homogenization_maxngrains,discretization_nelem),                   source=0)
  allocate(material_texture(homogenization_maxngrains,discretization_nip,discretization_nelem),source=0)   !this is only needed by plasticity nonlocal
  allocate(material_orientation0(homogenization_maxngrains,discretization_nip,discretization_nelem))
 
  do e = 1, discretization_nelem
     do i = 1, discretization_nip
       mymicro = discretization_microstructureat(e)
       do c = 1, homogenization_ngrains(discretization_homogenizationat(e))
         if(microstructure_phase(c,mymicro) > 0) then
           material_phaseat(c,e)        = microstructure_phase(c,mymicro)
         else
           call io_error(150,ext_msg='phase')
         endif
         if(microstructure_texture(c,mymicro) > 0) then
           material_texture(c,i,e)      = microstructure_texture(c,mymicro)
           material_orientation0(c,i,e) = texture_orientation(material_texture(c,i,e))
         else
           call io_error(150,ext_msg='texture')
         endif
       enddo
     enddo
   enddo
 
  deallocate(microstructure_phase)
  deallocate(microstructure_texture)
  deallocate(texture_orientation)
 
 
  allocate(material_homogenizationat,source=discretization_homogenizationat)
  allocate(material_homogenizationmemberat(discretization_nip,discretization_nelem),source=0)
 
  allocate(counterhomogenization(size(config_homogenization)),source=0)
  do e = 1, discretization_nelem
    do i = 1, discretization_nip
      counterhomogenization(material_homogenizationat(e)) = &
      counterhomogenization(material_homogenizationat(e)) + 1
      material_homogenizationmemberat(i,e) = counterhomogenization(material_homogenizationat(e))
    enddo
  enddo
 
  allocate(material_phasememberat(homogenization_maxngrains,discretization_nip,discretization_nelem),source=0)
 
  allocate(counterphase(size(config_phase)),source=0)
  do e = 1, discretization_nelem
    do i = 1, discretization_nip
      do c = 1, homogenization_maxngrains
        counterphase(material_phaseat(c,e)) = &
        counterphase(material_phaseat(c,e)) + 1
        material_phasememberat(c,i,e) = counterphase(material_phaseat(c,e))
      enddo
    enddo
  enddo
 
  call config_deallocate('material.config/microstructure')
  call config_deallocate('material.config/texture')
 
  call results_openjobfile
  call results_mapping_constituent(material_phaseat,material_phasememberat,config_name_phase)
  call results_mapping_materialpoint(material_homogenizationat,material_homogenizationmemberat,config_name_homogenization)
  call results_closejobfile
 
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! BEGIN DEPRECATED
  allocate(mappinghomogenizationconst(  discretization_nip,discretization_nelem),source=1)
 
! hack needed to initialize field values used during constitutive initialization
  do myhomog = 1,size(config_homogenization)
    thermalmapping(myhomog)%p => mappinghomogenizationconst
    damagemapping(myhomog)%p => mappinghomogenizationconst
    allocate(temperature(myhomog)%p(1), source=thermal_initialt(myhomog))
    allocate(damage(myhomog)%p(1), source=damage_initialphi(myhomog))
    allocate(temperaturerate(myhomog)%p(1), source=0.0_preal)
  enddo
! END DEPRECATED
 
end subroutine material_init
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine material_parsehomogenization
 
  integer :: h
  character(len=pStringLen) :: tag
 
  logical, dimension(:), allocatable :: homogenization_active
 
  allocate(homogenization_type(size(config_homogenization)),           source=homogenization_undefined_id)
  allocate(thermal_type(size(config_homogenization)),                  source=thermal_isothermal_id)
  allocate(damage_type(size(config_homogenization)),                  source=damage_none_id)
  allocate(homogenization_typeinstance(size(config_homogenization)),   source=0)
  allocate(thermal_typeinstance(size(config_homogenization)),          source=0)
  allocate(damage_typeinstance(size(config_homogenization)),           source=0)
  allocate(homogenization_ngrains(size(config_homogenization)),        source=0)
  allocate(homogenization_active(size(config_homogenization)),         source=.false.)  !!!!!!!!!!!!!!!
  allocate(thermal_initialt(size(config_homogenization)),              source=300.0_preal)
  allocate(damage_initialphi(size(config_homogenization)),             source=1.0_preal)
 
  forall (h = 1:size(config_homogenization)) &
    homogenization_active(h) = any(discretization_homogenizationat == h)
 
 
  do h=1, size(config_homogenization)
 
    tag = config_homogenization(h)%getString('mech')
    select case (trim(tag))
      case(homogenization_none_label)
        homogenization_type(h) = homogenization_none_id
        homogenization_ngrains(h) = 1
      case(homogenization_isostrain_label)
        homogenization_type(h) = homogenization_isostrain_id
        homogenization_ngrains(h) = config_homogenization(h)%getInt('nconstituents')
      case(homogenization_rgc_label)
        homogenization_type(h) = homogenization_rgc_id
        homogenization_ngrains(h) = config_homogenization(h)%getInt('nconstituents')
      case default
        call io_error(500,ext_msg=trim(tag))
    end select
 
    homogenization_typeinstance(h) = count(homogenization_type==homogenization_type(h))
 
    if (config_homogenization(h)%keyExists('thermal')) then
      thermal_initialt(h) =  config_homogenization(h)%getFloat('t0',defaultval=300.0_preal)
 
      tag = config_homogenization(h)%getString('thermal')
      select case (trim(tag))
        case(thermal_isothermal_label)
          thermal_type(h) = thermal_isothermal_id
        case(thermal_adiabatic_label)
          thermal_type(h) = thermal_adiabatic_id
        case(thermal_conduction_label)
          thermal_type(h) = thermal_conduction_id
        case default
          call io_error(500,ext_msg=trim(tag))
      end select
 
    endif
 
    if (config_homogenization(h)%keyExists('damage')) then
      damage_initialphi(h) =  config_homogenization(h)%getFloat('initialdamage',defaultval=1.0_preal)
 
      tag = config_homogenization(h)%getString('damage')
      select case (trim(tag))
        case(damage_none_label)
          damage_type(h) = damage_none_id
        case(damage_local_label)
          damage_type(h) = damage_local_id
        case(damage_nonlocal_label)
          damage_type(h) = damage_nonlocal_id
        case default
          call io_error(500,ext_msg=trim(tag))
      end select
 
    endif
 
  enddo
 
  do h=1, size(config_homogenization)
    homogenization_typeinstance(h)  = count(homogenization_type(1:h) == homogenization_type(h))
    thermal_typeinstance(h)         = count(thermal_type(1:h) == thermal_type(h))
    damage_typeinstance(h)          = count(damage_type(1:h) == damage_type(h))
  enddo
 
  homogenization_maxngrains = maxval(homogenization_ngrains,homogenization_active)
 
end subroutine material_parsehomogenization
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine material_parsemicrostructure
 
  character(len=pStringLen), dimension(:), allocatable :: &
    strings
  integer, allocatable, dimension(:) :: chunkPos
  integer :: m, c, i
  character(len=pStringLen) :: &
    tag
  real(pReal), dimension(:,:), allocatable :: &
    microstructure_fraction
  integer :: &
    maxNconstituents
 
  allocate(microstructure_nconstituents(size(config_microstructure)), source=0)
 
  if(any(discretization_microstructureat > size(config_microstructure))) &
   call io_error(155,ext_msg='More microstructures in geometry than sections in material.config')
 
  do m=1, size(config_microstructure)
    microstructure_nconstituents(m) =  config_microstructure(m)%countKeys('(constituent)')
  enddo
 
  maxnconstituents = maxval(microstructure_nconstituents)
  allocate(microstructure_phase(maxnconstituents,size(config_microstructure)),source=0)
  allocate(microstructure_texture(maxnconstituents,size(config_microstructure)),source=0)
  allocate(microstructure_fraction(maxnconstituents,size(config_microstructure)),source=0.0_preal)
 
  allocate(strings(1))                                                                              ! Intel 16.0 Bug
  do m=1, size(config_microstructure)
    strings = config_microstructure(m)%getStrings('(constituent)',raw=.true.)
    do c = 1, size(strings)
      chunkpos = io_stringpos(strings(c))
 
      do i = 1,5,2
         tag = io_stringvalue(strings(c),chunkpos,i)
 
         select case (tag)
           case('phase')
             microstructure_phase(c,m) =    io_intvalue(strings(c),chunkpos,i+1)
           case('texture')
             microstructure_texture(c,m) =  io_intvalue(strings(c),chunkpos,i+1)
           case('fraction')
             microstructure_fraction(c,m) = io_floatvalue(strings(c),chunkpos,i+1)
         end select
 
      enddo
    enddo
    if (dneq(sum(microstructure_fraction(:,m)),1.0_preal)) call io_error(153,ext_msg=config_name_microstructure(m))
  enddo
 
 
end subroutine material_parsemicrostructure
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine material_parsephase
 
  integer :: sourceCtr, kinematicsCtr, stiffDegradationCtr, p
  character(len=pStringLen), dimension(:), allocatable ::  str
 
 
  allocate(phase_elasticity(size(config_phase)),source=elasticity_undefined_id)
  allocate(phase_plasticity(size(config_phase)),source=plasticity_undefined_id)
  allocate(phase_nsources(size(config_phase)),              source=0)
  allocate(phase_nkinematics(size(config_phase)),           source=0)
  allocate(phase_nstiffnessdegradations(size(config_phase)),source=0)
  allocate(phase_localplasticity(size(config_phase)),       source=.false.)
 
  do p=1, size(config_phase)
    phase_nsources(p) =                config_phase(p)%countKeys('(source)')
    phase_nkinematics(p) =             config_phase(p)%countKeys('(kinematics)')
    phase_nstiffnessdegradations(p) =  config_phase(p)%countKeys('(stiffness_degradation)')
    phase_localplasticity(p) = .not.   config_phase(p)%KeyExists('/nonlocal/')
 
    select case (config_phase(p)%getString('elasticity'))
      case (elasticity_hooke_label)
        phase_elasticity(p) = elasticity_hooke_id
      case default
        call io_error(200,ext_msg=trim(config_phase(p)%getString('elasticity')))
    end select
 
    select case (config_phase(p)%getString('plasticity'))
      case (plasticity_none_label)
        phase_plasticity(p) = plasticity_none_id
      case (plasticity_isotropic_label)
        phase_plasticity(p) = plasticity_isotropic_id
      case (plasticity_phenopowerlaw_label)
        phase_plasticity(p) = plasticity_phenopowerlaw_id
      case (plasticity_kinehardening_label)
        phase_plasticity(p) = plasticity_kinehardening_id
      case (plasticity_dislotwin_label)
        phase_plasticity(p) = plasticity_dislotwin_id
      case (plasticity_disloucla_label)
        phase_plasticity(p) = plasticity_disloucla_id
      case (plasticity_nonlocal_label)
        phase_plasticity(p) = plasticity_nonlocal_id
      case default
        call io_error(201,ext_msg=trim(config_phase(p)%getString('plasticity')))
    end select
 
  enddo
 
  allocate(phase_source(maxval(phase_nsources),size(config_phase)), source=source_undefined_id)
  allocate(phase_kinematics(maxval(phase_nkinematics),size(config_phase)), source=kinematics_undefined_id)
  allocate(phase_stiffnessdegradation(maxval(phase_nstiffnessdegradations),size(config_phase)), &
           source=stiffness_degradation_undefined_id)
  do p=1, size(config_phase)
 
    str = ['GfortranBug86277']
    str = config_phase(p)%getStrings('(source)',defaultval=str)
    if (str(1) == 'GfortranBug86277') str = [character(len=pStringLen)::]
 
 
 
    do sourcectr = 1, size(str)
      select case (trim(str(sourcectr)))
        case (source_thermal_dissipation_label)
          phase_source(sourcectr,p) = source_thermal_dissipation_id
        case (source_thermal_externalheat_label)
          phase_source(sourcectr,p) = source_thermal_externalheat_id
        case (source_damage_isobrittle_label)
          phase_source(sourcectr,p) = source_damage_isobrittle_id
        case (source_damage_isoductile_label)
          phase_source(sourcectr,p) = source_damage_isoductile_id
        case (source_damage_anisobrittle_label)
          phase_source(sourcectr,p) = source_damage_anisobrittle_id
        case (source_damage_anisoductile_label)
          phase_source(sourcectr,p) = source_damage_anisoductile_id
      end select
    enddo
 
 
    str = ['GfortranBug86277']
    str = config_phase(p)%getStrings('(kinematics)',defaultval=str)
    if (str(1) == 'GfortranBug86277') str = [character(len=pStringLen)::]
 
 
 
    do kinematicsctr = 1, size(str)
      select case (trim(str(kinematicsctr)))
        case (kinematics_cleavage_opening_label)
          phase_kinematics(kinematicsctr,p) = kinematics_cleavage_opening_id
        case (kinematics_slipplane_opening_label)
          phase_kinematics(kinematicsctr,p) = kinematics_slipplane_opening_id
        case (kinematics_thermal_expansion_label)
          phase_kinematics(kinematicsctr,p) = kinematics_thermal_expansion_id
      end select
    enddo
 
    str = ['GfortranBug86277']
    str = config_phase(p)%getStrings('(stiffness_degradation)',defaultval=str)
    if (str(1) == 'GfortranBug86277') str = [character(len=pStringLen)::]
 
 
 
    do stiffdegradationctr = 1, size(str)
      select case (trim(str(stiffdegradationctr)))
        case (stiffness_degradation_damage_label)
          phase_stiffnessdegradation(stiffdegradationctr,p) = stiffness_degradation_damage_id
      end select
    enddo
  enddo
 
  allocate(phase_plasticityinstance(size(config_phase)),source=0)
  allocate(phase_elasticityinstance(size(config_phase)),source=0)
 
  do p=1, size(config_phase)
    phase_elasticityinstance(p) = count(phase_elasticity(1:p) == phase_elasticity(p))
    phase_plasticityinstance(p) = count(phase_plasticity(1:p) == phase_plasticity(p))
  enddo
 
end subroutine material_parsephase
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine material_parsetexture
 
  integer :: j,t
  character(len=pStringLen), dimension(:), allocatable ::  strings                                  ! Values for given key in material config
  integer, dimension(:), allocatable :: chunkPos
  real(pReal), dimension(3,3) :: transformation                                                     ! maps texture to microstructure coordinate system
  real(pReal), dimension(3)   :: Eulers                                                             ! Euler angles in degrees from file
  type(rotation)              :: transformation_
 
  do t=1, size(config_texture)
    if (config_texture(t)%countKeys('(gauss)') /= 1) call io_error(147,ext_msg='count((gauss)) != 1')
    if (config_texture(t)%keyExists('symmetry'))     call io_error(147,ext_msg='symmetry')
    if (config_texture(t)%keyExists('(random)'))     call io_error(147,ext_msg='(random)')
    if (config_texture(t)%keyExists('(fiber)'))      call io_error(147,ext_msg='(fiber)')
  enddo
 
  allocate(texture_orientation(size(config_texture)))
 
  do t=1, size(config_texture)
 
    strings = config_texture(t)%getStrings('(gauss)',raw= .true.)
    chunkpos = io_stringpos(strings(1))
    do j = 1,5,2
      select case (io_stringvalue(strings(1),chunkpos,j))
        case('phi1')
          eulers(1) = io_floatvalue(strings(1),chunkpos,j+1)
        case('phi')
          eulers(2) = io_floatvalue(strings(1),chunkpos,j+1)
        case('phi2')
          eulers(3) = io_floatvalue(strings(1),chunkpos,j+1)
      end select
    enddo
    call texture_orientation(t)%fromEulers(eulers,degrees=.true.)
 
    if (config_texture(t)%keyExists('axes')) then
      strings = config_texture(t)%getStrings('axes')
      do j = 1, 3                                                                                   ! look for "x", "y", and "z" entries
        select case (strings(j))
          case('x', '+x')
            transformation(j,1:3) = [ 1.0_preal, 0.0_preal, 0.0_preal]                              ! original axis is now +x-axis
          case('-x')
            transformation(j,1:3) = [-1.0_preal, 0.0_preal, 0.0_preal]                              ! original axis is now -x-axis
          case('y', '+y')
            transformation(j,1:3) = [ 0.0_preal, 1.0_preal, 0.0_preal]                              ! original axis is now +y-axis
          case('-y')
            transformation(j,1:3) = [ 0.0_preal,-1.0_preal, 0.0_preal]                              ! original axis is now -y-axis
          case('z', '+z')
            transformation(j,1:3) = [ 0.0_preal, 0.0_preal, 1.0_preal]                              ! original axis is now +z-axis
          case('-z')
            transformation(j,1:3) = [ 0.0_preal, 0.0_preal,-1.0_preal]                              ! original axis is now -z-axis
          case default
            call io_error(157,t)
        end select
      enddo
      call transformation_%fromMatrix(transformation)
      texture_orientation(t) = texture_orientation(t) * transformation_
    endif
 
  enddo
 
end subroutine material_parsetexture
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine material_allocateplasticstate(phase,NipcMyPhase,&
                                         sizeState,sizeDotState,sizeDeltaState)
 
  integer, intent(in) :: &
    phase, &
    nipcmyphase, &
    sizestate, &
    sizedotstate, &
    sizedeltastate
 
  plasticstate(phase)%sizeState        = sizestate
  plasticstate(phase)%sizeDotState     = sizedotstate
  plasticstate(phase)%sizeDeltaState   = sizedeltastate
  plasticstate(phase)%offsetDeltaState = sizestate-sizedeltastate                                   ! deltaState occupies latter part of state by definition
 
  allocate(plasticstate(phase)%atol                (sizestate),               source=0.0_preal)
  allocate(plasticstate(phase)%state0              (sizestate,nipcmyphase),   source=0.0_preal)
  allocate(plasticstate(phase)%partionedState0     (sizestate,nipcmyphase),   source=0.0_preal)
  allocate(plasticstate(phase)%subState0           (sizestate,nipcmyphase),   source=0.0_preal)
  allocate(plasticstate(phase)%state               (sizestate,nipcmyphase),   source=0.0_preal)
 
  allocate(plasticstate(phase)%dotState            (sizedotstate,nipcmyphase),source=0.0_preal)
  if (numerics_integrator == 1) then
    allocate(plasticstate(phase)%previousDotState  (sizedotstate,nipcmyphase),source=0.0_preal)
    allocate(plasticstate(phase)%previousDotState2 (sizedotstate,nipcmyphase),source=0.0_preal)
  endif
  if (numerics_integrator == 4) &
    allocate(plasticstate(phase)%RK4dotState       (4,sizedotstate,nipcmyphase),source=0.0_preal)
  if (numerics_integrator == 5) &
    allocate(plasticstate(phase)%RKCK45dotState  (6,sizedotstate,nipcmyphase),source=0.0_preal)
 
  allocate(plasticstate(phase)%deltaState        (sizedeltastate,nipcmyphase),source=0.0_preal)
 
end subroutine material_allocateplasticstate
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine material_allocatesourcestate(phase,of,NipcMyPhase,&
                                        sizeState,sizeDotState,sizeDeltaState)
 
  integer, intent(in) :: &
    phase, &
    of, &
    nipcmyphase, &
    sizestate, sizedotstate,sizedeltastate
 
  sourcestate(phase)%p(of)%sizeState        = sizestate
  sourcestate(phase)%p(of)%sizeDotState     = sizedotstate
  sourcestate(phase)%p(of)%sizeDeltaState   = sizedeltastate
  sourcestate(phase)%p(of)%offsetDeltaState = sizestate-sizedeltastate                              ! deltaState occupies latter part of state by definition
 
  allocate(sourcestate(phase)%p(of)%atol                (sizestate),               source=0.0_preal)
  allocate(sourcestate(phase)%p(of)%state0              (sizestate,nipcmyphase),   source=0.0_preal)
  allocate(sourcestate(phase)%p(of)%partionedState0     (sizestate,nipcmyphase),   source=0.0_preal)
  allocate(sourcestate(phase)%p(of)%subState0           (sizestate,nipcmyphase),   source=0.0_preal)
  allocate(sourcestate(phase)%p(of)%state               (sizestate,nipcmyphase),   source=0.0_preal)
 
  allocate(sourcestate(phase)%p(of)%dotState            (sizedotstate,nipcmyphase),source=0.0_preal)
  if (numerics_integrator == 1) then
    allocate(sourcestate(phase)%p(of)%previousDotState  (sizedotstate,nipcmyphase),source=0.0_preal)
    allocate(sourcestate(phase)%p(of)%previousDotState2 (sizedotstate,nipcmyphase),source=0.0_preal)
  endif
  if (numerics_integrator == 4) &
    allocate(sourcestate(phase)%p(of)%RK4dotState     (4,sizedotstate,nipcmyphase),source=0.0_preal)
  if (numerics_integrator == 5) &
    allocate(sourcestate(phase)%p(of)%RKCK45dotState  (6,sizedotstate,nipcmyphase),source=0.0_preal)
 
  allocate(sourcestate(phase)%p(of)%deltaState        (sizedeltastate,nipcmyphase),source=0.0_preal)
 
end subroutine material_allocatesourcestate
 
end module material
# 26 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/lattice.f90" 1
!--------------------------------------------------------------------------------------------------
!          and cleavage as well as interaction among the various systems
!--------------------------------------------------------------------------------------------------
module lattice
  use prec
  use io
  use config
  use math
  use rotations
 
  implicit none
  private
 
!--------------------------------------------------------------------------------------------------
! face centered cubic
  integer, dimension(2), parameter :: &
    fcc_nslipsystem = [12, 6]
 
  integer, dimension(1), parameter :: &
    fcc_ntwinsystem = [12]
 
  integer, dimension(1), parameter :: &
    fcc_ntranssystem = [12]
 
  integer, dimension(1), parameter :: &
    fcc_ncleavagesystem = [3]
 
  integer, parameter  :: &
 
    fcc_nslip     = sum(fcc_nslipsystem), &                                                         
    fcc_ntwin     = sum(fcc_ntwinsystem), &                                                         
    fcc_ntrans    = sum(fcc_ntranssystem), &                                                        
    fcc_ncleavage = sum(fcc_ncleavagesystem)                                                        
 
 
 
 
 
 
 
  real(preal), dimension(3+3,FCC_NSLIP), parameter :: &
    fcc_systemslip = reshape(real([&
     ! Slip direction     Plane normal                                                              ! SCHMID-BOAS notation
       0, 1,-1,     1, 1, 1, &                                                                      ! B2
      -1, 0, 1,     1, 1, 1, &                                                                      ! B4
       1,-1, 0,     1, 1, 1, &                                                                      ! B5
       0,-1,-1,    -1,-1, 1, &                                                                      ! C1
       1, 0, 1,    -1,-1, 1, &                                                                      ! C3
      -1, 1, 0,    -1,-1, 1, &                                                                      ! C5
       0,-1, 1,     1,-1,-1, &                                                                      ! A2
      -1, 0,-1,     1,-1,-1, &                                                                      ! A3
       1, 1, 0,     1,-1,-1, &                                                                      ! A6
       0, 1, 1,    -1, 1,-1, &                                                                      ! D1
       1, 0,-1,    -1, 1,-1, &                                                                      ! D4
      -1,-1, 0,    -1, 1,-1, &                                                                      ! D6
      ! Slip system <110>{110}
       1, 1, 0,     1,-1, 0, &
       1,-1, 0,     1, 1, 0, &
       1, 0, 1,     1, 0,-1, &
       1, 0,-1,     1, 0, 1, &
       0, 1, 1,     0, 1,-1, &
       0, 1,-1,     0, 1, 1  &
      ],preal),shape(fcc_systemslip))                                                               
 
  real(preal), dimension(3+3,FCC_NTWIN), parameter :: &
    fcc_systemtwin = reshape(real( [&
      -2, 1, 1,     1, 1, 1, &
       1,-2, 1,     1, 1, 1, &
       1, 1,-2,     1, 1, 1, &
       2,-1, 1,    -1,-1, 1, &
      -1, 2, 1,    -1,-1, 1, &
      -1,-1,-2,    -1,-1, 1, &
      -2,-1,-1,     1,-1,-1, &
       1, 2,-1,     1,-1,-1, &
       1,-1, 2,     1,-1,-1, &
       2, 1,-1,    -1, 1,-1, &
      -1,-2,-1,    -1, 1,-1, &
      -1, 1, 2,    -1, 1,-1  &
      ],preal),shape(fcc_systemtwin))                                                               
 
  integer, dimension(2,FCC_NTWIN), parameter, public :: &
    lattice_fcc_twinnucleationslippair = reshape( [&
      2,3, &
      1,3, &
      1,2, &
      5,6, &
      4,6, &
      4,5, &
      8,9, &
      7,9, &
      7,8, &
      11,12, &
      10,12, &
      10,11 &
      ],shape(lattice_fcc_twinnucleationslippair))
 
  real(preal), dimension(3+3,FCC_NCLEAVAGE), parameter :: &
    fcc_systemcleavage = reshape(real([&
     ! Cleavage direction     Plane normal
       0, 1, 0,     1, 0, 0, &
       0, 0, 1,     0, 1, 0, &
       1, 0, 0,     0, 0, 1  &
      ],preal),shape(fcc_systemcleavage))
 
!--------------------------------------------------------------------------------------------------
! body centered cubic
  integer, dimension(2), parameter :: &
    bcc_nslipsystem = [12, 12]
 
  integer, dimension(1), parameter :: &
    bcc_ntwinsystem = [12]
 
  integer, dimension(1), parameter :: &
    bcc_ncleavagesystem = [3]
 
  integer, parameter  :: &
 
    bcc_nslip     = sum(bcc_nslipsystem), &                                                         
    bcc_ntwin     = sum(bcc_ntwinsystem), &                                                         
    bcc_ncleavage = sum(bcc_ncleavagesystem)                                                        
 
 
 
 
 
 
  real(preal), dimension(3+3,BCC_NSLIP), parameter :: &
    bcc_systemslip = reshape(real([&
     ! Slip direction     Plane normal
     ! Slip system <111>{110}
       1,-1, 1,     0, 1, 1, &
      -1,-1, 1,     0, 1, 1, &
       1, 1, 1,     0,-1, 1, &
      -1, 1, 1,     0,-1, 1, &
      -1, 1, 1,     1, 0, 1, &
      -1,-1, 1,     1, 0, 1, &
       1, 1, 1,    -1, 0, 1, &
       1,-1, 1,    -1, 0, 1, &
      -1, 1, 1,     1, 1, 0, &
      -1, 1,-1,     1, 1, 0, &
       1, 1, 1,    -1, 1, 0, &
       1, 1,-1,    -1, 1, 0, &
     ! Slip system <111>{112}
      -1, 1, 1,     2, 1, 1, &
       1, 1, 1,    -2, 1, 1, &
       1, 1,-1,     2,-1, 1, &
       1,-1, 1,     2, 1,-1, &
       1,-1, 1,     1, 2, 1, &
       1, 1,-1,    -1, 2, 1, &
       1, 1, 1,     1,-2, 1, &
      -1, 1, 1,     1, 2,-1, &
       1, 1,-1,     1, 1, 2, &
       1,-1, 1,    -1, 1, 2, &
      -1, 1, 1,     1,-1, 2, &
       1, 1, 1,     1, 1,-2  &
      ],preal),shape(bcc_systemslip))
 
  real(preal), dimension(3+3,BCC_NTWIN), parameter :: &
    bcc_systemtwin = reshape(real([&
     ! Twin system <111>{112}
      -1, 1, 1,     2, 1, 1, &
       1, 1, 1,    -2, 1, 1, &
       1, 1,-1,     2,-1, 1, &
       1,-1, 1,     2, 1,-1, &
       1,-1, 1,     1, 2, 1, &
       1, 1,-1,    -1, 2, 1, &
       1, 1, 1,     1,-2, 1, &
      -1, 1, 1,     1, 2,-1, &
       1, 1,-1,     1, 1, 2, &
       1,-1, 1,    -1, 1, 2, &
      -1, 1, 1,     1,-1, 2, &
       1, 1, 1,     1, 1,-2  &
      ],preal),shape(bcc_systemtwin))
 
  real(preal), dimension(3+3,BCC_NCLEAVAGE), parameter :: &
    bcc_systemcleavage = reshape(real([&
     ! Cleavage direction     Plane normal
       0, 1, 0,     1, 0, 0, &
       0, 0, 1,     0, 1, 0, &
       1, 0, 0,     0, 0, 1  &
      ],preal),shape(bcc_systemcleavage))
 
!--------------------------------------------------------------------------------------------------
! hexagonal
  integer, dimension(6), parameter :: &
    hex_nslipsystem = [3, 3, 3, 6, 12, 6]
 
  integer, dimension(4), parameter :: &
    hex_ntwinsystem = [6, 6, 6, 6]
 
  integer, parameter  :: &
 
    hex_nslip     = sum(hex_nslipsystem), &                                                         
    hex_ntwin     = sum(hex_ntwinsystem)                                                            
 
 
 
 
 
  real(preal), dimension(4+4,HEX_NSLIP), parameter :: &
    hex_systemslip = reshape(real([&
     ! Slip direction     Plane normal
     ! Basal systems <-1-1.0>{00.1} (independent of c/a-ratio, Bravais notation (4 coordinate base))
       2, -1, -1,  0,     0,  0,  0,  1, &
      -1,  2, -1,  0,     0,  0,  0,  1, &
      -1, -1,  2,  0,     0,  0,  0,  1, &
     ! 1st type prismatic systems <-1-1.0>{1-1.0}  (independent of c/a-ratio)
       2, -1, -1,  0,     0,  1, -1,  0, &
      -1,  2, -1,  0,    -1,  0,  1,  0, &
      -1, -1,  2,  0,     1, -1,  0,  0, &
     ! 2nd type prismatic systems <-11.0>{11.0} -- a slip; plane normals independent of c/a-ratio
      -1,  1,  0,  0,     1,  1, -2,  0, &
       0, -1,  1,  0,    -2,  1,  1,  0, &
       1,  0, -1,  0,     1, -2,  1,  0, &
     ! 1st type 1st order pyramidal systems <-1-1.0>{-11.1} -- plane normals depend on the c/a-ratio
      -1,  2, -1,  0,     1,  0, -1,  1, &
      -2,  1,  1,  0,     0,  1, -1,  1, &
      -1, -1,  2,  0,    -1,  1,  0,  1, &
       1, -2,  1,  0,    -1,  0,  1,  1, &
       2, -1, -1,  0,     0, -1,  1,  1, &
       1,  1, -2,  0,     1, -1,  0,  1, &
     ! pyramidal system: c+a slip <11.3>{-10.1} -- plane normals depend on the c/a-ratio
      -2,  1,  1,  3,     1,  0, -1,  1, &
      -1, -1,  2,  3,     1,  0, -1,  1, &
      -1, -1,  2,  3,     0,  1, -1,  1, &
       1, -2,  1,  3,     0,  1, -1,  1, &
       1, -2,  1,  3,    -1,  1,  0,  1, &
       2, -1, -1,  3,    -1,  1,  0,  1, &
       2, -1, -1,  3,    -1,  0,  1,  1, &
       1,  1, -2,  3,    -1,  0,  1,  1, &
       1,  1, -2,  3,     0, -1,  1,  1, &
      -1,  2, -1,  3,     0, -1,  1,  1, &
      -1,  2, -1,  3,     1, -1,  0,  1, &
      -2,  1,  1,  3,     1, -1,  0,  1, &
     ! pyramidal system: c+a slip <11.3>{-1-1.2} -- as for hexagonal ice (Castelnau et al. 1996, similar to twin system found below)
      -1, -1,  2,  3,     1,  1, -2,  2, & ! <11.3>{-1-1.2} shear = 2((c/a)^2-2)/(3 c/a)
       1, -2,  1,  3,    -1,  2, -1,  2, &
       2, -1, -1,  3,    -2,  1,  1,  2, &
       1,  1, -2,  3,    -1, -1,  2,  2, &
      -1,  2, -1,  3,     1, -2,  1,  2, &
      -2,  1,  1,  3,     2, -1, -1,  2  &
      ],preal),shape(hex_systemslip))                                                               
 
  real(preal), dimension(4+4,HEX_NTWIN), parameter :: &
    hex_systemtwin =  reshape(real([&
     ! Compression or Tension = f(twinning shear=f(c/a)) for each metal ! (according to Yoo 1981)
      -1,  0,  1,  1,     1,  0, -1,  2, & ! <-10.1>{10.2} shear = (3-(c/a)^2)/(sqrt(3) c/a)
       0, -1,  1,  1,     0,  1, -1,  2, &
       1, -1,  0,  1,    -1,  1,  0,  2, &
       1,  0, -1,  1,    -1,  0,  1,  2, &
       0,  1, -1,  1,     0, -1,  1,  2, &
      -1,  1,  0,  1,     1, -1,  0,  2, &
!
      -1, -1,  2,  6,     1,  1, -2,  1, & ! <11.6>{-1-1.1} shear = 1/(c/a)
       1, -2,  1,  6,    -1,  2, -1,  1, &
       2, -1, -1,  6,    -2,  1,  1,  1, &
       1,  1, -2,  6,    -1, -1,  2,  1, &
      -1,  2, -1,  6,     1, -2,  1,  1, &
      -2,  1,  1,  6,     2, -1, -1,  1, &
!
       1,  0, -1, -2,     1,  0, -1,  1, & ! <10.-2>{10.1} shear = (4(c/a)^2-9)/(4 sqrt(3) c/a)
       0,  1, -1, -2,     0,  1, -1,  1, &
      -1,  1,  0, -2,    -1,  1,  0,  1, &
      -1,  0,  1, -2,    -1,  0,  1,  1, &
       0, -1,  1, -2,     0, -1,  1,  1, &
       1, -1,  0, -2,     1, -1,  0,  1, &
!
       1,  1, -2, -3,     1,  1, -2,  2, & ! <11.-3>{11.2} shear = 2((c/a)^2-2)/(3 c/a)
      -1,  2, -1, -3,    -1,  2, -1,  2, &
      -2,  1,  1, -3,    -2,  1,  1,  2, &
      -1, -1,  2, -3,    -1, -1,  2,  2, &
       1, -2,  1, -3,     1, -2,  1,  2, &
       2, -1, -1, -3,     2, -1, -1,  2  &
      ],preal),shape(hex_systemtwin))                                                               
 
!--------------------------------------------------------------------------------------------------
! body centered tetragonal
  integer, dimension(13), parameter :: &
    bct_nslipsystem = [2, 2, 2, 4, 2, 4, 2, 2, 4, 8, 4, 8, 8 ]
 
  integer, parameter :: &
 
    bct_nslip = sum(bct_nslipsystem)                                                                
 
 
 
 
  real(preal), dimension(3+3,BCT_NSLIP), parameter :: &
    bct_systemslip = reshape(real([&
     ! Slip direction     Plane normal
     ! Slip family 1 {100)<001] (Bravais notation {hkl)<uvw] for bct c/a = 0.5456)
       0, 0, 1,      1, 0, 0, &
       0, 0, 1,      0, 1, 0, &
     ! Slip family 2 {110)<001]
       0, 0, 1,      1, 1, 0, &
       0, 0, 1,     -1, 1, 0, &
     ! slip family 3 {100)<010]
       0,  1, 0,     1, 0, 0, &
       1,  0, 0,     0, 1, 0, &
     ! Slip family 4 {110)<1-11]/2
       1,-1, 1,      1, 1, 0, &
       1,-1,-1,      1, 1, 0, &
      -1,-1,-1,     -1, 1, 0, &
      -1,-1, 1,     -1, 1, 0, &
     ! Slip family 5 {110)<1-10]
       1, -1, 0,     1, 1, 0, &
       1,  1, 0,     1,-1, 0, &
     ! Slip family 6 {100)<011]
       0, 1, 1,      1, 0, 0, &
       0,-1, 1,      1, 0, 0, &
      -1, 0, 1,      0, 1, 0, &
       1, 0, 1,      0, 1, 0, &
     ! Slip family 7 {001)<010]
       0, 1, 0,      0, 0, 1, &
       1, 0, 0,      0, 0, 1, &
     ! Slip family 8 {001)<110]
       1, 1, 0,      0, 0, 1, &
      -1, 1, 0,      0, 0, 1, &
     ! Slip family 9 {011)<01-1]
       0, 1,-1,      0, 1, 1, &
       0,-1,-1,      0,-1, 1, &
      -1, 0,-1,     -1, 0, 1, &
       1, 0,-1,      1, 0, 1, &
     ! Slip family 10 {011)<1-11]/2
       1,-1, 1,      0, 1, 1, &
       1, 1,-1,      0, 1, 1, &
       1, 1, 1,      0, 1,-1, &
      -1, 1, 1,      0, 1,-1, &
       1,-1,-1,      1, 0, 1, &
      -1,-1, 1,      1, 0, 1, &
       1, 1, 1,      1, 0,-1, &
       1,-1, 1,      1, 0,-1,  &
     ! Slip family 11 {011)<100]
       1, 0, 0,      0, 1, 1, &
       1, 0, 0,      0, 1,-1, &
       0, 1, 0,      1, 0, 1, &
       0, 1, 0,      1, 0,-1, &
     ! Slip family 12 {211)<01-1]
       0, 1,-1,      2, 1, 1, &
       0,-1,-1,      2,-1, 1, &
       1, 0,-1,      1, 2, 1, &
      -1, 0,-1,     -1, 2, 1, &
       0, 1,-1,     -2, 1, 1, &
       0,-1,-1,     -2,-1, 1, &
      -1, 0,-1,     -1,-2, 1, &
       1, 0,-1,      1,-2, 1, &
     ! Slip family 13 {211)<-111]/2
      -1, 1, 1,      2, 1, 1, &
      -1,-1, 1,      2,-1, 1, &
       1,-1, 1,      1, 2, 1, &
      -1,-1, 1,     -1, 2, 1, &
       1, 1, 1,     -2, 1, 1, &
       1,-1, 1,     -2,-1, 1, &
      -1, 1, 1,     -1,-2, 1, &
       1, 1, 1,      1,-2, 1  &
       ],preal),shape(bct_systemslip))                                                              
 
!--------------------------------------------------------------------------------------------------
! orthorhombic
  integer, dimension(3), parameter :: &
    ort_ncleavagesystem = [1, 1, 1]
 
  integer, parameter  :: &
 
    ort_ncleavage = sum(ort_ncleavagesystem)                                                        
 
 
 
 
  real(preal), dimension(3+3,ORT_NCLEAVAGE), parameter :: &
    ort_systemcleavage = reshape(real([&
     ! Cleavage direction     Plane normal
       0, 1, 0,     1, 0, 0, &
       0, 0, 1,     0, 1, 0, &
       1, 0, 0,     0, 0, 1  &
      ],preal),shape(ort_systemcleavage))
 
 
  enum, bind(c); enumerator :: &
    lattice_undefined_id, &
    lattice_iso_id, &
    lattice_fcc_id, &
    lattice_bcc_id, &
    lattice_bct_id, &
    lattice_hex_id, &
    lattice_ort_id
  end enum
 
! SHOULD NOT BE PART OF LATTICE BEGIN
  real(preal),                        dimension(:),     allocatable, public, protected :: &
    lattice_mu, lattice_nu, &
    lattice_damagemobility, &
    lattice_massdensity, &
    lattice_specificheat
   real(preal),                       dimension(:,:,:), allocatable, public, protected :: &
    lattice_c66, &
    lattice_thermalconductivity, &
    lattice_damagediffusion
 integer(kind(lattice_UNDEFINED_ID)), dimension(:),     allocatable, public, protected :: &
    lattice_structure
! SHOULD NOT BE PART OF LATTICE END
 
  interface lattice_forestprojection_edge
    module procedure slipprojection_transverse
  end interface lattice_forestprojection_edge
 
  interface lattice_forestprojection_screw
    module procedure slipprojection_direction
  end interface lattice_forestprojection_screw
 
  public :: &
    lattice_init, &
    lattice_iso_id, &
    lattice_fcc_id, &
    lattice_bcc_id, &
    lattice_bct_id, &
    lattice_hex_id, &
    lattice_ort_id, &
    lattice_applylatticesymmetry33, &
    lattice_schmidmatrix_slip, &
    lattice_schmidmatrix_twin, &
    lattice_schmidmatrix_trans, &
    lattice_schmidmatrix_cleavage, &
    lattice_nonschmidmatrix, &
    lattice_interaction_slipbyslip, &
    lattice_interaction_twinbytwin, &
    lattice_interaction_transbytrans, &
    lattice_interaction_slipbytwin, &
    lattice_interaction_slipbytrans, &
    lattice_interaction_twinbyslip, &
    lattice_characteristicshear_twin, &
    lattice_c66_twin, &
    lattice_c66_trans, &
    lattice_forestprojection_edge, &
    lattice_forestprojection_screw, &
    lattice_slip_normal, &
    lattice_slip_direction, &
    lattice_slip_transverse, &
    lattice_labels_slip, &
    lattice_labels_twin
 
contains
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine lattice_init
 
  integer :: nphases, p,i
  character(len=pStringLen) :: structure = ''
 
  write(6,'(/,a)') ' <<<+-  lattice init  -+>>>'; flush(6)
 
  nphases = size(config_phase)
 
  allocate(lattice_structure(nphases),source = lattice_undefined_id)
  allocate(lattice_c66(6,6,nphases),  source=0.0_preal)
 
  allocate(lattice_thermalconductivity(3,3,nphases), source=0.0_preal)
  allocate(lattice_damagediffusion(3,3,nphases), source=0.0_preal)
 
  allocate(lattice_damagemobility,&
           lattice_massdensity,lattice_specificheat, &
           lattice_mu, lattice_nu,&
           source=[(0.0_preal,i=1,nphases)])
 
  do p = 1, size(config_phase)
 
    lattice_c66(1,1,p) = config_phase(p)%getFloat('c11')
    lattice_c66(1,2,p) = config_phase(p)%getFloat('c12')
 
    lattice_c66(1,3,p) = config_phase(p)%getFloat('c13',defaultval=0.0_preal)
    lattice_c66(2,2,p) = config_phase(p)%getFloat('c22',defaultval=0.0_preal)
    lattice_c66(2,3,p) = config_phase(p)%getFloat('c23',defaultval=0.0_preal)
    lattice_c66(3,3,p) = config_phase(p)%getFloat('c33',defaultval=0.0_preal)
    lattice_c66(4,4,p) = config_phase(p)%getFloat('c44',defaultval=0.0_preal)
    lattice_c66(5,5,p) = config_phase(p)%getFloat('c55',defaultval=0.0_preal)
    lattice_c66(6,6,p) = config_phase(p)%getFloat('c66',defaultval=0.0_preal)
 
    structure = config_phase(p)%getString('lattice_structure')
    select case(trim(structure))
      case('iso')
        lattice_structure(p) = lattice_iso_id
      case('fcc')
        lattice_structure(p) = lattice_fcc_id
      case('bcc')
        lattice_structure(p) = lattice_bcc_id
      case('hex')
        lattice_structure(p) = lattice_hex_id
      case('bct')
        lattice_structure(p) = lattice_bct_id
      case('ort')
        lattice_structure(p) = lattice_ort_id
      case default
        call io_error(130,ext_msg='lattice_init: '//trim(structure))
    end select
 
    lattice_c66(1:6,1:6,p) = applylatticesymmetryc66(lattice_c66(1:6,1:6,p),structure)
 
    lattice_mu(p) = equivalent_mu(lattice_c66(1:6,1:6,p),'voigt')
    lattice_nu(p) = equivalent_nu(lattice_c66(1:6,1:6,p),'voigt')
 
    lattice_c66(1:6,1:6,p) = math_sym3333to66(math_voigt66to3333(lattice_c66(1:6,1:6,p)))           ! Literature data is in Voigt notation
    do i = 1, 6
      if (abs(lattice_c66(i,i,p))<tol_math_check) &
        call io_error(135,el=i,ip=p,ext_msg='matrix diagonal "el"ement of phase "ip"')
    enddo
 
 
    ! SHOULD NOT BE PART OF LATTICE BEGIN
    lattice_thermalconductivity(1,1,p) = config_phase(p)%getFloat('thermal_conductivity11',defaultval=0.0_preal)
    lattice_thermalconductivity(2,2,p) = config_phase(p)%getFloat('thermal_conductivity22',defaultval=0.0_preal)
    lattice_thermalconductivity(3,3,p) = config_phase(p)%getFloat('thermal_conductivity33',defaultval=0.0_preal)
    lattice_thermalconductivity(1:3,1:3,p) = lattice_applylatticesymmetry33(lattice_thermalconductivity(1:3,1:3,p),structure)
 
    lattice_specificheat(p) = config_phase(p)%getFloat('specific_heat',defaultval=0.0_preal)
    lattice_massdensity(p)  = config_phase(p)%getFloat('mass_density', defaultval=0.0_preal)
 
    lattice_damagediffusion(1,1,p) = config_phase(p)%getFloat('damage_diffusion11',defaultval=0.0_preal)
    lattice_damagediffusion(2,2,p) = config_phase(p)%getFloat('damage_diffusion22',defaultval=0.0_preal)
    lattice_damagediffusion(3,3,p) = config_phase(p)%getFloat('damage_diffusion33',defaultval=0.0_preal)
    lattice_damagediffusion(1:3,1:3,p) = lattice_applylatticesymmetry33(lattice_damagediffusion(1:3,1:3,p),structure)
 
    lattice_damagemobility(p) = config_phase(p)%getFloat('damage_mobility',defaultval=0.0_preal)
    ! SHOULD NOT BE PART OF LATTICE END
 
    call unittest
 
  enddo
 
end subroutine lattice_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function lattice_characteristicshear_twin(Ntwin,structure,CoverA) result(characteristicShear)
 
  integer,     dimension(:),            intent(in) :: ntwin
  character(len=*),                     intent(in) :: structure
  real(preal),                          intent(in) :: covera
  real(preal), dimension(sum(Ntwin))               :: characteristicshear
 
  integer :: &
    a, &                                                                                            !< index of active system
    p, &                                                                                            !< index in potential system list
    f, &                                                                                            !< index of my family
    s
 
  integer, dimension(HEX_NTWIN), parameter :: &
    hex_sheartwin = reshape( [&
      1, &  ! <-10.1>{10.2}
      1, &
      1, &
      1, &
      1, &
      1, &
      2, &  ! <11.6>{-1-1.1}
      2, &
      2, &
      2, &
      2, &
      2, &
      3, &  ! <10.-2>{10.1}
      3, &
      3, &
      3, &
      3, &
      3, &
      4, &  ! <11.-3>{11.2}
      4, &
      4, &
      4, &
      4, &
      4  &
      ],[hex_ntwin])                                                                                ! indicator to formulas below
 
  if (len_trim(structure) /= 3) &
    call io_error(137,ext_msg='lattice_characteristicShear_Twin: '//trim(structure))
 
  a = 0
  myfamilies: do f = 1,size(ntwin,1)
    mysystems: do s = 1,ntwin(f)
      a = a + 1
      select case(structure)
        case('fcc','bcc')
          characteristicshear(a) = 0.5_preal*sqrt(2.0_preal)
        case('hex')
          if (covera < 1.0_preal .or. covera > 2.0_preal) &
            call io_error(131,ext_msg='lattice_characteristicShear_Twin')
          p = sum(hex_ntwinsystem(1:f-1))+s
          select case(hex_sheartwin(p))                                                             ! from Christian & Mahajan 1995 p.29
            case (1)                                                                                ! <-10.1>{10.2}
              characteristicshear(a) = (3.0_preal-covera**2.0_preal)/sqrt(3.0_preal)/covera
            case (2)                                                                                ! <11.6>{-1-1.1}
              characteristicshear(a) = 1.0_preal/covera
            case (3)                                                                                ! <10.-2>{10.1}
              characteristicshear(a) = (4.0_preal*covera**2.0_preal-9.0_preal)/sqrt(48.0_preal)/covera
            case (4)                                                                                ! <11.-3>{11.2}
              characteristicshear(a) = 2.0_preal*(covera**2.0_preal-2.0_preal)/3.0_preal/covera
          end select
        case default
          call io_error(137,ext_msg='lattice_characteristicShear_Twin: '//trim(structure))
      end select
    enddo mysystems
  enddo myfamilies
 
end function lattice_characteristicshear_twin
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function lattice_c66_twin(Ntwin,C66,structure,CoverA)
 
  integer,     dimension(:),            intent(in) :: ntwin
  character(len=*),                     intent(in) :: structure
  real(preal), dimension(6,6),          intent(in) :: c66
  real(preal),                          intent(in) :: covera
  real(preal), dimension(6,6,sum(Ntwin))           :: lattice_c66_twin
 
  real(preal), dimension(3,3,sum(Ntwin)):: coordinatesystem
  type(rotation)                        :: r
  integer                               :: i
 
  if (len_trim(structure) /= 3) &
    call io_error(137,ext_msg='lattice_C66_twin: '//trim(structure))
 
  select case(structure)
    case('fcc')
      coordinatesystem = buildcoordinatesystem(ntwin,fcc_nslipsystem,fcc_systemtwin,&
                                               trim(structure),0.0_preal)
    case('bcc')
      coordinatesystem = buildcoordinatesystem(ntwin,bcc_nslipsystem,bcc_systemtwin,&
                                               trim(structure),0.0_preal)
    case('hex')
      coordinatesystem = buildcoordinatesystem(ntwin,hex_nslipsystem,hex_systemtwin,&
                                               'hex',covera)
    case default
      call io_error(137,ext_msg='lattice_C66_twin: '//trim(structure))
  end select
 
  do i = 1, sum(ntwin)
    call r%fromAxisAngle([coordinatesystem(1:3,2,i),pi],p=1)                                        ! ToDo: Why always 180 deg?
    lattice_c66_twin(1:6,1:6,i) = r%rotTensor4sym(c66)
  enddo
 
end function lattice_c66_twin
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function lattice_c66_trans(Ntrans,C_parent66,structure_target, &
                           cOverA_trans,a_bcc,a_fcc)
 
  integer,     dimension(:),             intent(in) :: ntrans
  character(len=*),                      intent(in) :: structure_target
  real(preal), dimension(6,6),           intent(in) :: c_parent66
  real(preal), dimension(6,6,sum(Ntrans))           :: lattice_c66_trans
 
  real(preal), dimension(6,6)             :: c_bar66, c_target_unrotated66
  real(preal), dimension(3,3,sum(Ntrans)) :: q,s
  type(rotation)                          :: r
  real(preal)                             :: a_bcc, a_fcc, covera_trans
  integer                                 :: i
 
  if (len_trim(structure_target) /= 3) &
    call io_error(137,ext_msg='lattice_C66_trans (target): '//trim(structure_target))
 
 !--------------------------------------------------------------------------------------------------
 ! elasticity matrix of the target phase in cube orientation
  if (structure_target(1:3) == 'hex') then
    if (covera_trans < 1.0_preal .or. covera_trans > 2.0_preal) &
      call io_error(131,ext_msg='lattice_C66_trans: '//trim(structure_target))
    c_bar66(1,1) = (c_parent66(1,1) + c_parent66(1,2) + 2.0_preal*c_parent66(4,4))/2.0_preal
    c_bar66(1,2) = (c_parent66(1,1) + 5.0_preal*c_parent66(1,2) - 2.0_preal*c_parent66(4,4))/6.0_preal
    c_bar66(3,3) = (c_parent66(1,1) + 2.0_preal*c_parent66(1,2) + 4.0_preal*c_parent66(4,4))/3.0_preal
    c_bar66(1,3) = (c_parent66(1,1) + 2.0_preal*c_parent66(1,2) - 2.0_preal*c_parent66(4,4))/3.0_preal
    c_bar66(4,4) = (c_parent66(1,1) - c_parent66(1,2) + c_parent66(4,4))/3.0_preal
    c_bar66(1,4) = (c_parent66(1,1) - c_parent66(1,2) - 2.0_preal*c_parent66(4,4)) /(3.0_preal*sqrt(2.0_preal))
 
    c_target_unrotated66 = 0.0_preal
    c_target_unrotated66(1,1) = c_bar66(1,1) - c_bar66(1,4)**2.0_preal/c_bar66(4,4)
    c_target_unrotated66(1,2) = c_bar66(1,2) + c_bar66(1,4)**2.0_preal/c_bar66(4,4)
    c_target_unrotated66(1,3) = c_bar66(1,3)
    c_target_unrotated66(3,3) = c_bar66(3,3)
    c_target_unrotated66(4,4) = c_bar66(4,4) - c_bar66(1,4)**2.0_preal/(0.5_preal*(c_bar66(1,1) - c_bar66(1,2)))
    c_target_unrotated66 = applylatticesymmetryc66(c_target_unrotated66,'hex')
  elseif (structure_target(1:3)  == 'bcc') then
    if (a_bcc <= 0.0_preal .or. a_fcc <= 0.0_preal) &
      call io_error(134,ext_msg='lattice_C66_trans: '//trim(structure_target))
    c_target_unrotated66 = c_parent66
  else
    call io_error(137,ext_msg='lattice_C66_trans : '//trim(structure_target))
  endif
 
  do i = 1, 6
    if (abs(c_target_unrotated66(i,i))<tol_math_check) &
    call io_error(135,el=i,ext_msg='matrix diagonal "el"ement in transformation')
  enddo
 
  call buildtransformationsystem(q,s,ntrans,covera_trans,a_fcc,a_bcc)
 
  do i = 1, sum(ntrans)
    call r%fromMatrix(q(1:3,1:3,i))
    lattice_c66_trans(1:6,1:6,i) = r%rotTensor4sym(c_target_unrotated66)
  enddo
 
 end function lattice_c66_trans
 
 
!--------------------------------------------------------------------------------------------------
! Koester et al. 2012, Acta Materialia 60 (2012) 3894–3901, eq. (17)
! Gröger et al. 2008, Acta Materialia 56 (2008) 5412–5425, table 1
!--------------------------------------------------------------------------------------------------
function lattice_nonschmidmatrix(Nslip,nonSchmidCoefficients,sense) result(nonSchmidMatrix)
 
  integer,     dimension(:),                intent(in) :: nslip
  real(preal), dimension(:),                intent(in) :: nonschmidcoefficients
  integer,                                  intent(in) :: sense
  real(preal), dimension(1:3,1:3,sum(Nslip))           :: nonschmidmatrix
 
  real(preal), dimension(1:3,1:3,sum(Nslip))           :: coordinatesystem
  real(preal), dimension(3)                            :: direction, normal, np
  type(rotation)                                       :: r
  integer                                              :: i
 
  if (abs(sense) /= 1) call io_error(0,ext_msg='lattice_nonSchmidMatrix')
 
  coordinatesystem  = buildcoordinatesystem(nslip,bcc_nslipsystem,bcc_systemslip,&
                                            'bcc',0.0_preal)
  coordinatesystem(1:3,1,1:sum(nslip)) = coordinatesystem(1:3,1,1:sum(nslip))*real(sense,preal)     ! convert unidirectional coordinate system
  nonschmidmatrix = lattice_schmidmatrix_slip(nslip,'bcc',0.0_preal)                                ! Schmid contribution
 
  do i = 1,sum(nslip)
    direction = coordinatesystem(1:3,1,i)
    normal    = coordinatesystem(1:3,2,i)
    call r%fromAxisAngle([direction,60.0_preal],degrees=.true.,p=1)
    np = r%rotate(normal)
 
    if (size(nonschmidcoefficients)>0) nonschmidmatrix(1:3,1:3,i) = nonschmidmatrix(1:3,1:3,i) &
      + nonschmidcoefficients(1) * math_outer(direction, np)
    if (size(nonschmidcoefficients)>1) nonschmidmatrix(1:3,1:3,i) = nonschmidmatrix(1:3,1:3,i) &
      + nonschmidcoefficients(2) * math_outer(math_cross(normal, direction), normal)
    if (size(nonschmidcoefficients)>2) nonschmidmatrix(1:3,1:3,i) = nonschmidmatrix(1:3,1:3,i) &
      + nonschmidcoefficients(3) * math_outer(math_cross(np, direction), np)
    if (size(nonschmidcoefficients)>3) nonschmidmatrix(1:3,1:3,i) = nonschmidmatrix(1:3,1:3,i) &
      + nonschmidcoefficients(4) * math_outer(normal, normal)
    if (size(nonschmidcoefficients)>4) nonschmidmatrix(1:3,1:3,i) = nonschmidmatrix(1:3,1:3,i) &
      + nonschmidcoefficients(5) * math_outer(math_cross(normal, direction), &
                                              math_cross(normal, direction))
    if (size(nonschmidcoefficients)>5) nonschmidmatrix(1:3,1:3,i) = nonschmidmatrix(1:3,1:3,i) &
      + nonschmidcoefficients(6) * math_outer(direction, direction)
  enddo
 
end function lattice_nonschmidmatrix
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function lattice_interaction_slipbyslip(Nslip,interactionValues,structure) result(interactionMatrix)
 
  integer,         dimension(:),                   intent(in) :: nslip
  real(preal),     dimension(:),                   intent(in) :: interactionvalues
  character(len=*),                                intent(in) :: structure
  real(preal),     dimension(sum(Nslip),sum(Nslip))           :: interactionmatrix
 
  integer, dimension(:),   allocatable :: nslipmax
  integer, dimension(:,:), allocatable :: interactiontypes
 
  integer, dimension(FCC_NSLIP,FCC_NSLIP), parameter :: &
    fcc_interactionslipslip = reshape( [&
       1, 2, 2, 4, 6, 5, 3, 5, 5, 4, 5, 6,  9,10, 9,10,11,12, & ! -----> acting
       2, 1, 2, 6, 4, 5, 5, 4, 6, 5, 3, 5,  9,10,11,12, 9,10, & ! |
       2, 2, 1, 5, 5, 3, 5, 6, 4, 6, 5, 4, 11,12, 9,10, 9,10, & ! |
       4, 6, 5, 1, 2, 2, 4, 5, 6, 3, 5, 5,  9,10,10, 9,12,11, & ! v
       6, 4, 5, 2, 1, 2, 5, 3, 5, 5, 4, 6,  9,10,12,11,10, 9, & ! reacting
       5, 5, 3, 2, 2, 1, 6, 5, 4, 5, 6, 4, 11,12,10, 9,10, 9, &
       3, 5, 5, 4, 5, 6, 1, 2, 2, 4, 6, 5, 10, 9,10, 9,11,12, &
       5, 4, 6, 5, 3, 5, 2, 1, 2, 6, 4, 5, 10, 9,12,11, 9,10, &
       5, 6, 4, 6, 5, 4, 2, 2, 1, 5, 5, 3, 12,11,10, 9, 9,10, &
       4, 5, 6, 3, 5, 5, 4, 6, 5, 1, 2, 2, 10, 9, 9,10,12,11, &
       5, 3, 5, 5, 4, 6, 6, 4, 5, 2, 1, 2, 10, 9,11,12,10, 9, &
       6, 5, 4, 5, 6, 4, 5, 5, 3, 2, 2, 1, 12,11, 9,10,10, 9, &
 
       9, 9,11, 9, 9,11,10,10,12,10,10,12,  1, 7, 8, 8, 8, 8, &
      10,10,12,10,10,12, 9, 9,11, 9, 9,11,  7, 1, 8, 8, 8, 8, &
       9,11, 9,10,12,10,10,12,10, 9,11, 9,  8, 8, 1, 7, 8, 8, &
      10,12,10, 9,11, 9, 9,11, 9,10,12,10,  8, 8, 7, 1, 8, 8, &
      11, 9, 9,12,10,10,11, 9, 9,12,10,10,  8, 8, 8, 8, 1, 7, &
      12,10,10,11, 9, 9,12,10,10,11, 9, 9,  8, 8, 8, 8, 7, 1  &
      ],shape(fcc_interactionslipslip))                                                             
 
  integer, dimension(BCC_NSLIP,BCC_NSLIP), parameter :: &
    bcc_interactionslipslip = reshape( [&
      1,2,6,6,5,4,4,3,4,3,5,4, 6,6,4,3,3,4,6,6,4,3,6,6, & ! -----> acting
      2,1,6,6,4,3,5,4,5,4,4,3, 6,6,3,4,4,3,6,6,3,4,6,6, & ! |
      6,6,1,2,4,5,3,4,4,5,3,4, 4,3,6,6,6,6,3,4,6,6,4,3, & ! |
      6,6,2,1,3,4,4,5,3,4,4,5, 3,4,6,6,6,6,4,3,6,6,3,4, & ! v
      5,4,4,3,1,2,6,6,3,4,5,4, 3,6,4,6,6,4,6,3,4,6,3,6, & ! reacting
      4,3,5,4,2,1,6,6,4,5,4,3, 4,6,3,6,6,3,6,4,3,6,4,6, &
      4,5,3,4,6,6,1,2,5,4,3,4, 6,3,6,4,4,6,3,6,6,4,6,3, &
      3,4,4,5,6,6,2,1,4,3,4,5, 6,4,6,3,3,6,4,6,6,3,6,4, &
      4,5,4,3,3,4,5,4,1,2,6,6, 3,6,6,4,4,6,6,3,6,4,3,6, &
      3,4,5,4,4,5,4,3,2,1,6,6, 4,6,6,3,3,6,6,4,6,3,4,6, &
      5,4,3,4,5,4,3,4,6,6,1,2, 6,3,4,6,6,4,3,6,4,6,6,3, &
      4,3,4,5,4,3,4,5,6,6,2,1, 6,4,3,6,6,3,4,6,3,6,6,4, &
      !
      6,6,4,3,3,4,6,6,3,4,6,6, 1,5,6,6,5,6,6,3,5,6,3,6, &
      6,6,3,4,6,6,3,4,6,6,3,4, 5,1,6,6,6,5,3,6,6,5,6,3, &
      4,3,6,6,4,3,6,6,6,6,4,3, 6,6,1,5,6,3,5,6,3,6,5,6, &
      3,4,6,6,6,6,4,3,4,3,6,6, 6,6,5,1,3,6,6,5,6,3,6,5, &
      3,4,6,6,6,6,4,3,4,3,6,6, 5,6,6,3,1,6,5,6,5,3,6,6, &
      4,3,6,6,4,3,6,6,6,6,4,3, 6,5,3,6,6,1,6,5,3,5,6,6, &
      6,6,3,4,6,6,3,4,6,6,3,4, 6,3,5,6,5,6,1,6,6,6,5,3, &
      6,6,4,3,3,4,6,6,3,4,6,6, 3,6,6,5,6,5,6,1,6,6,3,5, &
      4,3,6,6,4,3,6,6,6,6,4,3, 5,6,3,6,5,3,6,6,1,6,6,5, &
      3,4,6,6,6,6,4,3,4,3,6,6, 6,5,6,3,3,5,6,6,6,1,5,6, &
      6,6,4,3,3,4,6,6,3,4,6,6, 3,6,5,6,6,6,5,3,6,5,1,6, &
      6,6,3,4,6,6,3,4,6,6,3,4, 6,3,6,5,6,6,3,5,5,6,6,1  &
      ],shape(bcc_interactionslipslip))                                                             
 
  integer, dimension(HEX_NSLIP,HEX_NSLIP), parameter :: &
    hex_interactionslipslip = reshape( [&
       1, 2, 2,   3, 3, 3,   7, 7, 7,  13,13,13,13,13,13,  21,21,21,21,21,21,21,21,21,21,21,21,  31,31,31,31,31,31, & ! -----> acting
       2, 1, 2,   3, 3, 3,   7, 7, 7,  13,13,13,13,13,13,  21,21,21,21,21,21,21,21,21,21,21,21,  31,31,31,31,31,31, & ! |
       2, 2, 1,   3, 3, 3,   7, 7, 7,  13,13,13,13,13,13,  21,21,21,21,21,21,21,21,21,21,21,21,  31,31,31,31,31,31, & ! |
     !                                                                                                                ! v
       6, 6, 6,   4, 5, 5,   8, 8, 8,  14,14,14,14,14,14,  22,22,22,22,22,22,22,22,22,22,22,22,  32,32,32,32,32,32, & ! reacting
       6, 6, 6,   5, 4, 5,   8, 8, 8,  14,14,14,14,14,14,  22,22,22,22,22,22,22,22,22,22,22,22,  32,32,32,32,32,32, &
       6, 6, 6,   5, 5, 4,   8, 8, 8,  14,14,14,14,14,14,  22,22,22,22,22,22,22,22,22,22,22,22,  32,32,32,32,32,32, &
     !
      12,12,12,  11,11,11,   9,10,10,  15,15,15,15,15,15,  23,23,23,23,23,23,23,23,23,23,23,23,  33,33,33,33,33,33, &
      12,12,12,  11,11,11,  10, 9,10,  15,15,15,15,15,15,  23,23,23,23,23,23,23,23,23,23,23,23,  33,33,33,33,33,33, &
      12,12,12,  11,11,11,  10,10, 9,  15,15,15,15,15,15,  23,23,23,23,23,23,23,23,23,23,23,23,  33,33,33,33,33,33, &
     !
      20,20,20,  19,19,19,  18,18,18,  16,17,17,17,17,17,  24,24,24,24,24,24,24,24,24,24,24,24,  34,34,34,34,34,34, &
      20,20,20,  19,19,19,  18,18,18,  17,16,17,17,17,17,  24,24,24,24,24,24,24,24,24,24,24,24,  34,34,34,34,34,34, &
      20,20,20,  19,19,19,  18,18,18,  17,17,16,17,17,17,  24,24,24,24,24,24,24,24,24,24,24,24,  34,34,34,34,34,34, &
      20,20,20,  19,19,19,  18,18,18,  17,17,17,16,17,17,  24,24,24,24,24,24,24,24,24,24,24,24,  34,34,34,34,34,34, &
      20,20,20,  19,19,19,  18,18,18,  17,17,17,17,16,17,  24,24,24,24,24,24,24,24,24,24,24,24,  34,34,34,34,34,34, &
      20,20,20,  19,19,19,  18,18,18,  17,17,17,17,17,16,  24,24,24,24,24,24,24,24,24,24,24,24,  34,34,34,34,34,34, &
     !
      30,30,30,  29,29,29,  28,28,28,  27,27,27,27,27,27,  25,26,26,26,26,26,26,26,26,26,26,26,  35,35,35,35,35,35, &
      30,30,30,  29,29,29,  28,28,28,  27,27,27,27,27,27,  26,25,26,26,26,26,26,26,26,26,26,26,  35,35,35,35,35,35, &
      30,30,30,  29,29,29,  28,28,28,  27,27,27,27,27,27,  26,26,25,26,26,26,26,26,26,26,26,26,  35,35,35,35,35,35, &
      30,30,30,  29,29,29,  28,28,28,  27,27,27,27,27,27,  26,26,26,25,26,26,26,26,26,26,26,26,  35,35,35,35,35,35, &
      30,30,30,  29,29,29,  28,28,28,  27,27,27,27,27,27,  26,26,26,26,25,26,26,26,26,26,26,26,  35,35,35,35,35,35, &
      30,30,30,  29,29,29,  28,28,28,  27,27,27,27,27,27,  26,26,26,26,26,25,26,26,26,26,26,26,  35,35,35,35,35,35, &
      30,30,30,  29,29,29,  28,28,28,  27,27,27,27,27,27,  26,26,26,26,26,26,25,26,26,26,26,26,  35,35,35,35,35,35, &
      30,30,30,  29,29,29,  28,28,28,  27,27,27,27,27,27,  26,26,26,26,26,26,26,25,26,26,26,26,  35,35,35,35,35,35, &
      30,30,30,  29,29,29,  28,28,28,  27,27,27,27,27,27,  26,26,26,26,26,26,26,26,25,26,26,26,  35,35,35,35,35,35, &
      30,30,30,  29,29,29,  28,28,28,  27,27,27,27,27,27,  26,26,26,26,26,26,26,26,26,25,26,26,  35,35,35,35,35,35, &
      30,30,30,  29,29,29,  28,28,28,  27,27,27,27,27,27,  26,26,26,26,26,26,26,26,26,26,25,26,  35,35,35,35,35,35, &
      30,30,30,  29,29,29,  28,28,28,  27,27,27,27,27,27,  26,26,26,26,26,26,26,26,26,26,26,25,  35,35,35,35,35,35, &
     !
      42,42,42,  41,41,41,  40,40,40,  39,39,39,39,39,39,  38,38,38,38,38,38,38,38,38,38,38,38,  36,37,37,37,37,37, &
      42,42,42,  41,41,41,  40,40,40,  39,39,39,39,39,39,  38,38,38,38,38,38,38,38,38,38,38,38,  37,36,37,37,37,37, &
      42,42,42,  41,41,41,  40,40,40,  39,39,39,39,39,39,  38,38,38,38,38,38,38,38,38,38,38,38,  37,37,36,37,37,37, &
      42,42,42,  41,41,41,  40,40,40,  39,39,39,39,39,39,  38,38,38,38,38,38,38,38,38,38,38,38,  37,37,37,36,37,37, &
      42,42,42,  41,41,41,  40,40,40,  39,39,39,39,39,39,  38,38,38,38,38,38,38,38,38,38,38,38,  37,37,37,37,36,37, &
      42,42,42,  41,41,41,  40,40,40,  39,39,39,39,39,39,  38,38,38,38,38,38,38,38,38,38,38,38,  37,37,37,37,37,36  &
     ],shape(hex_interactionslipslip))                                                              
 
  integer, dimension(BCT_NSLIP,BCT_NSLIP), parameter :: &
    bct_interactionslipslip = reshape( [&
      1,  2,   3,  3,   7,  7,  13, 13, 13, 13,  21, 21,  31, 31, 31, 31,  43, 43,  57, 57,  73, 73, 73, 73,  91, 91, 91, 91, 91, 91, 91, 91,  111, 111, 111, 111, 133,133,133,133,133,133,133,133, 157,157,157,157,157,157,157,157, & ! -----> acting
      2,  1,   3,  3,   7,  7,  13, 13, 13, 13,  21, 21,  31, 31, 31, 31,  43, 43,  57, 57,  73, 73, 73, 73,  91, 91, 91, 91, 91, 91, 91, 91,  111, 111, 111, 111, 133,133,133,133,133,133,133,133, 157,157,157,157,157,157,157,157, & ! |
     !                                                                                                                                                                                                                                   |
      6,  6,   4,  5,   8,  8,  14, 14, 14, 14,  22, 22,  32, 32, 32, 32,  44, 44,  58, 58,  74, 74, 74, 74,  92, 92, 92, 92, 92, 92, 92, 92,  112, 112, 112, 112, 134,134,134,134,134,134,134,134, 158,158,158,158,158,158,158,158, & ! v
      6,  6,   5,  4,   8,  8,  14, 14, 14, 14,  22, 22,  32, 32, 32, 32,  44, 44,  58, 58,  74, 74, 74, 74,  92, 92, 92, 92, 92, 92, 92, 92,  112, 112, 112, 112, 134,134,134,134,134,134,134,134, 158,158,158,158,158,158,158,158, & ! reacting
     !
     12, 12,  11, 11,   9, 10,  15, 15, 15, 15,  23, 23,  33, 33, 33, 33,  45, 45,  59, 59,  75, 75, 75, 75,  93, 93, 93, 93, 93, 93, 93, 93,  113, 113, 113, 113, 135,135,135,135,135,135,135,135, 159,159,159,159,159,159,159,159, &
     12, 12,  11, 11,  10,  9,  15, 15, 15, 15,  23, 23,  33, 33, 33, 33,  45, 45,  59, 59,  75, 75, 75, 75,  93, 93, 93, 93, 93, 93, 93, 93,  113, 113, 113, 113, 135,135,135,135,135,135,135,135, 159,159,159,159,159,159,159,159, &
     !
     20, 20,  19, 19,  18, 18,  16, 17, 17, 17,  24, 24,  34, 34, 34, 34,  46, 46,  60, 60,  76, 76, 76, 76,  94, 94, 94, 94, 94, 94, 94, 94,  114, 114, 114, 114, 136,136,136,136,136,136,136,136, 160,160,160,160,160,160,160,160, &
     20, 20,  19, 19,  18, 18,  17, 16, 17, 17,  24, 24,  34, 34, 34, 34,  46, 46,  60, 60,  76, 76, 76, 76,  94, 94, 94, 94, 94, 94, 94, 94,  114, 114, 114, 114, 136,136,136,136,136,136,136,136, 160,160,160,160,160,160,160,160, &
     20, 20,  19, 19,  18, 18,  17, 17, 16, 17,  24, 24,  34, 34, 34, 34,  46, 46,  60, 60,  76, 76, 76, 76,  94, 94, 94, 94, 94, 94, 94, 94,  114, 114, 114, 114, 136,136,136,136,136,136,136,136, 160,160,160,160,160,160,160,160, &
     20, 20,  19, 19,  18, 18,  17, 17, 17, 16,  24, 24,  34, 34, 34, 34,  46, 46,  60, 60,  76, 76, 76, 76,  94, 94, 94, 94, 94, 94, 94, 94,  114, 114, 114, 114, 136,136,136,136,136,136,136,136, 160,160,160,160,160,160,160,160, &
     !
     30, 30,  29, 29,  28, 28,  27, 27, 27, 27,  25, 26,  35, 35, 35, 35,  47, 47,  61, 61,  77, 77, 77, 77,  95, 95, 95, 95, 95, 95, 95, 95,  115, 115, 115, 115, 137,137,137,137,137,137,137,137, 161,161,161,161,161,161,161,161, &
     30, 30,  29, 29,  28, 28,  27, 27, 27, 27,  26, 25,  35, 35, 35, 35,  47, 47,  61, 61,  77, 77, 77, 77,  95, 95, 95, 95, 95, 95, 95, 95,  115, 115, 115, 115, 137,137,137,137,137,137,137,137, 161,161,161,161,161,161,161,161, &
     !
     42, 42,  41, 41,  40, 40,  39, 39, 39, 39,  38, 38,  36, 37, 37, 37,  48, 48,  62, 62,  78, 78, 78, 78,  96, 96, 96, 96, 96, 96, 96, 96,  116, 116, 116, 116, 138,138,138,138,138,138,138,138, 162,162,162,162,162,162,162,162, &
     42, 42,  41, 41,  40, 40,  39, 39, 39, 39,  38, 38,  37, 36, 37, 37,  48, 48,  62, 62,  78, 78, 78, 78,  96, 96, 96, 96, 96, 96, 96, 96,  116, 116, 116, 116, 138,138,138,138,138,138,138,138, 162,162,162,162,162,162,162,162, &
     42, 42,  41, 41,  40, 40,  39, 39, 39, 39,  38, 38,  37, 37, 36, 37,  48, 48,  62, 62,  78, 78, 78, 78,  96, 96, 96, 96, 96, 96, 96, 96,  116, 116, 116, 116, 138,138,138,138,138,138,138,138, 162,162,162,162,162,162,162,162, &
     42, 42,  41, 41,  40, 40,  39, 39, 39, 39,  38, 38,  37, 37, 37, 36,  48, 48,  62, 62,  78, 78, 78, 78,  96, 96, 96, 96, 96, 96, 96, 96,  116, 116, 116, 116, 138,138,138,138,138,138,138,138, 162,162,162,162,162,162,162,162, &
     !
     56, 56,  55, 55,  54, 54,  53, 53, 53, 53,  52, 52,  51, 51, 51, 51,  49, 50,  63, 63,  79, 79, 79, 79,  97, 97, 97, 97, 97, 97, 97, 97,  117, 117, 117, 117, 139,139,139,139,139,139,139,139, 163,163,163,163,163,163,163,163, &
     56, 56,  55, 55,  54, 54,  53, 53, 53, 53,  52, 52,  51, 51, 51, 51,  50, 49,  63, 63,  79, 79, 79, 79,  97, 97, 97, 97, 97, 97, 97, 97,  117, 117, 117, 117, 139,139,139,139,139,139,139,139, 163,163,163,163,163,163,163,163, &
     !
     72, 72,  71, 71,  70, 70,  69, 69, 69, 69,  68, 68,  67, 67, 67, 67,  66, 66,  64, 65,  80, 80, 80, 80,  98, 98, 98, 98, 98, 98, 98, 98,  118, 118, 118, 118, 140,140,140,140,140,140,140,140, 164,164,164,164,164,164,164,164, &
     72, 72,  71, 71,  70, 70,  69, 69, 69, 69,  68, 68,  67, 67, 67, 67,  66, 66,  65, 64,  80, 80, 80, 80,  98, 98, 98, 98, 98, 98, 98, 98,  118, 118, 118, 118, 140,140,140,140,140,140,140,140, 164,164,164,164,164,164,164,164, &
     !
     90, 90,  89, 89,  88, 88,  87, 87, 87, 87,  86, 86,  85, 85, 85, 85,  84, 84,  83, 83,  81, 82, 82, 82,  99, 99, 99, 99, 99, 99, 99, 99,  119, 119, 119, 119, 141,141,141,141,141,141,141,141, 165,165,165,165,165,165,165,165, &
     90, 90,  89, 89,  88, 88,  87, 87, 87, 87,  86, 86,  85, 85, 85, 85,  84, 84,  83, 83,  82, 81, 82, 82,  99, 99, 99, 99, 99, 99, 99, 99,  119, 119, 119, 119, 141,141,141,141,141,141,141,141, 165,165,165,165,165,165,165,165, &
     90, 90,  89, 89,  88, 88,  87, 87, 87, 87,  86, 86,  85, 85, 85, 85,  84, 84,  83, 83,  82, 82, 81, 82,  99, 99, 99, 99, 99, 99, 99, 99,  119, 119, 119, 119, 141,141,141,141,141,141,141,141, 165,165,165,165,165,165,165,165, &
     90, 90,  89, 89,  88, 88,  87, 87, 87, 87,  86, 86,  85, 85, 85, 85,  84, 84,  83, 83,  82, 82, 82, 81,  99, 99, 99, 99, 99, 99, 99, 99,  119, 119, 119, 119, 141,141,141,141,141,141,141,141, 165,165,165,165,165,165,165,165, &
     !
    110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 100,101,101,101,101,101,101,101,  120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, &
    110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,100,101,101,101,101,101,101,  120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, &
    110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,100,101,101,101,101,101,  120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, &
    110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,101,100,101,101,101,101,  120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, &
    110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,101,101,100,101,101,101,  120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, &
    110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,101,101,101,100,101,101,  120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, &
    110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,101,101,101,101,100,101,  120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, &
    110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,101,101,101,101,101,100,  120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, &
     !
    132,132, 131,131, 130,130, 129,129,129,129, 128,128, 127,127,127,127, 126,126, 125,125, 124,124,124,124, 123,123,123,123,123,123,123,123,  121, 122, 122, 122, 143,143,143,143,143,143,143,143, 167,167,167,167,167,167,167,167, &
    132,132, 131,131, 130,130, 129,129,129,129, 128,128, 127,127,127,127, 126,126, 125,125, 124,124,124,124, 123,123,123,123,123,123,123,123,  121, 121, 122, 122, 143,143,143,143,143,143,143,143, 167,167,167,167,167,167,167,167, &
    132,132, 131,131, 130,130, 129,129,129,129, 128,128, 127,127,127,127, 126,126, 125,125, 124,124,124,124, 123,123,123,123,123,123,123,123,  121, 122, 121, 122, 143,143,143,143,143,143,143,143, 167,167,167,167,167,167,167,167, &
    132,132, 131,131, 130,130, 129,129,129,129, 128,128, 127,127,127,127, 126,126, 125,125, 124,124,124,124, 123,123,123,123,123,123,123,123,  121, 122, 122, 121, 143,143,143,143,143,143,143,143, 167,167,167,167,167,167,167,167, &
     !
    156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147,  146, 146, 146, 146, 144,145,145,145,145,145,145,145, 168,168,168,168,168,168,168,168, &
    156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147,  146, 146, 146, 146, 145,144,145,145,145,145,145,145, 168,168,168,168,168,168,168,168, &
    156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147,  146, 146, 146, 146, 145,145,144,145,145,145,145,145, 168,168,168,168,168,168,168,168, &
    156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147,  146, 146, 146, 146, 145,145,145,144,145,145,145,145, 168,168,168,168,168,168,168,168, &
    156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147,  146, 146, 146, 146, 145,145,145,145,144,145,145,145, 168,168,168,168,168,168,168,168, &
    156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147,  146, 146, 146, 146, 145,145,145,145,145,144,145,145, 168,168,168,168,168,168,168,168, &
    156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147,  146, 146, 146, 146, 145,145,145,145,145,145,144,145, 168,168,168,168,168,168,168,168, &
    156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147,  146, 146, 146, 146, 145,145,145,145,145,145,145,144, 168,168,168,168,168,168,168,168, &
     !
    182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173,  172, 172, 172, 172, 171,171,171,171,171,171,171,171, 169,170,170,170,170,170,170,170, &
    182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173,  172, 172, 172, 172, 171,171,171,171,171,171,171,171, 170,169,170,170,170,170,170,170, &
    182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173,  172, 172, 172, 172, 171,171,171,171,171,171,171,171, 170,170,169,170,170,170,170,170, &
    182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173,  172, 172, 172, 172, 171,171,171,171,171,171,171,171, 170,170,170,169,170,170,170,170, &
    182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173,  172, 172, 172, 172, 171,171,171,171,171,171,171,171, 170,170,170,170,169,170,170,170, &
    182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173,  172, 172, 172, 172, 171,171,171,171,171,171,171,171, 169,170,170,170,170,169,170,170, &
    182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173,  172, 172, 172, 172, 171,171,171,171,171,171,171,171, 169,170,170,170,170,170,169,170, &
    182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173,  172, 172, 172, 172, 171,171,171,171,171,171,171,171, 169,170,170,170,170,170,170,169  &
  ],shape(bct_interactionslipslip))
 
 
  if (len_trim(structure) /= 3) &
    call io_error(137,ext_msg='lattice_interaction_SlipBySlip: '//trim(structure))
 
  select case(structure)
    case('fcc')
      interactiontypes = fcc_interactionslipslip
      nslipmax         = fcc_nslipsystem
    case('bcc')
      interactiontypes = bcc_interactionslipslip
      nslipmax         = bcc_nslipsystem
    case('hex')
      interactiontypes = hex_interactionslipslip
      nslipmax         = hex_nslipsystem
    case('bct')
      interactiontypes = bct_interactionslipslip
      nslipmax         = bct_nslipsystem
    case default
      call io_error(137,ext_msg='lattice_interaction_SlipBySlip: '//trim(structure))
  end select
 
  interactionmatrix = buildinteraction(nslip,nslip,nslipmax,nslipmax,interactionvalues,interactiontypes)
 
end function lattice_interaction_slipbyslip
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function lattice_interaction_twinbytwin(Ntwin,interactionValues,structure) result(interactionMatrix)
 
  integer,         dimension(:),                   intent(in) :: ntwin
  real(preal),     dimension(:),                   intent(in) :: interactionvalues
  character(len=*),                                intent(in) :: structure
  real(preal),     dimension(sum(Ntwin),sum(Ntwin))           :: interactionmatrix
 
  integer, dimension(:),   allocatable :: ntwinmax
  integer, dimension(:,:), allocatable :: interactiontypes
 
  integer, dimension(FCC_NTWIN,FCC_NTWIN), parameter :: &
    fcc_interactiontwintwin = reshape( [&
      1,1,1,2,2,2,2,2,2,2,2,2, & ! -----> acting
      1,1,1,2,2,2,2,2,2,2,2,2, & ! |
      1,1,1,2,2,2,2,2,2,2,2,2, & ! |
      2,2,2,1,1,1,2,2,2,2,2,2, & ! v
      2,2,2,1,1,1,2,2,2,2,2,2, & ! reacting
      2,2,2,1,1,1,2,2,2,2,2,2, &
      2,2,2,2,2,2,1,1,1,2,2,2, &
      2,2,2,2,2,2,1,1,1,2,2,2, &
      2,2,2,2,2,2,1,1,1,2,2,2, &
      2,2,2,2,2,2,2,2,2,1,1,1, &
      2,2,2,2,2,2,2,2,2,1,1,1, &
      2,2,2,2,2,2,2,2,2,1,1,1  &
      ],shape(fcc_interactiontwintwin))                                                             
 
  integer, dimension(BCC_NTWIN,BCC_NTWIN), parameter :: &
    bcc_interactiontwintwin = reshape( [&
      1,3,3,3,3,3,3,2,3,3,2,3, & ! -----> acting
      3,1,3,3,3,3,2,3,3,3,3,2, & ! |
      3,3,1,3,3,2,3,3,2,3,3,3, & ! |
      3,3,3,1,2,3,3,3,3,2,3,3, & ! v
      3,3,3,2,1,3,3,3,3,2,3,3, & ! reacting
      3,3,2,3,3,1,3,3,2,3,3,3, &
      3,2,3,3,3,3,1,3,3,3,3,2, &
      2,3,3,3,3,3,3,1,3,3,2,3, &
      3,3,2,3,3,2,3,3,1,3,3,3, &
      3,3,3,2,2,3,3,3,3,1,3,3, &
      2,3,3,3,3,3,3,2,3,3,1,3, &
      3,2,3,3,3,3,2,3,3,3,3,1  &
      ],shape(bcc_interactiontwintwin))                                                             
  integer, dimension(HEX_NTWIN,HEX_NTWIN), parameter :: &
    hex_interactiontwintwin = reshape( [&
       1, 2, 2, 2, 2, 2,   3, 3, 3, 3, 3, 3,   7, 7, 7, 7, 7, 7,  13,13,13,13,13,13, & ! -----> acting
       2, 1, 2, 2, 2, 2,   3, 3, 3, 3, 3, 3,   7, 7, 7, 7, 7, 7,  13,13,13,13,13,13, & ! |
       2, 2, 1, 2, 2, 2,   3, 3, 3, 3, 3, 3,   7, 7, 7, 7, 7, 7,  13,13,13,13,13,13, & ! |
       2, 2, 2, 1, 2, 2,   3, 3, 3, 3, 3, 3,   7, 7, 7, 7, 7, 7,  13,13,13,13,13,13, & ! v
       2, 2, 2, 2, 1, 2,   3, 3, 3, 3, 3, 3,   7, 7, 7, 7, 7, 7,  13,13,13,13,13,13, & ! reacting
       2, 2, 2, 2, 2, 1,   3, 3, 3, 3, 3, 3,   7, 7, 7, 7, 7, 7,  13,13,13,13,13,13, &
     !
       6, 6, 6, 6, 6, 6,   4, 5, 5, 5, 5, 5,   8, 8, 8, 8, 8, 8,  14,14,14,14,14,14, &
       6, 6, 6, 6, 6, 6,   5, 4, 5, 5, 5, 5,   8, 8, 8, 8, 8, 8,  14,14,14,14,14,14, &
       6, 6, 6, 6, 6, 6,   5, 5, 4, 5, 5, 5,   8, 8, 8, 8, 8, 8,  14,14,14,14,14,14, &
       6, 6, 6, 6, 6, 6,   5, 5, 5, 4, 5, 5,   8, 8, 8, 8, 8, 8,  14,14,14,14,14,14, &
       6, 6, 6, 6, 6, 6,   5, 5, 5, 5, 4, 5,   8, 8, 8, 8, 8, 8,  14,14,14,14,14,14, &
       6, 6, 6, 6, 6, 6,   5, 5, 5, 5, 5, 4,   8, 8, 8, 8, 8, 8,  14,14,14,14,14,14, &
     !
      12,12,12,12,12,12,  11,11,11,11,11,11,   9,10,10,10,10,10,  15,15,15,15,15,15, &
      12,12,12,12,12,12,  11,11,11,11,11,11,  10, 9,10,10,10,10,  15,15,15,15,15,15, &
      12,12,12,12,12,12,  11,11,11,11,11,11,  10,10, 9,10,10,10,  15,15,15,15,15,15, &
      12,12,12,12,12,12,  11,11,11,11,11,11,  10,10,10, 9,10,10,  15,15,15,15,15,15, &
      12,12,12,12,12,12,  11,11,11,11,11,11,  10,10,10,10, 9,10,  15,15,15,15,15,15, &
      12,12,12,12,12,12,  11,11,11,11,11,11,  10,10,10,10,10, 9,  15,15,15,15,15,15, &
     !
      20,20,20,20,20,20,  19,19,19,19,19,19,  18,18,18,18,18,18,  16,17,17,17,17,17, &
      20,20,20,20,20,20,  19,19,19,19,19,19,  18,18,18,18,18,18,  17,16,17,17,17,17, &
      20,20,20,20,20,20,  19,19,19,19,19,19,  18,18,18,18,18,18,  17,17,16,17,17,17, &
      20,20,20,20,20,20,  19,19,19,19,19,19,  18,18,18,18,18,18,  17,17,17,16,17,17, &
      20,20,20,20,20,20,  19,19,19,19,19,19,  18,18,18,18,18,18,  17,17,17,17,16,17, &
      20,20,20,20,20,20,  19,19,19,19,19,19,  18,18,18,18,18,18,  17,17,17,17,17,16  &
      ],shape(hex_interactiontwintwin))                                                             
 
  if (len_trim(structure) /= 3) &
    call io_error(137,ext_msg='lattice_interaction_TwinByTwin: '//trim(structure))
 
  select case(structure)
    case('fcc')
      interactiontypes = fcc_interactiontwintwin
      ntwinmax         = fcc_ntwinsystem
    case('bcc')
      interactiontypes = bcc_interactiontwintwin
      ntwinmax         = bcc_ntwinsystem
    case('hex')
      interactiontypes = hex_interactiontwintwin
      ntwinmax         = hex_ntwinsystem
    case default
      call io_error(137,ext_msg='lattice_interaction_TwinByTwin: '//trim(structure))
  end select
 
  interactionmatrix = buildinteraction(ntwin,ntwin,ntwinmax,ntwinmax,interactionvalues,interactiontypes)
 
end function lattice_interaction_twinbytwin
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function lattice_interaction_transbytrans(Ntrans,interactionValues,structure) result(interactionMatrix)
 
  integer,         dimension(:),                     intent(in) :: ntrans
  real(preal),     dimension(:),                     intent(in) :: interactionvalues
  character(len=*),                                  intent(in) :: structure
  real(preal),     dimension(sum(Ntrans),sum(Ntrans))           :: interactionmatrix
 
  integer, dimension(:),   allocatable :: ntransmax
  integer, dimension(:,:), allocatable :: interactiontypes
 
  integer, dimension(FCC_NTRANS,FCC_NTRANS), parameter :: &
    fcc_interactiontranstrans = reshape( [&
      1,1,1,2,2,2,2,2,2,2,2,2, & ! -----> acting
      1,1,1,2,2,2,2,2,2,2,2,2, & ! |
      1,1,1,2,2,2,2,2,2,2,2,2, & ! |
      2,2,2,1,1,1,2,2,2,2,2,2, & ! v
      2,2,2,1,1,1,2,2,2,2,2,2, & ! reacting
      2,2,2,1,1,1,2,2,2,2,2,2, &
      2,2,2,2,2,2,1,1,1,2,2,2, &
      2,2,2,2,2,2,1,1,1,2,2,2, &
      2,2,2,2,2,2,1,1,1,2,2,2, &
      2,2,2,2,2,2,2,2,2,1,1,1, &
      2,2,2,2,2,2,2,2,2,1,1,1, &
      2,2,2,2,2,2,2,2,2,1,1,1  &
      ],shape(fcc_interactiontranstrans))                                                           
 
  if (len_trim(structure) /= 3) &
    call io_error(137,ext_msg='lattice_interaction_TransByTrans: '//trim(structure))
 
  if(structure == 'fcc') then
    interactiontypes = fcc_interactiontranstrans
    ntransmax        = fcc_ntranssystem
  else
    call io_error(137,ext_msg='lattice_interaction_TransByTrans: '//trim(structure))
  end if
 
  interactionmatrix = buildinteraction(ntrans,ntrans,ntransmax,ntransmax,interactionvalues,interactiontypes)
 
end function lattice_interaction_transbytrans
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function lattice_interaction_slipbytwin(Nslip,Ntwin,interactionValues,structure) result(interactionMatrix)
 
  integer,         dimension(:),                   intent(in) :: nslip, &                           !< number of active slip systems per family
                                                                 ntwin
  real(preal),     dimension(:),                   intent(in) :: interactionvalues
  character(len=*),                                intent(in) :: structure
  real(preal),     dimension(sum(Nslip),sum(Ntwin))           :: interactionmatrix
 
  integer, dimension(:),   allocatable :: nslipmax, &
                                          ntwinmax
  integer, dimension(:,:), allocatable :: interactiontypes
 
  integer, dimension(FCC_NTWIN,FCC_NSLIP), parameter :: &
    fcc_interactionsliptwin = reshape( [&
      1,1,1,3,3,3,2,2,2,3,3,3, & ! -----> twin (acting)
      1,1,1,3,3,3,3,3,3,2,2,2, & ! |
      1,1,1,2,2,2,3,3,3,3,3,3, & ! |
      3,3,3,1,1,1,3,3,3,2,2,2, & ! v
      3,3,3,1,1,1,2,2,2,3,3,3, & ! slip (reacting)
      2,2,2,1,1,1,3,3,3,3,3,3, &
      2,2,2,3,3,3,1,1,1,3,3,3, &
      3,3,3,2,2,2,1,1,1,3,3,3, &
      3,3,3,3,3,3,1,1,1,2,2,2, &
      3,3,3,2,2,2,3,3,3,1,1,1, &
      2,2,2,3,3,3,3,3,3,1,1,1, &
      3,3,3,3,3,3,2,2,2,1,1,1, &
 
      4,4,4,4,4,4,4,4,4,4,4,4, &
      4,4,4,4,4,4,4,4,4,4,4,4, &
      4,4,4,4,4,4,4,4,4,4,4,4, &
      4,4,4,4,4,4,4,4,4,4,4,4, &
      4,4,4,4,4,4,4,4,4,4,4,4, &
      4,4,4,4,4,4,4,4,4,4,4,4  &
      ],shape(fcc_interactionsliptwin))                                                             
  integer, dimension(BCC_NTWIN,BCC_NSLIP), parameter :: &
   bcc_interactionsliptwin = reshape( [&
      3,3,3,2,2,3,3,3,3,2,3,3, & ! -----> twin (acting)
      3,3,2,3,3,2,3,3,2,3,3,3, & ! |
      3,2,3,3,3,3,2,3,3,3,3,2, & ! |
      2,3,3,3,3,3,3,2,3,3,2,3, & ! v
      2,3,3,3,3,3,3,2,3,3,2,3, & ! slip (reacting)
      3,3,2,3,3,2,3,3,2,3,3,3, &
      3,2,3,3,3,3,2,3,3,3,3,2, &
      3,3,3,2,2,3,3,3,3,2,3,3, &
      2,3,3,3,3,3,3,2,3,3,2,3, &
      3,3,3,2,2,3,3,3,3,2,3,3, &
      3,2,3,3,3,3,2,3,3,3,3,2, &
      3,3,2,3,3,2,3,3,2,3,3,3, &
      !
      1,3,3,3,3,3,3,2,3,3,2,3, &
      3,1,3,3,3,3,2,3,3,3,3,2, &
      3,3,1,3,3,2,3,3,2,3,3,3, &
      3,3,3,1,2,3,3,3,3,2,3,3, &
      3,3,3,2,1,3,3,3,3,2,3,3, &
      3,3,2,3,3,1,3,3,2,3,3,3, &
      3,2,3,3,3,3,1,3,3,3,3,2, &
      2,3,3,3,3,3,3,1,3,3,2,3, &
      3,3,2,3,3,2,3,3,1,3,3,3, &
      3,3,3,2,2,3,3,3,3,1,3,3, &
      2,3,3,3,3,3,3,2,3,3,1,3, &
      3,2,3,3,3,3,2,3,3,3,3,1  &
      ],shape(bcc_interactionsliptwin))                                                             
  integer, dimension(HEX_NTWIN,HEX_NSLIP), parameter :: &
    hex_interactionsliptwin = reshape( [&
       1, 1, 1, 1, 1, 1,   2, 2, 2, 2, 2, 2,   3, 3, 3, 3, 3, 3,   4, 4, 4, 4, 4, 4, & ! ----> twin (acting)
       1, 1, 1, 1, 1, 1,   2, 2, 2, 2, 2, 2,   3, 3, 3, 3, 3, 3,   4, 4, 4, 4, 4, 4, & ! |
       1, 1, 1, 1, 1, 1,   2, 2, 2, 2, 2, 2,   3, 3, 3, 3, 3, 3,   4, 4, 4, 4, 4, 4, & ! |
     !                                                                                   v
       5, 5, 5, 5, 5, 5,   6, 6, 6, 6, 6, 6,   7, 7, 7, 7, 7, 7,   8, 8, 8, 8, 8, 8, & ! slip (reacting)
       5, 5, 5, 5, 5, 5,   6, 6, 6, 6, 6, 6,   7, 7, 7, 7, 7, 7,   8, 8, 8, 8, 8, 8, &
       5, 5, 5, 5, 5, 5,   6, 6, 6, 6, 6, 6,   7, 7, 7, 7, 7, 7,   8, 8, 8, 8, 8, 8, &
     !
       9, 9, 9, 9, 9, 9,  10,10,10,10,10,10,  11,11,11,11,11,11,  12,12,12,12,12,12, &
       9, 9, 9, 9, 9, 9,  10,10,10,10,10,10,  11,11,11,11,11,11,  12,12,12,12,12,12, &
       9, 9, 9, 9, 9, 9,  10,10,10,10,10,10,  11,11,11,11,11,11,  12,12,12,12,12,12, &
     !
      13,13,13,13,13,13,  14,14,14,14,14,14,  15,15,15,15,15,15,  16,16,16,16,16,16, &
      13,13,13,13,13,13,  14,14,14,14,14,14,  15,15,15,15,15,15,  16,16,16,16,16,16, &
      13,13,13,13,13,13,  14,14,14,14,14,14,  15,15,15,15,15,15,  16,16,16,16,16,16, &
      13,13,13,13,13,13,  14,14,14,14,14,14,  15,15,15,15,15,15,  16,16,16,16,16,16, &
      13,13,13,13,13,13,  14,14,14,14,14,14,  15,15,15,15,15,15,  16,16,16,16,16,16, &
      13,13,13,13,13,13,  14,14,14,14,14,14,  15,15,15,15,15,15,  16,16,16,16,16,16, &
     !
      17,17,17,17,17,17,  18,18,18,18,18,18,  19,19,19,19,19,19,  20,20,20,20,20,20, &
      17,17,17,17,17,17,  18,18,18,18,18,18,  19,19,19,19,19,19,  20,20,20,20,20,20, &
      17,17,17,17,17,17,  18,18,18,18,18,18,  19,19,19,19,19,19,  20,20,20,20,20,20, &
      17,17,17,17,17,17,  18,18,18,18,18,18,  19,19,19,19,19,19,  20,20,20,20,20,20, &
      17,17,17,17,17,17,  18,18,18,18,18,18,  19,19,19,19,19,19,  20,20,20,20,20,20, &
      17,17,17,17,17,17,  18,18,18,18,18,18,  19,19,19,19,19,19,  20,20,20,20,20,20, &
      17,17,17,17,17,17,  18,18,18,18,18,18,  19,19,19,19,19,19,  20,20,20,20,20,20, &
      17,17,17,17,17,17,  18,18,18,18,18,18,  19,19,19,19,19,19,  20,20,20,20,20,20, &
      17,17,17,17,17,17,  18,18,18,18,18,18,  19,19,19,19,19,19,  20,20,20,20,20,20, &
      17,17,17,17,17,17,  18,18,18,18,18,18,  19,19,19,19,19,19,  20,20,20,20,20,20, &
      17,17,17,17,17,17,  18,18,18,18,18,18,  19,19,19,19,19,19,  20,20,20,20,20,20, &
      17,17,17,17,17,17,  18,18,18,18,18,18,  19,19,19,19,19,19,  20,20,20,20,20,20, &
     !
      21,21,21,21,21,21,  22,22,22,22,22,22,  23,23,23,23,23,23,  24,24,24,24,24,24, &
      21,21,21,21,21,21,  22,22,22,22,22,22,  23,23,23,23,23,23,  24,24,24,24,24,24, &
      21,21,21,21,21,21,  22,22,22,22,22,22,  23,23,23,23,23,23,  24,24,24,24,24,24, &
      21,21,21,21,21,21,  22,22,22,22,22,22,  23,23,23,23,23,23,  24,24,24,24,24,24, &
      21,21,21,21,21,21,  22,22,22,22,22,22,  23,23,23,23,23,23,  24,24,24,24,24,24, &
      21,21,21,21,21,21,  22,22,22,22,22,22,  23,23,23,23,23,23,  24,24,24,24,24,24  &
     !
      ],shape(hex_interactionsliptwin))                                                             
 
  if (len_trim(structure) /= 3) &
    call io_error(137,ext_msg='lattice_interaction_SlipByTwin: '//trim(structure))
 
  select case(structure)
    case('fcc')
      interactiontypes = fcc_interactionsliptwin
      nslipmax         = fcc_nslipsystem
      ntwinmax         = fcc_ntwinsystem
    case('bcc')
      interactiontypes = bcc_interactionsliptwin
      nslipmax         = bcc_nslipsystem
      ntwinmax         = bcc_ntwinsystem
    case('hex')
      interactiontypes = hex_interactionsliptwin
      nslipmax         = hex_nslipsystem
      ntwinmax         = hex_ntwinsystem
    case default
      call io_error(137,ext_msg='lattice_interaction_SlipByTwin: '//trim(structure))
  end select
 
  interactionmatrix = buildinteraction(nslip,ntwin,nslipmax,ntwinmax,interactionvalues,interactiontypes)
 
end function lattice_interaction_slipbytwin
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function lattice_interaction_slipbytrans(Nslip,Ntrans,interactionValues,structure) result(interactionMatrix)
 
  integer,         dimension(:),                    intent(in) :: nslip, &                          !< number of active slip systems per family
                                                                  ntrans
  real(preal),     dimension(:),                    intent(in) :: interactionvalues
  character(len=*),                                 intent(in) :: structure
  real(preal),     dimension(sum(Nslip),sum(Ntrans))           :: interactionmatrix
 
  integer, dimension(:),   allocatable :: nslipmax, &
                                          ntransmax
  integer, dimension(:,:), allocatable :: interactiontypes
 
  integer, dimension(FCC_NTRANS,FCC_NSLIP), parameter :: &
    fcc_interactionsliptrans = reshape( [&
      1,1,1,3,3,3,2,2,2,3,3,3, & ! -----> trans (acting)
      1,1,1,3,3,3,3,3,3,2,2,2, & ! |
      1,1,1,2,2,2,3,3,3,3,3,3, & ! |
      3,3,3,1,1,1,3,3,3,2,2,2, & ! v
      3,3,3,1,1,1,2,2,2,3,3,3, & ! slip (reacting)
      2,2,2,1,1,1,3,3,3,3,3,3, &
      2,2,2,3,3,3,1,1,1,3,3,3, &
      3,3,3,2,2,2,1,1,1,3,3,3, &
      3,3,3,3,3,3,1,1,1,2,2,2, &
      3,3,3,2,2,2,3,3,3,1,1,1, &
      2,2,2,3,3,3,3,3,3,1,1,1, &
      3,3,3,3,3,3,2,2,2,1,1,1, &
 
      4,4,4,4,4,4,4,4,4,4,4,4, &
      4,4,4,4,4,4,4,4,4,4,4,4, &
      4,4,4,4,4,4,4,4,4,4,4,4, &
      4,4,4,4,4,4,4,4,4,4,4,4, &
      4,4,4,4,4,4,4,4,4,4,4,4, &
      4,4,4,4,4,4,4,4,4,4,4,4  &
      ],shape(fcc_interactionsliptrans))                                                            
 
  if (len_trim(structure) /= 3) &
    call io_error(137,ext_msg='lattice_interaction_SlipByTrans: '//trim(structure))
 
  select case(structure)
    case('fcc')
      interactiontypes = fcc_interactionsliptrans
      nslipmax         = fcc_nslipsystem
      ntransmax        = fcc_ntranssystem
    case default
      call io_error(137,ext_msg='lattice_interaction_SlipByTrans: '//trim(structure))
  end select
 
  interactionmatrix = buildinteraction(nslip,ntrans,nslipmax,ntransmax,interactionvalues,interactiontypes)
 
 end function lattice_interaction_slipbytrans
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function lattice_interaction_twinbyslip(Ntwin,Nslip,interactionValues,structure) result(interactionMatrix)
 
  integer,         dimension(:),                   intent(in) :: ntwin, &                           !< number of active twin systems per family
                                                                 nslip
  real(preal),     dimension(:),                   intent(in) :: interactionvalues
  character(len=*),                                intent(in) :: structure
  real(preal),     dimension(sum(Ntwin),sum(Nslip))           :: interactionmatrix
 
  integer, dimension(:),   allocatable :: ntwinmax, &
                                          nslipmax
  integer, dimension(:,:), allocatable :: interactiontypes
 
  integer, dimension(FCC_NSLIP,FCC_NTWIN), parameter :: &
    fcc_interactiontwinslip = 1
 
  integer, dimension(BCC_NSLIP,BCC_NTWIN), parameter :: &
    bcc_interactiontwinslip = 1
 
  integer, dimension(HEX_NSLIP,HEX_NTWIN), parameter :: &
    hex_interactiontwinslip = reshape( [&
       1, 1, 1,   5, 5, 5,   9, 9, 9,  13,13,13,13,13,13,  17,17,17,17,17,17,17,17,17,17,17,17,  21,21,21,21,21,21, & ! ----> slip (acting)
       1, 1, 1,   5, 5, 5,   9, 9, 9,  13,13,13,13,13,13,  17,17,17,17,17,17,17,17,17,17,17,17,  21,21,21,21,21,21, & ! |
       1, 1, 1,   5, 5, 5,   9, 9, 9,  13,13,13,13,13,13,  17,17,17,17,17,17,17,17,17,17,17,17,  21,21,21,21,21,21, & ! |
       1, 1, 1,   5, 5, 5,   9, 9, 9,  13,13,13,13,13,13,  17,17,17,17,17,17,17,17,17,17,17,17,  21,21,21,21,21,21, & ! v
       1, 1, 1,   5, 5, 5,   9, 9, 9,  13,13,13,13,13,13,  17,17,17,17,17,17,17,17,17,17,17,17,  21,21,21,21,21,21, & ! twin (reacting)
       1, 1, 1,   5, 5, 5,   9, 9, 9,  13,13,13,13,13,13,  17,17,17,17,17,17,17,17,17,17,17,17,  21,21,21,21,21,21, &
     !
       2, 2, 2,   6, 6, 6,  10,10,10,  14,14,14,14,14,14,  18,18,18,18,18,18,18,18,18,18,18,18,  22,22,22,22,22,22, &
       2, 2, 2,   6, 6, 6,  10,10,10,  14,14,14,14,14,14,  18,18,18,18,18,18,18,18,18,18,18,18,  22,22,22,22,22,22, &
       2, 2, 2,   6, 6, 6,  10,10,10,  14,14,14,14,14,14,  18,18,18,18,18,18,18,18,18,18,18,18,  22,22,22,22,22,22, &
       2, 2, 2,   6, 6, 6,  10,10,10,  14,14,14,14,14,14,  18,18,18,18,18,18,18,18,18,18,18,18,  22,22,22,22,22,22, &
       2, 2, 2,   6, 6, 6,  10,10,10,  14,14,14,14,14,14,  18,18,18,18,18,18,18,18,18,18,18,18,  22,22,22,22,22,22, &
       2, 2, 2,   6, 6, 6,  10,10,10,  14,14,14,14,14,14,  18,18,18,18,18,18,18,18,18,18,18,18,  22,22,22,22,22,22, &
     !
       3, 3, 3,   7, 7, 7,  11,11,11,  15,15,15,15,15,15,  19,19,19,19,19,19,19,19,19,19,19,19,  23,23,23,23,23,23, &
       3, 3, 3,   7, 7, 7,  11,11,11,  15,15,15,15,15,15,  19,19,19,19,19,19,19,19,19,19,19,19,  23,23,23,23,23,23, &
       3, 3, 3,   7, 7, 7,  11,11,11,  15,15,15,15,15,15,  19,19,19,19,19,19,19,19,19,19,19,19,  23,23,23,23,23,23, &
       3, 3, 3,   7, 7, 7,  11,11,11,  15,15,15,15,15,15,  19,19,19,19,19,19,19,19,19,19,19,19,  23,23,23,23,23,23, &
       3, 3, 3,   7, 7, 7,  11,11,11,  15,15,15,15,15,15,  19,19,19,19,19,19,19,19,19,19,19,19,  23,23,23,23,23,23, &
       3, 3, 3,   7, 7, 7,  11,11,11,  15,15,15,15,15,15,  19,19,19,19,19,19,19,19,19,19,19,19,  23,23,23,23,23,23, &
     !
       4, 4, 4,   8, 8, 8,  12,12,12,  16,16,16,16,16,16,  20,20,20,20,20,20,20,20,20,20,20,20,  24,24,24,24,24,24, &
       4, 4, 4,   8, 8, 8,  12,12,12,  16,16,16,16,16,16,  20,20,20,20,20,20,20,20,20,20,20,20,  24,24,24,24,24,24, &
       4, 4, 4,   8, 8, 8,  12,12,12,  16,16,16,16,16,16,  20,20,20,20,20,20,20,20,20,20,20,20,  24,24,24,24,24,24, &
       4, 4, 4,   8, 8, 8,  12,12,12,  16,16,16,16,16,16,  20,20,20,20,20,20,20,20,20,20,20,20,  24,24,24,24,24,24, &
       4, 4, 4,   8, 8, 8,  12,12,12,  16,16,16,16,16,16,  20,20,20,20,20,20,20,20,20,20,20,20,  24,24,24,24,24,24, &
       4, 4, 4,   8, 8, 8,  12,12,12,  16,16,16,16,16,16,  20,20,20,20,20,20,20,20,20,20,20,20,  24,24,24,24,24,24  &
      ],shape(hex_interactiontwinslip))                                                             
 
  if (len_trim(structure) /= 3) &
    call io_error(137,ext_msg='lattice_interaction_TwinBySlip: '//trim(structure))
 
  select case(structure)
    case('fcc')
      interactiontypes = fcc_interactiontwinslip
      ntwinmax         = fcc_ntwinsystem
      nslipmax         = fcc_nslipsystem
    case('bcc')
      interactiontypes = bcc_interactiontwinslip
      ntwinmax         = bcc_ntwinsystem
      nslipmax         = bcc_nslipsystem
    case('hex')
      interactiontypes = hex_interactiontwinslip
      ntwinmax         = hex_ntwinsystem
      nslipmax         = hex_nslipsystem
    case default
      call io_error(137,ext_msg='lattice_interaction_TwinBySlip: '//trim(structure))
  end select
 
  interactionmatrix = buildinteraction(ntwin,nslip,ntwinmax,nslipmax,interactionvalues,interactiontypes)
 
end function lattice_interaction_twinbyslip
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function lattice_schmidmatrix_slip(Nslip,structure,cOverA) result(SchmidMatrix)
 
  integer,         dimension(:),            intent(in) :: nslip
  character(len=*),                         intent(in) :: structure
  real(preal),                              intent(in) :: covera
  real(preal),     dimension(3,3,sum(Nslip))           :: schmidmatrix
 
  real(preal), dimension(3,3,sum(Nslip))             :: coordinatesystem
  real(preal), dimension(:,:),           allocatable :: slipsystems
  integer,     dimension(:),             allocatable :: nslipmax
  integer                                            :: i
 
  if (len_trim(structure) /= 3) &
    call io_error(137,ext_msg='lattice_SchmidMatrix_slip: '//trim(structure))
 
  select case(structure)
    case('fcc')
      nslipmax    = fcc_nslipsystem
      slipsystems = fcc_systemslip
    case('bcc')
      nslipmax    = bcc_nslipsystem
      slipsystems = bcc_systemslip
    case('hex')
      nslipmax    = hex_nslipsystem
      slipsystems = hex_systemslip
    case('bct')
      nslipmax    = bct_nslipsystem
      slipsystems = bct_systemslip
    case default
      call io_error(137,ext_msg='lattice_SchmidMatrix_slip: '//trim(structure))
  end select
 
  if (any(nslipmax(1:size(nslip)) - nslip < 0)) &
    call io_error(145,ext_msg='Nslip '//trim(structure))
  if (any(nslip < 0)) &
    call io_error(144,ext_msg='Nslip '//trim(structure))
 
  coordinatesystem = buildcoordinatesystem(nslip,nslipmax,slipsystems,structure,covera)
 
  do i = 1, sum(nslip)
    schmidmatrix(1:3,1:3,i) = math_outer(coordinatesystem(1:3,1,i),coordinatesystem(1:3,2,i))
    if (abs(math_trace33(schmidmatrix(1:3,1:3,i))) > tol_math_check) &
      call io_error(0,i,ext_msg = 'dilatational Schmid matrix for slip')
  enddo
 
end function lattice_schmidmatrix_slip
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function lattice_schmidmatrix_twin(Ntwin,structure,cOverA) result(SchmidMatrix)
 
  integer,         dimension(:),            intent(in) :: ntwin
  character(len=*),                         intent(in) :: structure
  real(preal),                              intent(in) :: covera
  real(preal),     dimension(3,3,sum(Ntwin))           :: schmidmatrix
 
  real(preal), dimension(3,3,sum(Ntwin))             :: coordinatesystem
  real(preal), dimension(:,:),           allocatable :: twinsystems
  integer,     dimension(:),             allocatable :: ntwinmax
  integer                                            :: i
 
  if (len_trim(structure) /= 3) &
    call io_error(137,ext_msg='lattice_SchmidMatrix_twin: '//trim(structure))
 
  select case(structure)
    case('fcc')
      ntwinmax    = fcc_ntwinsystem
      twinsystems = fcc_systemtwin
    case('bcc')
      ntwinmax    = bcc_ntwinsystem
      twinsystems = bcc_systemtwin
    case('hex')
      ntwinmax    = hex_ntwinsystem
      twinsystems = hex_systemtwin
    case default
      call io_error(137,ext_msg='lattice_SchmidMatrix_twin: '//trim(structure))
  end select
 
  if (any(ntwinmax(1:size(ntwin)) - ntwin < 0)) &
    call io_error(145,ext_msg='Ntwin '//trim(structure))
  if (any(ntwin < 0)) &
    call io_error(144,ext_msg='Ntwin '//trim(structure))
 
  coordinatesystem = buildcoordinatesystem(ntwin,ntwinmax,twinsystems,structure,covera)
 
  do i = 1, sum(ntwin)
    schmidmatrix(1:3,1:3,i) = math_outer(coordinatesystem(1:3,1,i),coordinatesystem(1:3,2,i))
    if (abs(math_trace33(schmidmatrix(1:3,1:3,i))) > tol_math_check) &
      call io_error(0,i,ext_msg = 'dilatational Schmid matrix for twin')
  enddo
 
end function lattice_schmidmatrix_twin
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function lattice_schmidmatrix_trans(Ntrans,structure_target,cOverA,a_bcc,a_fcc) result(SchmidMatrix)
 
  integer,         dimension(:),             intent(in) :: ntrans
  character(len=*),                          intent(in) :: structure_target
  real(preal),                               intent(in) :: covera
  real(preal),     dimension(3,3,sum(Ntrans))           :: schmidmatrix
 
  real(preal), dimension(3,3,sum(Ntrans)) :: devnull
  real(preal)                             :: a_bcc, a_fcc
 
  if (len_trim(structure_target) /= 3) &
    call io_error(137,ext_msg='lattice_SchmidMatrix_trans: '//trim(structure_target))
  if (structure_target(1:3) /= 'bcc' .and. structure_target(1:3) /= 'hex') &
    call io_error(137,ext_msg='lattice_SchmidMatrix_trans: '//trim(structure_target))
 
  if (structure_target(1:3) == 'hex' .and. (covera < 1.0_preal .or. covera > 2.0_preal)) &
    call io_error(131,ext_msg='lattice_SchmidMatrix_trans: '//trim(structure_target))
 
  if (structure_target(1:3) == 'bcc' .and. (a_bcc <= 0.0_preal .or. a_fcc <= 0.0_preal)) &
    call io_error(134,ext_msg='lattice_SchmidMatrix_trans: '//trim(structure_target))
 
  call buildtransformationsystem(devnull,schmidmatrix,ntrans,covera,a_fcc,a_bcc)
 
end function lattice_schmidmatrix_trans
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function lattice_schmidmatrix_cleavage(Ncleavage,structure,cOverA) result(SchmidMatrix)
 
  integer,         dimension(:),                  intent(in) :: ncleavage
  character(len=*),                               intent(in) :: structure
  real(preal),                                    intent(in) :: covera
  real(preal),     dimension(3,3,3,sum(Ncleavage))           :: schmidmatrix
 
  real(preal), dimension(3,3,sum(Ncleavage))             :: coordinatesystem
  real(preal), dimension(:,:),               allocatable :: cleavagesystems
  integer,     dimension(:),                 allocatable :: ncleavagemax
  integer                                                :: i
 
  if (len_trim(structure) /= 3) &
    call io_error(137,ext_msg='lattice_SchmidMatrix_cleavage: '//trim(structure))
 
  select case(structure)
    case('ort')
      ncleavagemax    = ort_ncleavagesystem
      cleavagesystems = ort_systemcleavage
    case('fcc')
      ncleavagemax    = fcc_ncleavagesystem
      cleavagesystems = fcc_systemcleavage
    case('bcc')
      ncleavagemax    = bcc_ncleavagesystem
      cleavagesystems = bcc_systemcleavage
    case default
      call io_error(137,ext_msg='lattice_SchmidMatrix_cleavage: '//trim(structure))
  end select
 
  if (any(ncleavagemax(1:size(ncleavage)) - ncleavage < 0)) &
    call io_error(145,ext_msg='Ncleavage '//trim(structure))
  if (any(ncleavage < 0)) &
    call io_error(144,ext_msg='Ncleavage '//trim(structure))
 
  coordinatesystem = buildcoordinatesystem(ncleavage,ncleavagemax,cleavagesystems,structure,covera)
 
  do i = 1, sum(ncleavage)
    schmidmatrix(1:3,1:3,1,i) = math_outer(coordinatesystem(1:3,1,i),coordinatesystem(1:3,2,i))
    schmidmatrix(1:3,1:3,2,i) = math_outer(coordinatesystem(1:3,3,i),coordinatesystem(1:3,2,i))
    schmidmatrix(1:3,1:3,3,i) = math_outer(coordinatesystem(1:3,2,i),coordinatesystem(1:3,2,i))
  enddo
 
end function lattice_schmidmatrix_cleavage
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function lattice_slip_direction(Nslip,structure,cOverA) result(d)
 
  integer,         dimension(:),           intent(in) :: nslip
  character(len=*),                        intent(in) :: structure
  real(preal),                             intent(in) :: covera
  real(preal),     dimension(3,sum(Nslip))            :: d
 
  real(preal), dimension(3,3,sum(Nslip)) :: coordinatesystem
 
  coordinatesystem = coordinatesystem_slip(nslip,structure,covera)
  d = coordinatesystem(1:3,1,1:sum(nslip))
 
end function lattice_slip_direction
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function lattice_slip_normal(Nslip,structure,cOverA) result(n)
 
  integer,         dimension(:),           intent(in) :: nslip
  character(len=*),                        intent(in) :: structure
  real(preal),                             intent(in) :: covera
  real(preal),     dimension(3,sum(Nslip))            :: n
 
  real(preal), dimension(3,3,sum(Nslip)) :: coordinatesystem
 
  coordinatesystem = coordinatesystem_slip(nslip,structure,covera)
  n = coordinatesystem(1:3,2,1:sum(nslip))
 
end function lattice_slip_normal
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function lattice_slip_transverse(Nslip,structure,cOverA) result(t)
 
  integer,         dimension(:),           intent(in) :: nslip
  character(len=*),                        intent(in) :: structure
  real(preal),                             intent(in) :: covera
  real(preal),     dimension(3,sum(Nslip))            :: t
 
  real(preal), dimension(3,3,sum(Nslip)) :: coordinatesystem
 
  coordinatesystem = coordinatesystem_slip(nslip,structure,covera)
  t = coordinatesystem(1:3,3,1:sum(nslip))
 
end function lattice_slip_transverse
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function lattice_labels_slip(Nslip,structure) result(labels)
 
  integer,         dimension(:),  intent(in)  :: nslip
  character(len=*),               intent(in)  :: structure
 
  character(len=:), dimension(:),   allocatable :: labels
 
  real(preal),      dimension(:,:), allocatable :: slipsystems
  integer,          dimension(:),   allocatable :: nslipmax
 
  if (len_trim(structure) /= 3) &
    call io_error(137,ext_msg='lattice_labels_slip: '//trim(structure))
 
  select case(structure)
    case('fcc')
      nslipmax    = fcc_nslipsystem
      slipsystems = fcc_systemslip
    case('bcc')
      nslipmax    = bcc_nslipsystem
      slipsystems = bcc_systemslip
    case('hex')
      nslipmax    = hex_nslipsystem
      slipsystems = hex_systemslip
    case('bct')
      nslipmax    = bct_nslipsystem
      slipsystems = bct_systemslip
    case default
      call io_error(137,ext_msg='lattice_labels_slip: '//trim(structure))
  end select
 
  if (any(nslipmax(1:size(nslip)) - nslip < 0)) &
    call io_error(145,ext_msg='Nslip '//trim(structure))
  if (any(nslip < 0)) &
    call io_error(144,ext_msg='Nslip '//trim(structure))
 
  labels = getlabels(nslip,nslipmax,slipsystems)
 
end function lattice_labels_slip
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function lattice_applylatticesymmetry33(T,structure) result(T_sym)
 
  real(preal), dimension(3,3) :: t_sym
 
  real(preal), dimension(3,3), intent(in) :: t
  character(len=*),            intent(in) :: structure
 
  integer :: k
 
  t_sym = 0.0_preal
 
  if (len_trim(structure) /= 3) &
    call io_error(137,ext_msg='lattice_applyLatticeSymmetry33: '//trim(structure))
 
  select case(structure)
    case('iso','fcc','bcc')
      do k=1,3
        t_sym(k,k) = t(1,1)
      enddo
    case('hex')
      t_sym(1,1) = t(1,1)
      t_sym(2,2) = t(1,1)
      t_sym(3,3) = t(3,3)
    case('ort','bct')
      t_sym(1,1) = t(1,1)
      t_sym(2,2) = t(2,2)
      t_sym(3,3) = t(3,3)
    case default
      call io_error(137,ext_msg='lattice_applyLatticeSymmetry33: '//trim(structure))
   end select
 
end function lattice_applylatticesymmetry33
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function applylatticesymmetryc66(C66,structure) result(C66_sym)
 
  real(preal), dimension(6,6) :: c66_sym
 
  real(preal), dimension(6,6), intent(in) :: c66
  character(len=*),            intent(in) :: structure
 
  integer :: j,k
 
  c66_sym = 0.0_preal
 
  if (len_trim(structure) /= 3) &
    call io_error(137,ext_msg='applyLatticeSymmetryC66: '//trim(structure))
 
  select case(structure)
    case ('iso')
      do k=1,3
        do j=1,3
          c66_sym(k,j) = c66(1,2)
        enddo
        c66_sym(k,k)     = c66(1,1)
        c66_sym(k+3,k+3) = 0.5_preal*(c66(1,1)-c66(1,2))
      enddo
    case ('fcc','bcc')
      do k=1,3
        do j=1,3
          c66_sym(k,j) = c66(1,2)
        enddo
        c66_sym(k,k)     = c66(1,1)
        c66_sym(k+3,k+3) = c66(4,4)
      enddo
    case ('hex')
      c66_sym(1,1) = c66(1,1)
      c66_sym(2,2) = c66(1,1)
      c66_sym(3,3) = c66(3,3)
      c66_sym(1,2) = c66(1,2)
      c66_sym(2,1) = c66(1,2)
      c66_sym(1,3) = c66(1,3)
      c66_sym(3,1) = c66(1,3)
      c66_sym(2,3) = c66(1,3)
      c66_sym(3,2) = c66(1,3)
      c66_sym(4,4) = c66(4,4)
      c66_sym(5,5) = c66(4,4)
      c66_sym(6,6) = 0.5_preal*(c66(1,1)-c66(1,2))
    case ('ort')
      c66_sym(1,1) = c66(1,1)
      c66_sym(2,2) = c66(2,2)
      c66_sym(3,3) = c66(3,3)
      c66_sym(1,2) = c66(1,2)
      c66_sym(2,1) = c66(1,2)
      c66_sym(1,3) = c66(1,3)
      c66_sym(3,1) = c66(1,3)
      c66_sym(2,3) = c66(2,3)
      c66_sym(3,2) = c66(2,3)
      c66_sym(4,4) = c66(4,4)
      c66_sym(5,5) = c66(5,5)
      c66_sym(6,6) = c66(6,6)
    case ('bct')
      c66_sym(1,1) = c66(1,1)
      c66_sym(2,2) = c66(1,1)
      c66_sym(3,3) = c66(3,3)
      c66_sym(1,2) = c66(1,2)
      c66_sym(2,1) = c66(1,2)
      c66_sym(1,3) = c66(1,3)
      c66_sym(3,1) = c66(1,3)
      c66_sym(2,3) = c66(1,3)
      c66_sym(3,2) = c66(1,3)
      c66_sym(4,4) = c66(4,4)
      c66_sym(5,5) = c66(4,4)
      c66_sym(6,6) = c66(6,6)
    case default
      call io_error(137,ext_msg='applyLatticeSymmetryC66: '//trim(structure))
   end select
 
end function applylatticesymmetryc66
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function lattice_labels_twin(Ntwin,structure) result(labels)
 
  integer,         dimension(:),  intent(in)  :: ntwin
  character(len=*),               intent(in)  :: structure
 
  character(len=:), dimension(:),   allocatable :: labels
 
  real(preal),      dimension(:,:), allocatable :: twinsystems
  integer,          dimension(:),   allocatable :: ntwinmax
 
  if (len_trim(structure) /= 3) &
    call io_error(137,ext_msg='lattice_labels_twin: '//trim(structure))
 
  select case(structure)
    case('fcc')
      ntwinmax    = fcc_ntwinsystem
      twinsystems = fcc_systemtwin
    case('bcc')
      ntwinmax    = bcc_ntwinsystem
      twinsystems = bcc_systemtwin
    case('hex')
      ntwinmax    = hex_ntwinsystem
      twinsystems = hex_systemtwin
    case default
      call io_error(137,ext_msg='lattice_labels_twin: '//trim(structure))
  end select
 
  if (any(ntwinmax(1:size(ntwin)) - ntwin < 0)) &
    call io_error(145,ext_msg='Ntwin '//trim(structure))
  if (any(ntwin < 0)) &
    call io_error(144,ext_msg='Ntwin '//trim(structure))
 
  labels = getlabels(ntwin,ntwinmax,twinsystems)
 
end function lattice_labels_twin
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function slipprojection_transverse(Nslip,structure,cOverA) result(projection)
 
  integer,         dimension(:),                   intent(in) :: nslip
  character(len=*),                                intent(in) :: structure
  real(preal),                                     intent(in) :: covera
  real(preal),     dimension(sum(Nslip),sum(Nslip))           :: projection
 
  real(preal), dimension(3,sum(Nslip)) :: n, t
  integer                              :: i, j
 
  n = lattice_slip_normal(nslip,structure,covera)
  t = lattice_slip_transverse(nslip,structure,covera)
 
  do i=1, sum(nslip); do j=1, sum(nslip)
    projection(i,j) = abs(math_inner(n(:,i),t(:,j)))
  enddo; enddo
 
end function slipprojection_transverse
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function slipprojection_direction(Nslip,structure,cOverA) result(projection)
 
  integer,         dimension(:),                   intent(in) :: nslip
  character(len=*),                                intent(in) :: structure
  real(preal),                                     intent(in) :: covera
  real(preal),     dimension(sum(Nslip),sum(Nslip))           :: projection
 
  real(preal), dimension(3,sum(Nslip)) :: n, d
  integer                              :: i, j
 
  n = lattice_slip_normal(nslip,structure,covera)
  d = lattice_slip_direction(nslip,structure,covera)
 
  do i=1, sum(nslip); do j=1, sum(nslip)
    projection(i,j) = abs(math_inner(n(:,i),d(:,j)))
  enddo; enddo
 
end function slipprojection_direction
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function coordinatesystem_slip(Nslip,structure,cOverA) result(coordinateSystem)
 
  integer,          dimension(:),            intent(in) :: nslip
  character(len=*),                          intent(in) :: structure
  real(preal),                               intent(in) :: covera
  real(preal),     dimension(3,3,sum(Nslip))            :: coordinatesystem
 
  real(preal), dimension(:,:), allocatable :: slipsystems
  integer,     dimension(:),   allocatable :: nslipmax
 
  if (len_trim(structure) /= 3) &
    call io_error(137,ext_msg='coordinateSystem_slip: '//trim(structure))
 
  select case(structure)
    case('fcc')
      nslipmax    = fcc_nslipsystem
      slipsystems = fcc_systemslip
    case('bcc')
      nslipmax    = bcc_nslipsystem
      slipsystems = bcc_systemslip
    case('hex')
      nslipmax    = hex_nslipsystem
      slipsystems = hex_systemslip
    case('bct')
      nslipmax    = bct_nslipsystem
      slipsystems = bct_systemslip
    case default
      call io_error(137,ext_msg='coordinateSystem_slip: '//trim(structure))
  end select
 
  if (any(nslipmax(1:size(nslip)) - nslip < 0)) &
    call io_error(145,ext_msg='Nslip '//trim(structure))
  if (any(nslip < 0)) &
    call io_error(144,ext_msg='Nslip '//trim(structure))
 
  coordinatesystem = buildcoordinatesystem(nslip,nslipmax,slipsystems,structure,covera)
 
end function coordinatesystem_slip
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function buildinteraction(reacting_used,acting_used,reacting_max,acting_max,values,matrix)
 
  integer,     dimension(:),                                 intent(in) :: &
    reacting_used, &                                                                                !< # of reacting systems per family as specified in material.config
    acting_used, &                                                                                  !< # of   acting systems per family as specified in material.config
    reacting_max, &                                                                                 !< max # of reacting systems per family for given lattice
    acting_max
  real(preal), dimension(:),                                 intent(in) :: values
  integer,     dimension(:,:),                               intent(in) :: matrix
  real(preal), dimension(sum(reacting_used),sum(acting_used))           :: buildinteraction
 
  integer :: &
    acting_family_index,     acting_family,   acting_system, &
    reacting_family_index, reacting_family, reacting_system, &
    i,j,k,l
 
  do acting_family = 1,size(acting_used,1)
    acting_family_index = sum(acting_used(1:acting_family-1))
    do acting_system = 1,acting_used(acting_family)
 
      do reacting_family = 1,size(reacting_used,1)
        reacting_family_index = sum(reacting_used(1:reacting_family-1))
        do reacting_system = 1,reacting_used(reacting_family)
 
          i = sum(  acting_max(1:  acting_family-1)) +   acting_system
          j = sum(reacting_max(1:reacting_family-1)) + reacting_system
 
          k =   acting_family_index +   acting_system
          l = reacting_family_index + reacting_system
 
          if (matrix(i,j) > size(values)) call io_error(138,ext_msg='buildInteraction')
 
          buildinteraction(l,k) = values(matrix(i,j))
 
      enddo; enddo
  enddo; enddo
 
end function buildinteraction
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function buildcoordinatesystem(active,potential,system,structure,cOverA)
 
  integer, dimension(:), intent(in) :: &
    active, &                                                                                       !< # of active systems per family
    potential
  real(preal), dimension(:,:), intent(in) :: &
    system
  character(len=*),            intent(in) :: &
    structure
  real(preal),                 intent(in) :: &
    covera
  real(preal), dimension(3,3,sum(active)) :: &
    buildcoordinatesystem
 
  real(preal), dimension(3) :: &
    direction, normal
  integer :: &
    a, &                                                                                            !< index of active system
    p, &                                                                                            !< index in potential system matrix
    f, &                                                                                            !< index of my family
    s
 
  if (len_trim(structure) /= 3) &
    call io_error(137,ext_msg='buildCoordinateSystem: '//trim(structure))
  if (trim(structure) == 'bct' .and. covera > 2.0_preal) &
    call io_error(131,ext_msg='buildCoordinateSystem:'//trim(structure))
  if (trim(structure) == 'hex' .and. (covera < 1.0_preal .or. covera > 2.0_preal)) &
    call io_error(131,ext_msg='buildCoordinateSystem:'//trim(structure))
 
  a = 0
  activefamilies: do f = 1,size(active,1)
    activesystems: do s = 1,active(f)
      a = a + 1
      p = sum(potential(1:f-1))+s
 
      select case(trim(structure))
 
        case ('fcc','bcc','iso','ort','bct')
          direction = system(1:3,p)
          normal    = system(4:6,p)
 
        case ('hex')
          direction = [ system(1,p)*1.5_preal, &
                       (system(1,p)+2.0_preal*system(2,p))*sqrt(0.75_preal), &
                        system(4,p)*covera ]                                                        ! direction [uvtw]->[3u/2 (u+2v)*sqrt(3)/2 w*(p/a)])
          normal    = [ system(5,p), &
                       (system(5,p)+2.0_preal*system(6,p))/sqrt(3.0_preal), &
                        system(8,p)/covera ]                                                        ! plane (hkil)->(h (h+2k)/sqrt(3) l/(p/a))
 
        case default
          call io_error(137,ext_msg='buildCoordinateSystem: '//trim(structure))
 
      end select
 
      buildcoordinatesystem(1:3,1,a) = direction/norm2(direction)
      buildcoordinatesystem(1:3,2,a) = normal   /norm2(normal)
      buildcoordinatesystem(1:3,3,a) = math_cross(direction/norm2(direction),&
                                                  normal   /norm2(normal))
 
    enddo activesystems
  enddo activefamilies
 
end function buildcoordinatesystem
 
 
!--------------------------------------------------------------------------------------------------
! Needed to calculate Schmid matrix and rotated stiffness matrices.
! @details: set c/a   = 0.0 for fcc -> bcc transformation
!           set a_Xcc = 0.0 for fcc -> hex transformation
!--------------------------------------------------------------------------------------------------
subroutine buildtransformationsystem(Q,S,Ntrans,cOverA,a_fcc,a_bcc)
 
  integer, dimension(:), intent(in) :: &
    Ntrans
  real(pReal),  dimension(3,3,sum(Ntrans)), intent(out) :: &
    Q, &                                                                                            !< Total rotation: Q = R*B
    S
  real(pReal),                 intent(in) :: &
    cOverA, &                                                                                       !< c/a for target hex structure
    a_bcc, &                                                                                        !< lattice parameter a for target bcc structure
    a_fcc
 
  type(rotation) :: &
    R, &                                                                                            !< Pitsch rotation
    B
  real(pReal), dimension(3,3) :: &
    U, &                                                                                            !< Bain deformation
    ss, sd
  real(pReal), dimension(3) :: &
    x, y, z
  integer :: &
    i
  real(pReal), dimension(3+3,FCC_NTRANS), parameter :: &
    FCCTOHEX_SYSTEMTRANS = reshape(real( [&
      -2, 1, 1,     1, 1, 1, &
       1,-2, 1,     1, 1, 1, &
       1, 1,-2,     1, 1, 1, &
       2,-1, 1,    -1,-1, 1, &
      -1, 2, 1,    -1,-1, 1, &
      -1,-1,-2,    -1,-1, 1, &
      -2,-1,-1,     1,-1,-1, &
       1, 2,-1,     1,-1,-1, &
       1,-1, 2,     1,-1,-1, &
       2, 1,-1,    -1, 1,-1, &
      -1,-2,-1,    -1, 1,-1, &
      -1, 1, 2,    -1, 1,-1  &
      ],preal),shape(fcctohex_systemtrans))
       real(pReal), dimension(4,fcc_Ntrans), parameter :: &
    FCCTOBCC_SYSTEMTRANS = reshape([&
      0.0, 1.0, 0.0,     10.26, &                                                                   ! Pitsch OR (Ma & Hartmaier 2014, Table 3)
      0.0,-1.0, 0.0,     10.26, &
      0.0, 0.0, 1.0,     10.26, &
      0.0, 0.0,-1.0,     10.26, &
      1.0, 0.0, 0.0,     10.26, &
     -1.0, 0.0, 0.0,     10.26, &
      0.0, 0.0, 1.0,     10.26, &
      0.0, 0.0,-1.0,     10.26, &
      1.0, 0.0, 0.0,     10.26, &
     -1.0, 0.0, 0.0,     10.26, &
      0.0, 1.0, 0.0,     10.26, &
      0.0,-1.0, 0.0,     10.26  &
      ],shape(fcctobcc_systemtrans))
 
  integer, dimension(9,fcc_Ntrans), parameter :: &
    FCCTOBCC_BAINVARIANT = reshape( [&
      1, 0, 0, 0, 1, 0, 0, 0, 1, &                                                                  ! Pitsch OR (Ma & Hartmaier 2014, Table 3)
      1, 0, 0, 0, 1, 0, 0, 0, 1, &
      1, 0, 0, 0, 1, 0, 0, 0, 1, &
      1, 0, 0, 0, 1, 0, 0, 0, 1, &
      0, 1, 0, 1, 0, 0, 0, 0, 1, &
      0, 1, 0, 1, 0, 0, 0, 0, 1, &
      0, 1, 0, 1, 0, 0, 0, 0, 1, &
      0, 1, 0, 1, 0, 0, 0, 0, 1, &
      0, 0, 1, 1, 0, 0, 0, 1, 0, &
      0, 0, 1, 1, 0, 0, 0, 1, 0, &
      0, 0, 1, 1, 0, 0, 0, 1, 0, &
      0, 0, 1, 1, 0, 0, 0, 1, 0  &
      ],shape(fcctobcc_bainvariant))
 
  real(pReal), dimension(4,fcc_Ntrans), parameter :: &
    FCCTOBCC_BAINROT = reshape([&
      1.0, 0.0, 0.0,     45.0, &                                                                    ! Rotate fcc austensite to bain variant
      1.0, 0.0, 0.0,     45.0, &
      1.0, 0.0, 0.0,     45.0, &
      1.0, 0.0, 0.0,     45.0, &
      0.0, 1.0, 0.0,     45.0, &
      0.0, 1.0, 0.0,     45.0, &
      0.0, 1.0, 0.0,     45.0, &
      0.0, 1.0, 0.0,     45.0, &
      0.0, 0.0, 1.0,     45.0, &
      0.0, 0.0, 1.0,     45.0, &
      0.0, 0.0, 1.0,     45.0, &
      0.0, 0.0, 1.0,     45.0  &
      ],shape(fcctobcc_bainrot))
 
  if (a_bcc > 0.0_preal .and. a_fcc > 0.0_preal .and. deq0(covera)) then                            ! fcc -> bcc transformation
    do i = 1,sum(ntrans)
      call r%fromAxisAngle(fcctobcc_systemtrans(:,i),degrees=.true.,p=1)
      call b%fromAxisAngle(fcctobcc_bainrot(:,i),    degrees=.true.,p=1)
      x = real(fcctobcc_bainvariant(1:3,i),preal)
      y = real(fcctobcc_bainvariant(4:6,i),preal)
      z = real(fcctobcc_bainvariant(7:9,i),preal)
 
      u = (a_bcc/a_fcc)*math_outer(x,x) &
        + (a_bcc/a_fcc)*math_outer(y,y) * sqrt(2.0_preal) &
        + (a_bcc/a_fcc)*math_outer(z,z) * sqrt(2.0_preal)
      q(1:3,1:3,i) = matmul(r%asMatrix(),b%asMatrix())
      s(1:3,1:3,i) = matmul(r%asMatrix(),u) - math_i3
    enddo
  elseif (covera > 0.0_preal .and. deq0(a_bcc)) then                                                ! fcc -> hex transformation
    ss      = math_i3
    sd      = math_i3
    ss(1,3) = sqrt(2.0_preal)/4.0_preal
    sd(3,3) = covera/sqrt(8.0_preal/3.0_preal)
 
    do i = 1,sum(ntrans)
      x = fcctohex_systemtrans(1:3,i)/norm2(fcctohex_systemtrans(1:3,i))
      z = fcctohex_systemtrans(4:6,i)/norm2(fcctohex_systemtrans(4:6,i))
      y = -math_cross(x,z)
      q(1:3,1,i) = x
      q(1:3,2,i) = y
      q(1:3,3,i) = z
      s(1:3,1:3,i) = matmul(q(1:3,1:3,i), matmul(matmul(sd,ss), transpose(q(1:3,1:3,i)))) - math_i3 ! ToDo: This is of interest for the Schmid matrix only
    enddo
  else
    call io_error(132,ext_msg='buildTransformationSystem')
  endif
 
end subroutine buildtransformationsystem
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function getlabels(active,potential,system) result(labels)
 
  integer,          dimension(:),   intent(in) :: &
    active, &                                                                                       !< # of active systems per family
    potential
  real(preal),      dimension(:,:), intent(in) :: &
    system
 
  character(len=:), dimension(:), allocatable :: labels
  character(len=:),               allocatable :: label
 
  integer :: i,j
  integer :: &
    a, &                                                                                            !< index of active system
    p, &                                                                                            !< index in potential system matrix
    f, &                                                                                            !< index of my family
    s
 
  i = 2*size(system,1) + (size(system,1) - 2) + 4                                                   ! 2 letters per index + spaces + brackets
  allocate(character(len=i) :: labels(sum(active)), label)
 
  a = 0
  activefamilies: do f = 1,size(active,1)
    activesystems: do s = 1,active(f)
      a = a + 1
      p = sum(potential(1:f-1))+s
 
      i = 1
      label(i:i) = '['
      direction: do j = 1, size(system,1)/2
        write(label(i+1:i+2),'(I2.1)') int(system(j,p))
        label(i+3:i+3) = ' '
        i = i + 3
      enddo direction
      label(i:i) = ']'
 
      i = i +1
      label(i:i) = '('
      normal: do j = size(system,1)/2+1, size(system,1)
        write(label(i+1:i+2),'(I2.1)') int(system(j,p))
        label(i+3:i+3) = ' '
        i = i + 3
      enddo normal
      label(i:i) = ')'
 
      labels(s) = label
 
    enddo activesystems
  enddo activefamilies
 
end function getlabels
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function equivalent_nu(C,assumption) result(nu)
 
  real(preal), dimension(6,6), intent(in) :: c
  character(len=*),            intent(in) :: assumption
 
  real(preal)                 :: k, mu, nu
  logical                     :: error
  real(preal), dimension(6,6) :: s
 
  if    (io_lc(assumption) == 'voigt') then
    k = (c(1,1)+c(2,2)+c(3,3) +2.0_preal*(c(1,2)+c(2,3)+c(1,3))) &
      / 9.0_preal
  elseif(io_lc(assumption) == 'reuss') then
    call math_invert(s,error,c)
    if(error) call io_error(0)
    k = 1.0_preal &
      / (s(1,1)+s(2,2)+s(3,3) +2.0_preal*(s(1,2)+s(2,3)+s(1,3)))
  else
    call io_error(0)
    k = 0.0_preal
  endif
 
  mu = equivalent_mu(c,assumption)
  nu = (1.5_preal*k -mu)/(3.0_preal*k+mu)
 
end function equivalent_nu
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function equivalent_mu(C,assumption) result(mu)
 
  real(preal), dimension(6,6), intent(in) :: c
  character(len=*),            intent(in) :: assumption
 
  real(preal)                 :: mu
  logical                     :: error
  real(preal), dimension(6,6) :: s
 
  if    (io_lc(assumption) == 'voigt') then
    mu = (1.0_preal*(c(1,1)+c(2,2)+c(3,3)) -1.0_preal*(c(1,2)+c(2,3)+c(1,3)) +3.0_preal*(c(4,4)+c(5,5)+c(6,6))) &
       / 15.0_preal
  elseif(io_lc(assumption) == 'reuss') then
    call math_invert(s,error,c)
    if(error) call io_error(0)
    mu = 15.0_preal &
       / (4.0_preal*(s(1,1)+s(2,2)+s(3,3)) -4.0_preal*(s(1,2)+s(2,3)+s(1,3)) +3.0_preal*(s(4,4)+s(5,5)+s(6,6)))
  else
    call io_error(0)
    mu = 0.0_preal
  endif
 
end function equivalent_mu
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine unittest
 
  real(pReal), dimension(:,:,:), allocatable :: CoSy
  real(pReal), dimension(:,:),   allocatable :: system
 
  real(pReal), dimension(6,6) :: C
  real(pReal), dimension(2)   :: r
  real(pReal)                 :: lambda
 
  call random_number(r)
 
  system = reshape([1.0_preal+r(1),0.0_preal,0.0_preal, 0.0_preal,1.0_preal+r(2),0.0_preal],[6,1])
  cosy   = buildcoordinatesystem([1],[1],system,'fcc',0.0_preal)
 
  if(any(dneq(cosy(1:3,1:3,1),math_i3))) &
    call io_error(0)
 
  call random_number(c)
  c(1,1) = c(1,1) + 1.0_preal
  c = applylatticesymmetryc66(c,'iso')
  if(dneq(c(6,6),equivalent_mu(c,'voigt'),1.0e-12_preal)) &
    call io_error(0,ext_msg='equivalent_mu/voigt')
  if(dneq(c(6,6),equivalent_mu(c,'voigt'),1.0e-12_preal)) &
    call io_error(0,ext_msg='equivalent_mu/reuss')
  lambda = c(1,2)
  if(dneq(lambda*0.5_preal/(lambda+equivalent_mu(c,'voigt')),equivalent_nu(c,'voigt'),1.0e-12_preal)) &
    call io_error(0,ext_msg='equivalent_nu/voigt')
  if(dneq(lambda*0.5_preal/(lambda+equivalent_mu(c,'reuss')),equivalent_nu(c,'reuss'),1.0e-12_preal)) &
    call io_error(0,ext_msg='equivalent_nu/reuss')
 
end subroutine unittest
 
end module lattice
# 27 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/source_thermal_dissipation.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module source_thermal_dissipation
  use prec
  use debug
  use discretization
  use material
  use config
 
  implicit none
  private
 
  integer,           dimension(:),   allocatable :: &
    source_thermal_dissipation_offset, &                                                            !< which source is my current thermal dissipation mechanism?
    source_thermal_dissipation_instance
 
  type :: tparameters                                                                               
    real(preal) :: &
      kappa
  end type tparameters
 
  type(tparameters), dimension(:),   allocatable :: param
 
 
  public :: &
    source_thermal_dissipation_init, &
    source_thermal_dissipation_getrateanditstangent
 
contains
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine source_thermal_dissipation_init
 
  integer :: ninstance,sourceoffset,nipcmyphase,p
 
  write(6,'(/,a)') ' <<<+-  source_'//source_thermal_dissipation_label//' init  -+>>>'; flush(6)
 
  ninstance = count(phase_source == source_thermal_dissipation_id)
  if (iand(debug_level(debug_constitutive),debug_levelbasic) /= 0) &
    write(6,'(a16,1x,i5,/)') '# instances:',ninstance
 
  allocate(source_thermal_dissipation_offset(size(config_phase)), source=0)
  allocate(source_thermal_dissipation_instance(size(config_phase)), source=0)
  allocate(param(ninstance))
 
  do p = 1, size(config_phase)
    source_thermal_dissipation_instance(p) = count(phase_source(:,1:p) == source_thermal_dissipation_id)
    do sourceoffset = 1, phase_nsources(p)
      if (phase_source(sourceoffset,p) == source_thermal_dissipation_id) then
        source_thermal_dissipation_offset(p) = sourceoffset
        exit
      endif
    enddo
 
    if (all(phase_source(:,p) /= source_thermal_dissipation_id)) cycle
    associate(prm => param(source_thermal_dissipation_instance(p)), &
              config => config_phase(p))
 
    prm%kappa = config%getFloat('dissipation_coldworkcoeff')
 
    nipcmyphase = count(material_phaseat==p) * discretization_nip
    call material_allocatesourcestate(p,sourceoffset,nipcmyphase,0,0,0)
 
    end associate
  enddo
 
end subroutine source_thermal_dissipation_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine source_thermal_dissipation_getrateanditstangent(TDot, dTDot_dT, Tstar, Lp, phase)
 
  integer, intent(in) :: &
    phase
  real(preal),  intent(in), dimension(3,3) :: &
    tstar
  real(preal),  intent(in), dimension(3,3) :: &
    lp
 
  real(preal),  intent(out) :: &
    tdot, &
    dtdot_dt
 
  associate(prm => param(source_thermal_dissipation_instance(phase)))
  tdot = prm%kappa*sum(abs(tstar*lp))
  dtdot_dt = 0.0_preal
  end associate
 
end subroutine source_thermal_dissipation_getrateanditstangent
 
end module source_thermal_dissipation
# 28 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/source_thermal_externalheat.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module source_thermal_externalheat
  use prec
  use debug
  use discretization
  use material
  use config
 
  implicit none
  private
 
  integer,           dimension(:),   allocatable :: &
    source_thermal_externalheat_offset, &                                                           !< which source is my current thermal dissipation mechanism?
    source_thermal_externalheat_instance
 
  type :: tparameters                                                                              
    real(preal), dimension(:), allocatable :: &
      time, &
      heat_rate
    integer :: &
     nintervals
  end type tparameters
 
  type(tparameters), dimension(:), allocatable  :: param
 
 
  public :: &
    source_thermal_externalheat_init, &
    source_thermal_externalheat_dotstate, &
    source_thermal_externalheat_getrateanditstangent
 
contains
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine source_thermal_externalheat_init
 
  integer :: ninstance,sourceoffset,nipcmyphase,p
 
  write(6,'(/,a)') ' <<<+-  source_'//source_thermal_externalheat_label//' init  -+>>>'; flush(6)
 
  ninstance = count(phase_source == source_thermal_externalheat_id)
  if (iand(debug_level(debug_constitutive),debug_levelbasic) /= 0) &
    write(6,'(a16,1x,i5,/)') '# instances:',ninstance
 
  allocate(source_thermal_externalheat_offset(size(config_phase)), source=0)
  allocate(source_thermal_externalheat_instance(size(config_phase)), source=0)
  allocate(param(ninstance))
 
  do p = 1, size(config_phase)
    source_thermal_externalheat_instance(p) = count(phase_source(:,1:p) == source_thermal_externalheat_id)
    do sourceoffset = 1, phase_nsources(p)
      if (phase_source(sourceoffset,p) == source_thermal_externalheat_id) then
        source_thermal_externalheat_offset(p) = sourceoffset
        exit
      endif
    enddo
 
    if (all(phase_source(:,p) /= source_thermal_externalheat_id)) cycle
    associate(prm => param(source_thermal_externalheat_instance(p)), &
              config => config_phase(p))
 
    prm%time       = config%getFloats('externalheat_time')
    prm%nIntervals = size(prm%time) - 1
 
    prm%heat_rate = config%getFloats('externalheat_rate',requiredsize = size(prm%time))
 
    nipcmyphase = count(material_phaseat==p) * discretization_nip
    call material_allocatesourcestate(p,sourceoffset,nipcmyphase,1,1,0)
 
    end associate
  enddo
 
end subroutine source_thermal_externalheat_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine source_thermal_externalheat_dotstate(phase, of)
 
  integer, intent(in) :: &
    phase, &
    of
 
  integer :: &
    sourceoffset
 
  sourceoffset = source_thermal_externalheat_offset(phase)
 
  sourcestate(phase)%p(sourceoffset)%dotState(1,of) = 1.0_preal                                     ! state is current time
 
end subroutine source_thermal_externalheat_dotstate
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine source_thermal_externalheat_getrateanditstangent(TDot, dTDot_dT, phase, of)
 
  integer, intent(in) :: &
    phase, &
    of
  real(preal),  intent(out) :: &
    tdot, &
    dtdot_dt
 
  integer :: &
    sourceoffset, interval
  real(preal) :: &
    frac_time
 
  sourceoffset = source_thermal_externalheat_offset(phase)
 
  associate(prm => param(source_thermal_externalheat_instance(phase)))
  do interval = 1, prm%nIntervals                                                                   ! scan through all rate segments
    frac_time = (sourcestate(phase)%p(sourceoffset)%state(1,of) - prm%time(interval)) &
              / (prm%time(interval+1) - prm%time(interval))                                         ! fractional time within segment
    if (     (frac_time <  0.0_preal .and. interval == 1) &
        .or. (frac_time >= 1.0_preal .and. interval == prm%nIntervals) &
        .or. (frac_time >= 0.0_preal .and. frac_time < 1.0_preal) ) &
      tdot = prm%heat_rate(interval  ) * (1.0_preal - frac_time) + &
             prm%heat_rate(interval+1) * frac_time                                                  ! interpolate heat rate between segment boundaries...
                                                                                                    ! ...or extrapolate if outside of bounds
  enddo
  dtdot_dt = 0.0
  end associate
 
end subroutine source_thermal_externalheat_getrateanditstangent
 
end module source_thermal_externalheat
# 29 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/source_damage_isoBrittle.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module source_damage_isobrittle
  use prec
  use debug
  use io
  use math
  use discretization
  use material
  use config
  use results
 
  implicit none
  private
 
  integer,                       dimension(:),           allocatable :: &
    source_damage_isobrittle_offset, &
    source_damage_isobrittle_instance
 
  type, private :: tparameters                                                                      
    real(preal) :: &
      critstrainenergy, &
      n
    character(len=pStringLen), allocatable, dimension(:) :: &
      output
  end type tparameters
 
  type(tparameters), dimension(:), allocatable :: param
 
 
  public :: &
    source_damage_isobrittle_init, &
    source_damage_isobrittle_deltastate, &
    source_damage_isobrittle_getrateanditstangent, &
    source_damage_isobrittle_results
 
contains
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine source_damage_isobrittle_init
 
  integer :: ninstance,sourceoffset,nipcmyphase,p
  character(len=pStringLen) :: extmsg = ''
 
  write(6,'(/,a)') ' <<<+-  source_'//source_damage_isobrittle_label//' init  -+>>>'; flush(6)
 
  ninstance = count(phase_source == source_damage_isobrittle_id)
  if (iand(debug_level(debug_constitutive),debug_levelbasic) /= 0) &
    write(6,'(a16,1x,i5,/)') '# instances:',ninstance
 
  allocate(source_damage_isobrittle_offset(size(config_phase)), source=0)
  allocate(source_damage_isobrittle_instance(size(config_phase)), source=0)
  allocate(param(ninstance))
 
  do p = 1, size(config_phase)
    source_damage_isobrittle_instance(p) = count(phase_source(:,1:p) == source_damage_isobrittle_id)
    do sourceoffset = 1, phase_nsources(p)
      if (phase_source(sourceoffset,p) == source_damage_isobrittle_id) then
        source_damage_isobrittle_offset(p) = sourceoffset
        exit
      endif
    enddo
 
    if (all(phase_source(:,p) /= source_damage_isobrittle_id)) cycle
    associate(prm => param(source_damage_isobrittle_instance(p)), &
              config => config_phase(p))
 
    prm%output = config%getStrings('(output)',defaultval=emptystringarray)
 
    prm%N                = config%getFloat('isobrittle_n')
    prm%critStrainEnergy = config%getFloat('isobrittle_criticalstrainenergy')
 
    ! sanity checks
    if (prm%N                <= 0.0_preal) extmsg = trim(extmsg)//' isobrittle_n'
    if (prm%critStrainEnergy <= 0.0_preal) extmsg = trim(extmsg)//' isobrittle_criticalstrainenergy'
 
    nipcmyphase = count(material_phaseat==p) * discretization_nip
    call material_allocatesourcestate(p,sourceoffset,nipcmyphase,1,1,1)
    sourcestate(p)%p(sourceoffset)%atol = config%getFloat('isobrittle_atol',defaultval=1.0e-3_preal)
    if(any(sourcestate(p)%p(sourceoffset)%atol < 0.0_preal)) extmsg = trim(extmsg)//' isobrittle_atol'
 
    end associate
 
!--------------------------------------------------------------------------------------------------
!  exit if any parameter is out of range
    if (extmsg /= '') call io_error(211,ext_msg=trim(extmsg)//'('//source_damage_isobrittle_label//')')
 
enddo
 
end subroutine source_damage_isobrittle_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine source_damage_isobrittle_deltastate(C, Fe, ipc, ip, el)
 
  integer, intent(in) :: &
    ipc, &                                                                                          !< component-ID of integration point
    ip, &                                                                                           !< integration point
    el
  real(preal),  intent(in), dimension(3,3) :: &
    fe
  real(preal),  intent(in), dimension(6,6) :: &
    c
 
  integer :: &
    phase, &
    constituent, &
    sourceoffset
  real(preal), dimension(6) :: &
    strain
  real(preal) :: &
    strainenergy
 
  phase = material_phaseat(ipc,el)                                                                  
  constituent = material_phasememberat(ipc,ip,el)                                                   
  sourceoffset = source_damage_isobrittle_offset(phase)
 
  strain = 0.5_preal*math_sym33to6(matmul(transpose(fe),fe)-math_i3)
 
  associate(prm => param(source_damage_isobrittle_instance(phase)))
  strainenergy = 2.0_preal*sum(strain*matmul(c,strain))/prm%critStrainEnergy
  ! ToDo: check strainenergy = 2.0_pReal*dot_product(strain,matmul(C,strain))/param(instance)%critStrainEnergy
 
  if (strainenergy > sourcestate(phase)%p(sourceoffset)%subState0(1,constituent)) then
    sourcestate(phase)%p(sourceoffset)%deltaState(1,constituent) = &
      strainenergy - sourcestate(phase)%p(sourceoffset)%state(1,constituent)
  else
    sourcestate(phase)%p(sourceoffset)%deltaState(1,constituent) = &
      sourcestate(phase)%p(sourceoffset)%subState0(1,constituent) - &
      sourcestate(phase)%p(sourceoffset)%state(1,constituent)
  endif
  end associate
 
end subroutine source_damage_isobrittle_deltastate
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine source_damage_isobrittle_getrateanditstangent(localphiDot, dLocalphiDot_dPhi, phi, phase, constituent)
 
  integer, intent(in) :: &
    phase, &
    constituent
  real(preal),  intent(in) :: &
    phi
  real(preal),  intent(out) :: &
    localphidot, &
    dlocalphidot_dphi
 
  integer :: &
    sourceoffset
 
  sourceoffset = source_damage_isobrittle_offset(phase)
 
  associate(prm => param(source_damage_isobrittle_instance(phase)))
  localphidot = (1.0_preal - phi)**(prm%n - 1.0_preal) &
              - phi*sourcestate(phase)%p(sourceoffset)%state(1,constituent)
  dlocalphidot_dphi = - (prm%n - 1.0_preal)* (1.0_preal - phi)**max(0.0_preal,prm%n - 2.0_preal) &
                      - sourcestate(phase)%p(sourceoffset)%state(1,constituent)
  end associate
 
end subroutine source_damage_isobrittle_getrateanditstangent
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine source_damage_isobrittle_results(phase,group)
 
  integer,          intent(in) :: phase
  character(len=*), intent(in) :: group
 
  integer :: o
 
  associate(prm => param(source_damage_isobrittle_instance(phase)), &
            stt => sourcestate(phase)%p(source_damage_isobrittle_offset(phase))%state)
  outputsloop: do o = 1,size(prm%output)
    select case(trim(prm%output(o)))
      case ('isobrittle_drivingforce')
        call results_writedataset(group,stt,'tbd','driving force','tbd')
    end select
  enddo outputsloop
  end associate
 
end subroutine source_damage_isobrittle_results
 
end module source_damage_isobrittle
# 30 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/source_damage_isoDuctile.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module source_damage_isoductile
  use prec
  use debug
  use io
  use discretization
  use material
  use config
  use results
 
  implicit none
  private
 
  integer,                       dimension(:),           allocatable :: &
    source_damage_isoductile_offset, &                                                              !< which source is my current damage mechanism?
    source_damage_isoductile_instance
 
  type, private :: tparameters                                                                      
    real(preal) :: &
      critplasticstrain, &
      n
    character(len=pStringLen), allocatable, dimension(:) :: &
      output
  end type tparameters
 
  type(tparameters), dimension(:), allocatable, private :: param
 
 
  public :: &
    source_damage_isoductile_init, &
    source_damage_isoductile_dotstate, &
    source_damage_isoductile_getrateanditstangent, &
    source_damage_isoductile_results
 
contains
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine source_damage_isoductile_init
 
  integer :: ninstance,sourceoffset,nipcmyphase,p
  character(len=pStringLen) :: extmsg = ''
 
  write(6,'(/,a)') ' <<<+-  source_'//source_damage_isoductile_label//' init  -+>>>'; flush(6)
 
  ninstance = count(phase_source == source_damage_isoductile_id)
  if (iand(debug_level(debug_constitutive),debug_levelbasic) /= 0) &
    write(6,'(a16,1x,i5,/)') '# instances:',ninstance
 
  allocate(source_damage_isoductile_offset(size(config_phase)), source=0)
  allocate(source_damage_isoductile_instance(size(config_phase)), source=0)
  allocate(param(ninstance))
 
  do p = 1, size(config_phase)
    source_damage_isoductile_instance(p) = count(phase_source(:,1:p) == source_damage_isoductile_id)
    do sourceoffset = 1, phase_nsources(p)
      if (phase_source(sourceoffset,p) == source_damage_isoductile_id) then
        source_damage_isoductile_offset(p) = sourceoffset
        exit
      endif
    enddo
 
    if (all(phase_source(:,p) /= source_damage_isoductile_id)) cycle
    associate(prm => param(source_damage_isoductile_instance(p)), &
              config => config_phase(p))
 
    prm%output = config%getStrings('(output)',defaultval=emptystringarray)
 
    prm%N                 = config%getFloat('isoductile_ratesensitivity')
    prm%critPlasticStrain = config%getFloat('isoductile_criticalplasticstrain')
 
    ! sanity checks
    if (prm%N                 <= 0.0_preal) extmsg = trim(extmsg)//' isoductile_ratesensitivity'
    if (prm%critPlasticStrain <= 0.0_preal) extmsg = trim(extmsg)//' isoductile_criticalplasticstrain'
 
    nipcmyphase=count(material_phaseat==p) * discretization_nip
    call material_allocatesourcestate(p,sourceoffset,nipcmyphase,1,1,0)
    sourcestate(p)%p(sourceoffset)%atol = config%getFloat('isoductile_atol',defaultval=1.0e-3_preal)
    if(any(sourcestate(p)%p(sourceoffset)%atol < 0.0_preal)) extmsg = trim(extmsg)//' isoductile_atol'
 
    end associate
 
!--------------------------------------------------------------------------------------------------
!  exit if any parameter is out of range
    if (extmsg /= '') call io_error(211,ext_msg=trim(extmsg)//'('//source_damage_isoductile_label//')')
 
enddo
 
end subroutine source_damage_isoductile_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine source_damage_isoductile_dotstate(ipc, ip, el)
 
  integer, intent(in) :: &
    ipc, &                                                                                          !< component-ID of integration point
    ip, &                                                                                           !< integration point
    el
 
  integer :: &
    phase, &
    constituent, &
    sourceoffset, &
    damageoffset, &
    homog
 
  phase = material_phaseat(ipc,el)
  constituent = material_phasememberat(ipc,ip,el)
  sourceoffset = source_damage_isoductile_offset(phase)
  homog = material_homogenizationat(el)
  damageoffset = damagemapping(homog)%p(ip,el)
 
  associate(prm => param(source_damage_isoductile_instance(phase)))
  sourcestate(phase)%p(sourceoffset)%dotState(1,constituent) = &
    sum(plasticstate(phase)%slipRate(:,constituent))/(damage(homog)%p(damageoffset)**prm%N)/prm%critPlasticStrain
  end associate
 
end subroutine source_damage_isoductile_dotstate
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine source_damage_isoductile_getrateanditstangent(localphiDot, dLocalphiDot_dPhi, phi, phase, constituent)
 
  integer, intent(in) :: &
    phase, &
    constituent
  real(preal),  intent(in) :: &
    phi
  real(preal),  intent(out) :: &
    localphidot, &
    dlocalphidot_dphi
 
  integer :: &
    sourceoffset
 
  sourceoffset = source_damage_isoductile_offset(phase)
 
  dlocalphidot_dphi = -sourcestate(phase)%p(sourceoffset)%state(1,constituent)
 
  localphidot = 1.0_preal &
              + dlocalphidot_dphi*phi
 
end subroutine source_damage_isoductile_getrateanditstangent
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine source_damage_isoductile_results(phase,group)
 
  integer,          intent(in) :: phase
  character(len=*), intent(in) :: group
 
  integer :: o
 
  associate(prm => param(source_damage_isoductile_instance(phase)), &
            stt => sourcestate(phase)%p(source_damage_isoductile_offset(phase))%state)
  outputsloop: do o = 1,size(prm%output)
    select case(trim(prm%output(o)))
      case ('isoductile_drivingforce')
        call results_writedataset(group,stt,'tbd','driving force','tbd')
    end select
  enddo outputsloop
  end associate
 
end subroutine source_damage_isoductile_results
 
end module source_damage_isoductile
# 31 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/source_damage_anisoBrittle.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module source_damage_anisobrittle
  use prec
  use debug
  use io
  use math
  use discretization
  use material
  use config
  use lattice
  use results
 
  implicit none
  private
 
  integer,                       dimension(:),           allocatable :: &
    source_damage_anisobrittle_offset, &                                                            !< which source is my current source mechanism?
    source_damage_anisobrittle_instance
 
  type :: tparameters                                                                               
    real(preal) :: &
      sdot_0, &
      n
    real(preal), dimension(:), allocatable :: &
      critdisp, &
      critload
    real(preal), dimension(:,:,:,:), allocatable :: &
      cleavage_systems
    integer :: &
      sum_n_cl
    character(len=pStringLen), allocatable, dimension(:) :: &
      output
  end type tparameters
 
  type(tparameters), dimension(:), allocatable :: param
 
 
  public :: &
    source_damage_anisobrittle_init, &
    source_damage_anisobrittle_dotstate, &
    source_damage_anisobrittle_getrateanditstangent, &
    source_damage_anisobrittle_results
 
contains
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine source_damage_anisobrittle_init
 
  integer :: ninstance,sourceoffset,nipcmyphase,p
  integer, dimension(:), allocatable :: n_cl
  character(len=pStringLen) :: extmsg = ''
 
  write(6,'(/,a)') ' <<<+-  source_'//source_damage_anisobrittle_label//' init  -+>>>'; flush(6)
 
  ninstance = count(phase_source == source_damage_anisobrittle_id)
  if (iand(debug_level(debug_constitutive),debug_levelbasic) /= 0) &
    write(6,'(a16,1x,i5,/)') '# instances:',ninstance
 
  allocate(source_damage_anisobrittle_offset(size(config_phase)), source=0)
  allocate(source_damage_anisobrittle_instance(size(config_phase)), source=0)
  allocate(param(ninstance))
 
  do p = 1, size(config_phase)
    source_damage_anisobrittle_instance(p) = count(phase_source(:,1:p) == source_damage_anisobrittle_id)
    do sourceoffset = 1, phase_nsources(p)
      if (phase_source(sourceoffset,p) == source_damage_anisobrittle_id) then
        source_damage_anisobrittle_offset(p) = sourceoffset
        exit
      endif
    enddo
 
    if (all(phase_source(:,p) /= source_damage_anisobrittle_id)) cycle
    associate(prm => param(source_damage_anisobrittle_instance(p)), &
              config => config_phase(p))
 
    prm%output = config%getStrings('(output)',defaultval=emptystringarray)
 
    n_cl = config%getInts('ncleavage',defaultval=emptyintarray)
    prm%sum_N_cl = sum(abs(n_cl))
 
    prm%n         = config%getFloat('anisobrittle_ratesensitivity')
    prm%sdot_0    = config%getFloat('anisobrittle_sdot0')
 
    prm%critDisp  = config%getFloats('anisobrittle_criticaldisplacement',requiredsize=size(n_cl))
    prm%critLoad  = config%getFloats('anisobrittle_criticalload',        requiredsize=size(n_cl))
 
    prm%cleavage_systems = lattice_schmidmatrix_cleavage(n_cl,config%getString('lattice_structure'),&
                                                         config%getFloat('c/a',defaultval=0.0_preal))
 
    ! expand: family => system
    prm%critDisp = math_expand(prm%critDisp,n_cl)
    prm%critLoad = math_expand(prm%critLoad,n_cl)
 
    ! sanity checks
    if (prm%n            <= 0.0_preal)  extmsg = trim(extmsg)//' anisobrittle_n'
    if (prm%sdot_0       <= 0.0_preal)  extmsg = trim(extmsg)//' anisobrittle_sdot0'
    if (any(prm%critLoad <  0.0_preal)) extmsg = trim(extmsg)//' anisobrittle_critLoad'
    if (any(prm%critDisp <  0.0_preal)) extmsg = trim(extmsg)//' anisobrittle_critDisp'
 
    nipcmyphase = count(material_phaseat==p) * discretization_nip
    call material_allocatesourcestate(p,sourceoffset,nipcmyphase,1,1,0)
    sourcestate(p)%p(sourceoffset)%atol = config%getFloat('anisobrittle_atol',defaultval=1.0e-3_preal)
    if(any(sourcestate(p)%p(sourceoffset)%atol < 0.0_preal)) extmsg = trim(extmsg)//' anisobrittle_atol'
 
    end associate
 
!--------------------------------------------------------------------------------------------------
!  exit if any parameter is out of range
    if (extmsg /= '') call io_error(211,ext_msg=trim(extmsg)//'('//source_damage_anisobrittle_label//')')
 
enddo
 
end subroutine source_damage_anisobrittle_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine source_damage_anisobrittle_dotstate(S, ipc, ip, el)
 
  integer, intent(in) :: &
    ipc, &                                                                                          !< component-ID of integration point
    ip, &                                                                                           !< integration point
    el
  real(preal),  intent(in), dimension(3,3) :: &
    s
 
  integer :: &
    phase, &
    constituent, &
    sourceoffset, &
    damageoffset, &
    homog, &
    i
  real(preal) :: &
    traction_d, traction_t, traction_n, traction_crit
 
  phase = material_phaseat(ipc,el)
  constituent = material_phasememberat(ipc,ip,el)
  sourceoffset = source_damage_anisobrittle_offset(phase)
  homog = material_homogenizationat(el)
  damageoffset = damagemapping(homog)%p(ip,el)
 
  associate(prm => param(source_damage_anisobrittle_instance(phase)))
  sourcestate(phase)%p(sourceoffset)%dotState(1,constituent) = 0.0_preal
  do i = 1, prm%sum_N_cl
    traction_d    = math_tensordot(s,prm%cleavage_systems(1:3,1:3,1,i))
    traction_t    = math_tensordot(s,prm%cleavage_systems(1:3,1:3,2,i))
    traction_n    = math_tensordot(s,prm%cleavage_systems(1:3,1:3,3,i))
 
    traction_crit = prm%critLoad(i)*damage(homog)%p(damageoffset)**2.0_preal
 
    sourcestate(phase)%p(sourceoffset)%dotState(1,constituent) &
    = sourcestate(phase)%p(sourceoffset)%dotState(1,constituent) &
    + prm%sdot_0 / prm%critDisp(i) &
      * ((max(0.0_preal, abs(traction_d) - traction_crit)/traction_crit)**prm%n + &
         (max(0.0_preal, abs(traction_t) - traction_crit)/traction_crit)**prm%n + &
         (max(0.0_preal, abs(traction_n) - traction_crit)/traction_crit)**prm%n)
  enddo
  end associate
 
end subroutine source_damage_anisobrittle_dotstate
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine source_damage_anisobrittle_getrateanditstangent(localphiDot, dLocalphiDot_dPhi, phi, phase, constituent)
 
  integer, intent(in) :: &
    phase, &
    constituent
  real(preal),  intent(in) :: &
    phi
  real(preal),  intent(out) :: &
    localphidot, &
    dlocalphidot_dphi
 
  integer :: &
    sourceoffset
 
  sourceoffset = source_damage_anisobrittle_offset(phase)
 
  dlocalphidot_dphi = -sourcestate(phase)%p(sourceoffset)%state(1,constituent)
 
  localphidot = 1.0_preal &
              + dlocalphidot_dphi*phi
 
end subroutine source_damage_anisobrittle_getrateanditstangent
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine source_damage_anisobrittle_results(phase,group)
 
  integer,          intent(in) :: phase
  character(len=*), intent(in) :: group
 
  integer :: o
 
  associate(prm => param(source_damage_anisobrittle_instance(phase)), &
            stt => sourcestate(phase)%p(source_damage_anisobrittle_offset(phase))%state)
  outputsloop: do o = 1,size(prm%output)
    select case(trim(prm%output(o)))
      case ('anisobrittle_drivingforce')
        call results_writedataset(group,stt,'tbd','driving force','tbd')
    end select
  enddo outputsloop
  end associate
 
end subroutine source_damage_anisobrittle_results
 
end module source_damage_anisobrittle
# 32 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/source_damage_anisoDuctile.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module source_damage_anisoductile
  use prec
  use debug
  use io
  use math
  use discretization
  use material
  use config
  use results
 
  implicit none
  private
 
  integer,                       dimension(:),           allocatable :: &
    source_damage_anisoductile_offset, &                                                            !< which source is my current damage mechanism?
    source_damage_anisoductile_instance
 
  type, private :: tparameters                                                                       
    real(preal) :: &
      n
    real(preal), dimension(:), allocatable :: &
      critplasticstrain
    character(len=pStringLen), allocatable, dimension(:) :: &
      output
  end type tparameters
 
  type(tparameters), dimension(:), allocatable, private :: param
 
 
  public :: &
    source_damage_anisoductile_init, &
    source_damage_anisoductile_dotstate, &
    source_damage_anisoductile_getrateanditstangent, &
    source_damage_anisoductile_results
 
contains
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine source_damage_anisoductile_init
 
  integer :: ninstance,sourceoffset,nipcmyphase,p
  integer, dimension(:), allocatable :: n_sl
  character(len=pStringLen) :: extmsg = ''
 
  write(6,'(/,a)') ' <<<+-  source_'//source_damage_anisoductile_label//' init  -+>>>'; flush(6)
 
  ninstance = count(phase_source == source_damage_anisoductile_id)
  if (iand(debug_level(debug_constitutive),debug_levelbasic) /= 0) &
    write(6,'(a16,1x,i5,/)') '# instances:',ninstance
 
  allocate(source_damage_anisoductile_offset(size(config_phase)), source=0)
  allocate(source_damage_anisoductile_instance(size(config_phase)), source=0)
  allocate(param(ninstance))
 
  do p = 1, size(config_phase)
    source_damage_anisoductile_instance(p) = count(phase_source(:,1:p) == source_damage_anisoductile_id)
    do sourceoffset = 1, phase_nsources(p)
      if (phase_source(sourceoffset,p) == source_damage_anisoductile_id) then
        source_damage_anisoductile_offset(p) = sourceoffset
        exit
      endif
    enddo
 
    if (all(phase_source(:,p) /= source_damage_anisoductile_id)) cycle
    associate(prm => param(source_damage_anisoductile_instance(p)), &
              config => config_phase(p))
 
    prm%output = config%getStrings('(output)',defaultval=emptystringarray)
 
    n_sl = config%getInts('nslip',defaultval=emptyintarray)
    prm%n                 = config%getFloat('anisoductile_ratesensitivity')
    prm%critPlasticStrain = config%getFloats('anisoductile_criticalplasticstrain',requiredsize=size(n_sl))
 
    ! expand: family => system
    prm%critPlasticStrain = math_expand(prm%critPlasticStrain,n_sl)
 
    ! sanity checks
    if (prm%n                     <= 0.0_preal)  extmsg = trim(extmsg)//' anisoductile_ratesensitivity'
    if (any(prm%critPlasticStrain <  0.0_preal)) extmsg = trim(extmsg)//' anisoductile_criticalplasticstrain'
 
    nipcmyphase=count(material_phaseat==p) * discretization_nip
    call material_allocatesourcestate(p,sourceoffset,nipcmyphase,1,1,0)
    sourcestate(p)%p(sourceoffset)%atol = config%getFloat('anisoductile_atol',defaultval=1.0e-3_preal)
    if(any(sourcestate(p)%p(sourceoffset)%atol < 0.0_preal)) extmsg = trim(extmsg)//' anisoductile_atol'
 
    end associate
 
!--------------------------------------------------------------------------------------------------
!  exit if any parameter is out of range
    if (extmsg /= '') call io_error(211,ext_msg=trim(extmsg)//'('//source_damage_anisoductile_label//')')
 
enddo
 
end subroutine source_damage_anisoductile_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine source_damage_anisoductile_dotstate(ipc, ip, el)
 
  integer, intent(in) :: &
    ipc, &                                                                                          !< component-ID of integration point
    ip, &                                                                                           !< integration point
    el
 
  integer :: &
    phase, &
    constituent, &
    sourceoffset, &
    damageoffset, &
    homog
 
  phase = material_phaseat(ipc,el)
  constituent = material_phasememberat(ipc,ip,el)
  sourceoffset = source_damage_anisoductile_offset(phase)
  homog = material_homogenizationat(el)
  damageoffset = damagemapping(homog)%p(ip,el)
 
  associate(prm => param(source_damage_anisoductile_instance(phase)))
  sourcestate(phase)%p(sourceoffset)%dotState(1,constituent) &
    = sum(plasticstate(phase)%slipRate(:,constituent)/(damage(homog)%p(damageoffset)**prm%n)/prm%critPlasticStrain)
  end associate
 
end subroutine source_damage_anisoductile_dotstate
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine source_damage_anisoductile_getrateanditstangent(localphiDot, dLocalphiDot_dPhi, phi, phase, constituent)
 
  integer, intent(in) :: &
    phase, &
    constituent
  real(preal),  intent(in) :: &
    phi
  real(preal),  intent(out) :: &
    localphidot, &
    dlocalphidot_dphi
 
  integer :: &
    sourceoffset
 
  sourceoffset = source_damage_anisoductile_offset(phase)
 
  dlocalphidot_dphi = -sourcestate(phase)%p(sourceoffset)%state(1,constituent)
 
  localphidot = 1.0_preal &
              + dlocalphidot_dphi*phi
 
end subroutine source_damage_anisoductile_getrateanditstangent
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine source_damage_anisoductile_results(phase,group)
 
  integer,          intent(in) :: phase
  character(len=*), intent(in) :: group
 
  integer :: o
 
  associate(prm => param(source_damage_anisoductile_instance(phase)), &
            stt => sourcestate(phase)%p(source_damage_anisoductile_offset(phase))%state)
  outputsloop: do o = 1,size(prm%output)
    select case(trim(prm%output(o)))
      case ('anisoductile_drivingforce')
        call results_writedataset(group,stt,'tbd','driving force','tbd')
    end select
  enddo outputsloop
  end associate
 
end subroutine source_damage_anisoductile_results
 
end module source_damage_anisoductile
# 33 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/kinematics_cleavage_opening.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module kinematics_cleavage_opening
  use prec
  use io
  use config
  use debug
  use math
  use lattice
  use material
 
  implicit none
  private
 
  integer, dimension(:), allocatable :: kinematics_cleavage_opening_instance
 
  type :: tparameters                                                                               
    integer :: &
      sum_n_cl
    real(preal) :: &
      sdot0, &
      n
    real(preal),   dimension(:),   allocatable :: &
      critload
    real(preal), dimension(:,:,:,:), allocatable :: &
      cleavage_systems
  end type tparameters
 
  type(tparameters), dimension(:), allocatable :: param
 
  public :: &
    kinematics_cleavage_opening_init, &
    kinematics_cleavage_opening_lianditstangent
 
contains
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine kinematics_cleavage_opening_init
 
  integer :: ninstance,p
  integer, dimension(:), allocatable :: n_cl
  character(len=pStringLen) :: extmsg = ''
 
  write(6,'(/,a)') ' <<<+-  kinematics_'//kinematics_cleavage_opening_label//' init  -+>>>'; flush(6)
 
  ninstance = count(phase_kinematics == kinematics_cleavage_opening_id)
  if (iand(debug_level(debug_constitutive),debug_levelbasic) /= 0) &
    write(6,'(a16,1x,i5,/)') '# instances:',ninstance
 
  allocate(kinematics_cleavage_opening_instance(size(config_phase)), source=0)
  allocate(param(ninstance))
 
  do p = 1, size(config_phase)
    kinematics_cleavage_opening_instance(p) = count(phase_kinematics(:,1:p) == kinematics_cleavage_opening_id)
    if (all(phase_kinematics(:,p) /= kinematics_cleavage_opening_id)) cycle
 
    associate(prm => param(kinematics_cleavage_opening_instance(p)), &
              config => config_phase(p))
 
    n_cl = config%getInts('ncleavage')
    prm%sum_N_cl = sum(abs(n_cl))
 
    prm%n         = config%getFloat('anisobrittle_ratesensitivity')
    prm%sdot0     = config%getFloat('anisobrittle_sdot0')
 
    prm%critLoad  = config%getFloats('anisobrittle_criticalload',requiredsize=size(n_cl))
 
    prm%cleavage_systems  = lattice_schmidmatrix_cleavage(n_cl,config%getString('lattice_structure'),&
                                                          config%getFloat('c/a',defaultval=0.0_preal))
 
    ! expand: family => system
    prm%critLoad = math_expand(prm%critLoad,n_cl)
 
    ! sanity checks
    if (prm%n            <= 0.0_preal)  extmsg = trim(extmsg)//' anisobrittle_n'
    if (prm%sdot0        <= 0.0_preal)  extmsg = trim(extmsg)//' anisobrittle_sdot0'
    if (any(prm%critLoad <  0.0_preal)) extmsg = trim(extmsg)//' anisobrittle_critLoad'
 
!--------------------------------------------------------------------------------------------------
!  exit if any parameter is out of range
    if (extmsg /= '') call io_error(211,ext_msg=trim(extmsg)//'('//kinematics_cleavage_opening_label//')')
 
    end associate
  enddo
 
end subroutine kinematics_cleavage_opening_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine kinematics_cleavage_opening_lianditstangent(Ld, dLd_dTstar, S, ipc, ip, el)
 
  integer, intent(in) :: &
    ipc, &                                                                                          !< grain number
    ip, &                                                                                           !< integration point number
    el
  real(preal),   intent(in),  dimension(3,3) :: &
    s
  real(preal),   intent(out), dimension(3,3) :: &
    ld
  real(preal),   intent(out), dimension(3,3,3,3) :: &
    dld_dtstar
 
  integer :: &
    homog, damageoffset, &
    i, k, l, m, n
  real(preal) :: &
    traction_d, traction_t, traction_n, traction_crit, &
    udotd, dudotd_dt, udott, dudott_dt, udotn, dudotn_dt
 
  homog = material_homogenizationat(el)
  damageoffset = damagemapping(homog)%p(ip,el)
 
  ld = 0.0_preal
  dld_dtstar = 0.0_preal
  associate(prm => param(kinematics_cleavage_opening_instance(material_phaseat(ipc,el))))
  do i = 1,prm%sum_N_cl
    traction_crit = prm%critLoad(i)* damage(homog)%p(damageoffset)**2.0_preal
 
    traction_d = math_tensordot(s,prm%cleavage_systems(1:3,1:3,1,i))
    if (abs(traction_d) > traction_crit + tol_math_check) then
      udotd = sign(1.0_preal,traction_d)* prm%sdot0 * ((abs(traction_d) - traction_crit)/traction_crit)**prm%n
      ld = ld + udotd*prm%cleavage_systems(1:3,1:3,1,i)
      dudotd_dt = sign(1.0_preal,traction_d)*udotd*prm%n / (abs(traction_d) - traction_crit)
      forall (k=1:3,l=1:3,m=1:3,n=1:3) &
        dld_dtstar(k,l,m,n) = dld_dtstar(k,l,m,n) &
                            + dudotd_dt*prm%cleavage_systems(k,l,1,i) * prm%cleavage_systems(m,n,1,i)
    endif
 
    traction_t = math_tensordot(s,prm%cleavage_systems(1:3,1:3,2,i))
    if (abs(traction_t) > traction_crit + tol_math_check) then
      udott = sign(1.0_preal,traction_t)* prm%sdot0 * ((abs(traction_t) - traction_crit)/traction_crit)**prm%n
      ld = ld + udott*prm%cleavage_systems(1:3,1:3,2,i)
      dudott_dt = sign(1.0_preal,traction_t)*udott*prm%n / (abs(traction_t) - traction_crit)
      forall (k=1:3,l=1:3,m=1:3,n=1:3) &
        dld_dtstar(k,l,m,n) = dld_dtstar(k,l,m,n) &
                            + dudott_dt*prm%cleavage_systems(k,l,2,i) * prm%cleavage_systems(m,n,2,i)
    endif
 
    traction_n = math_tensordot(s,prm%cleavage_systems(1:3,1:3,3,i))
    if (abs(traction_n) > traction_crit + tol_math_check) then
      udotn = sign(1.0_preal,traction_n)* prm%sdot0 * ((abs(traction_n) - traction_crit)/traction_crit)**prm%n
      ld = ld + udotn*prm%cleavage_systems(1:3,1:3,3,i)
      dudotn_dt = sign(1.0_preal,traction_n)*udotn*prm%n / (abs(traction_n) - traction_crit)
      forall (k=1:3,l=1:3,m=1:3,n=1:3) &
        dld_dtstar(k,l,m,n) = dld_dtstar(k,l,m,n) &
                            + dudotn_dt*prm%cleavage_systems(k,l,3,i) * prm%cleavage_systems(m,n,3,i)
    endif
  enddo
  end associate
 
end subroutine kinematics_cleavage_opening_lianditstangent
 
end module kinematics_cleavage_opening
# 34 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/kinematics_slipplane_opening.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module kinematics_slipplane_opening
  use prec
  use config
  use io
  use debug
  use math
  use lattice
  use material
 
  implicit none
  private
 
  integer, dimension(:), allocatable :: kinematics_slipplane_opening_instance
 
  type :: tparameters                                                                               
    integer :: &
      sum_n_sl
    real(preal) :: &
      sdot0, &
      n
    real(preal), dimension(:),   allocatable :: &
      critload
    real(preal), dimension(:,:,:), allocatable     :: &
      p_d, &
      p_t, &
      p_n
  end type tparameters
 
  type(tparameters), dimension(:), allocatable :: param
 
  public :: &
    kinematics_slipplane_opening_init, &
    kinematics_slipplane_opening_lianditstangent
 
contains
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine kinematics_slipplane_opening_init
 
  integer :: ninstance,p,i
  character(len=pStringLen) :: extmsg = ''
  integer,     dimension(:),   allocatable :: n_sl
  real(preal), dimension(:,:), allocatable :: d,n,t
 
  write(6,'(/,a)') ' <<<+-  kinematics_'//kinematics_slipplane_opening_label//' init  -+>>>'; flush(6)
 
  ninstance = count(phase_kinematics == kinematics_slipplane_opening_id)
  if (iand(debug_level(debug_constitutive),debug_levelbasic) /= 0) &
    write(6,'(a16,1x,i5,/)') '# instances:',ninstance
 
  allocate(kinematics_slipplane_opening_instance(size(config_phase)), source=0)
  allocate(param(ninstance))
 
  do p = 1, size(config_phase)
    kinematics_slipplane_opening_instance(p) = count(phase_kinematics(:,1:p) == kinematics_slipplane_opening_id)
    if (all(phase_kinematics(:,p) /= kinematics_slipplane_opening_id)) cycle
    associate(prm => param(kinematics_slipplane_opening_instance(p)), &
             config => config_phase(p))
 
    prm%sdot0    = config%getFloat('anisoductile_sdot0')
    prm%n        = config%getFloat('anisoductile_ratesensitivity')
    n_sl         = config%getInts('nslip')
    prm%sum_N_sl = sum(abs(n_sl))
 
    d = lattice_slip_direction(n_sl,config%getString('lattice_structure'),&
                                config%getFloat('c/a',defaultval=0.0_preal))
    t = lattice_slip_transverse(n_sl,config%getString('lattice_structure'),&
                                config%getFloat('c/a',defaultval=0.0_preal))
    n = lattice_slip_normal(n_sl,config%getString('lattice_structure'),&
                                config%getFloat('c/a',defaultval=0.0_preal))
    allocate(prm%P_d(3,3,size(d,2)),prm%P_t(3,3,size(t,2)),prm%P_n(3,3,size(n,2)))
 
    do i=1, size(n,2)
      prm%P_d(1:3,1:3,i) = math_outer(d(1:3,i), n(1:3,i))
      prm%P_t(1:3,1:3,i) = math_outer(t(1:3,i), n(1:3,i))
      prm%P_n(1:3,1:3,i) = math_outer(n(1:3,i), n(1:3,i))
    enddo
 
    prm%critLoad = config%getFloats('anisoductile_criticalload',requiredsize=size(n_sl))
 
    ! expand: family => system
    prm%critLoad = math_expand(prm%critLoad,n_sl)
 
    ! sanity checks
    if (prm%n            <= 0.0_preal)  extmsg = trim(extmsg)//' anisoDuctile_n'
    if (prm%sdot0        <= 0.0_preal)  extmsg = trim(extmsg)//' anisoDuctile_sdot0'
    if (any(prm%critLoad <  0.0_preal)) extmsg = trim(extmsg)//' anisoDuctile_critLoad'
 
!--------------------------------------------------------------------------------------------------
!  exit if any parameter is out of range
    if (extmsg /= '') call io_error(211,ext_msg=trim(extmsg)//'('//kinematics_slipplane_opening_label//')')
 
    end associate
  enddo
 
end subroutine kinematics_slipplane_opening_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine kinematics_slipplane_opening_lianditstangent(Ld, dLd_dTstar, S, ipc, ip, el)
 
  integer, intent(in) :: &
    ipc, &                                                                                          !< grain number
    ip, &                                                                                           !< integration point number
    el
  real(preal),   intent(in),  dimension(3,3) :: &
    s
  real(preal),   intent(out), dimension(3,3) :: &
    ld
  real(preal),   intent(out), dimension(3,3,3,3) :: &
    dld_dtstar
 
  integer :: &
    instance, phase, &
    homog, damageoffset, &
    i, k, l, m, n
  real(preal) :: &
    traction_d, traction_t, traction_n, traction_crit, &
    udotd, dudotd_dt, udott, dudott_dt, udotn, dudotn_dt
 
  phase = material_phaseat(ipc,el)
  instance = kinematics_slipplane_opening_instance(phase)
  homog = material_homogenizationat(el)
  damageoffset = damagemapping(homog)%p(ip,el)
 
  associate(prm => param(instance))
  ld = 0.0_preal
  dld_dtstar = 0.0_preal
  do i = 1, prm%sum_N_sl
 
    traction_d = math_tensordot(s,prm%P_d(1:3,1:3,i))
    traction_t = math_tensordot(s,prm%P_t(1:3,1:3,i))
    traction_n = math_tensordot(s,prm%P_n(1:3,1:3,i))
 
    traction_crit = prm%critLoad(i)* damage(homog)%p(damageoffset)                                  ! degrading critical load carrying capacity by damage
 
    udotd = sign(1.0_preal,traction_d)* prm%sdot0* (  abs(traction_d)/traction_crit &
                                                    - abs(traction_d)/prm%critLoad(i))**prm%n
    udott = sign(1.0_preal,traction_t)* prm%sdot0* (  abs(traction_t)/traction_crit &
                                                    - abs(traction_t)/prm%critLoad(i))**prm%n
    udotn = prm%sdot0* (  max(0.0_preal,traction_n)/traction_crit &
                        - max(0.0_preal,traction_n)/prm%critLoad(i))**prm%n
 
    if (dneq0(traction_d)) then
      dudotd_dt = udotd*prm%n/traction_d
    else
      dudotd_dt = 0.0_preal
    endif
    if (dneq0(traction_t)) then
      dudott_dt = udott*prm%n/traction_t
    else
      dudott_dt = 0.0_preal
    endif
    if (dneq0(traction_n)) then
      dudotn_dt = udotn*prm%n/traction_n
    else
      dudotn_dt = 0.0_preal
    endif
 
    forall (k=1:3,l=1:3,m=1:3,n=1:3) &
      dld_dtstar(k,l,m,n) = dld_dtstar(k,l,m,n) &
                          + dudotd_dt*prm%P_d(k,l,i)*prm%P_d(m,n,i) &
                          + dudott_dt*prm%P_t(k,l,i)*prm%P_t(m,n,i) &
                          + dudotn_dt*prm%P_n(k,l,i)*prm%P_n(m,n,i)
 
    ld = ld &
       + udotd*prm%P_d(1:3,1:3,i) &
       + udott*prm%P_t(1:3,1:3,i) &
       + udotn*prm%P_n(1:3,1:3,i)
  enddo
 
  end associate
 
end subroutine kinematics_slipplane_opening_lianditstangent
 
end module kinematics_slipplane_opening
# 35 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/kinematics_thermal_expansion.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module kinematics_thermal_expansion
  use prec
  use io
  use config
  use debug
  use math
  use lattice
  use material
 
  implicit none
  private
 
  integer, dimension(:), allocatable :: kinematics_thermal_expansion_instance
 
  type :: tparameters
    real(preal) :: &
      t_ref
    real(preal), dimension(3,3,3) :: &
      expansion = 0.0_preal
  end type tparameters
 
  type(tparameters), dimension(:), allocatable :: param
 
  public :: &
    kinematics_thermal_expansion_init, &
    kinematics_thermal_expansion_initialstrain, &
    kinematics_thermal_expansion_lianditstangent
 
contains
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine kinematics_thermal_expansion_init
 
  integer :: ninstance,p,i
  real(preal), dimension(:), allocatable :: temp
 
  write(6,'(/,a)') ' <<<+-  kinematics_'//kinematics_thermal_expansion_label//' init  -+>>>'; flush(6)
 
  ninstance = count(phase_kinematics == kinematics_thermal_expansion_id)
  if (iand(debug_level(debug_constitutive),debug_levelbasic) /= 0) &
    write(6,'(a16,1x,i5,/)') '# instances:',ninstance
 
  allocate(kinematics_thermal_expansion_instance(size(config_phase)), source=0)
  allocate(param(ninstance))
 
  do p = 1, size(config_phase)
    kinematics_thermal_expansion_instance(p) = count(phase_kinematics(:,1:p) == kinematics_thermal_expansion_id)
    if (all(phase_kinematics(:,p) /= kinematics_thermal_expansion_id)) cycle
 
    associate(prm => param(kinematics_thermal_expansion_instance(p)), &
              config => config_phase(p))
 
    prm%T_ref = config%getFloat('reference_temperature', defaultval=0.0_preal)
 
    ! read up to three parameters (constant, linear, quadratic with T)
    temp = config%getFloats('thermal_expansion11')
    prm%expansion(1,1,1:size(temp)) = temp
    temp = config%getFloats('thermal_expansion22',defaultval=[(0.0_preal, i=1,size(temp))],requiredsize=size(temp))
    prm%expansion(2,2,1:size(temp)) = temp
    temp = config%getFloats('thermal_expansion33',defaultval=[(0.0_preal, i=1,size(temp))],requiredsize=size(temp))
    prm%expansion(3,3,1:size(temp)) = temp
    do i=1, size(prm%expansion,3)
      prm%expansion(1:3,1:3,i) = lattice_applylatticesymmetry33(prm%expansion(1:3,1:3,i),config%getString('lattice_structure'))
    enddo
 
    end associate
  enddo
 
end subroutine kinematics_thermal_expansion_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function kinematics_thermal_expansion_initialstrain(homog,phase,offset)
 
  integer, intent(in) :: &
    phase, &
    homog, &
    offset
 
  real(preal), dimension(3,3) :: &
    kinematics_thermal_expansion_initialstrain
 
  associate(prm => param(kinematics_thermal_expansion_instance(phase)))
  kinematics_thermal_expansion_initialstrain = &
    (temperature(homog)%p(offset) - prm%T_ref)**1 / 1. * prm%expansion(1:3,1:3,1) + &               ! constant  coefficient
    (temperature(homog)%p(offset) - prm%T_ref)**2 / 2. * prm%expansion(1:3,1:3,2) + &               ! linear    coefficient
    (temperature(homog)%p(offset) - prm%T_ref)**3 / 3. * prm%expansion(1:3,1:3,3)                   ! quadratic coefficient
  end associate
 
end function kinematics_thermal_expansion_initialstrain
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine kinematics_thermal_expansion_lianditstangent(Li, dLi_dTstar, ipc, ip, el)
 
  integer, intent(in) :: &
    ipc, &                                                                                          !< grain number
    ip, &                                                                                           !< integration point number
    el
  real(preal),   intent(out), dimension(3,3) :: &
    li
  real(preal),   intent(out), dimension(3,3,3,3) :: &
    dli_dtstar
 
  integer :: &
    phase, &
    homog
  real(preal) :: &
    t, tdot
 
  phase = material_phaseat(ipc,el)
  homog = material_homogenizationat(el)
  t = temperature(homog)%p(thermalmapping(homog)%p(ip,el))
  tdot = temperaturerate(homog)%p(thermalmapping(homog)%p(ip,el))
 
  associate(prm => param(kinematics_thermal_expansion_instance(phase)))
  li = tdot * ( &
                prm%expansion(1:3,1:3,1)*(t - prm%T_ref)**0 &                                       ! constant  coefficient
              + prm%expansion(1:3,1:3,2)*(t - prm%T_ref)**1 &                                       ! linear    coefficient
              + prm%expansion(1:3,1:3,3)*(t - prm%T_ref)**2 &                                       ! quadratic coefficient
              ) / &
       (1.0_preal &
             + prm%expansion(1:3,1:3,1)*(t - prm%T_ref)**1 / 1. &
             + prm%expansion(1:3,1:3,2)*(t - prm%T_ref)**2 / 2. &
             + prm%expansion(1:3,1:3,3)*(t - prm%T_ref)**3 / 3. &
       )
  end associate
  dli_dtstar = 0.0_preal
 
end subroutine kinematics_thermal_expansion_lianditstangent
 
end module kinematics_thermal_expansion
# 36 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module constitutive
  use prec
  use math
  use rotations
  use debug
  use numerics
  use io
  use config
  use material
  use results
  use lattice
  use discretization
  use geometry_plastic_nonlocal
  use source_thermal_dissipation
  use source_thermal_externalheat
  use source_damage_isobrittle
  use source_damage_isoductile
  use source_damage_anisobrittle
  use source_damage_anisoductile
  use kinematics_cleavage_opening
  use kinematics_slipplane_opening
  use kinematics_thermal_expansion
 
  implicit none
  private
 
  integer, public, protected :: &
    constitutive_plasticity_maxsizedotstate, &
    constitutive_source_maxsizedotstate
 
  interface
 
    module subroutine plastic_none_init
    end subroutine plastic_none_init
 
    module subroutine plastic_isotropic_init
    end subroutine plastic_isotropic_init
 
    module subroutine plastic_phenopowerlaw_init
    end subroutine plastic_phenopowerlaw_init
 
    module subroutine plastic_kinehardening_init
    end subroutine plastic_kinehardening_init
 
    module subroutine plastic_dislotwin_init
    end subroutine plastic_dislotwin_init
 
    module subroutine plastic_disloucla_init
    end subroutine plastic_disloucla_init
 
    module subroutine plastic_nonlocal_init
    end subroutine plastic_nonlocal_init
 
 
    module subroutine plastic_isotropic_lpanditstangent(lp,dlp_dmp,mp,instance,of)
      real(preal), dimension(3,3),     intent(out) :: &
        lp
      real(preal), dimension(3,3,3,3), intent(out) :: &
        dlp_dmp
 
      real(preal), dimension(3,3),     intent(in) :: &
        mp
      integer,                         intent(in) :: &
        instance, &
        of
    end subroutine plastic_isotropic_lpanditstangent
 
    pure module subroutine plastic_phenopowerlaw_lpanditstangent(lp,dlp_dmp,mp,instance,of)
      real(preal), dimension(3,3),     intent(out) :: &
        lp
      real(preal), dimension(3,3,3,3), intent(out) :: &
        dlp_dmp
 
      real(preal), dimension(3,3),     intent(in) :: &
        mp
      integer,                         intent(in) :: &
        instance, &
        of
    end subroutine plastic_phenopowerlaw_lpanditstangent
 
    pure module subroutine plastic_kinehardening_lpanditstangent(lp,dlp_dmp,mp,instance,of)
      real(preal), dimension(3,3),     intent(out) :: &
        lp
      real(preal), dimension(3,3,3,3), intent(out) :: &
        dlp_dmp
 
      real(preal), dimension(3,3),     intent(in) :: &
        mp
      integer,                         intent(in) :: &
        instance, &
        of
    end subroutine plastic_kinehardening_lpanditstangent
 
    module subroutine plastic_dislotwin_lpanditstangent(lp,dlp_dmp,mp,t,instance,of)
      real(preal), dimension(3,3),     intent(out) :: &
        lp
      real(preal), dimension(3,3,3,3), intent(out) :: &
        dlp_dmp
 
      real(preal), dimension(3,3),     intent(in) :: &
        mp
      real(preal),                     intent(in) :: &
        t
      integer,                         intent(in) :: &
        instance, &
        of
    end subroutine plastic_dislotwin_lpanditstangent
 
    pure module subroutine plastic_disloucla_lpanditstangent(lp,dlp_dmp,mp,t,instance,of)
      real(preal), dimension(3,3),     intent(out) :: &
        lp
      real(preal), dimension(3,3,3,3), intent(out) :: &
        dlp_dmp
 
      real(preal), dimension(3,3),     intent(in) :: &
        mp
      real(preal),                     intent(in) :: &
        t
      integer,                         intent(in) :: &
        instance, &
        of
    end subroutine plastic_disloucla_lpanditstangent
 
    module subroutine plastic_nonlocal_lpanditstangent(lp,dlp_dmp, &
                                                       mp,temperature,instance,of,ip,el)
      real(preal), dimension(3,3),     intent(out) :: &
        lp
      real(preal), dimension(3,3,3,3), intent(out) :: &
        dlp_dmp
 
      real(preal), dimension(3,3),     intent(in) :: &
        mp
      real(preal),                     intent(in) :: &
        temperature
      integer,                         intent(in) :: &
        instance, &
        of, &
        ip, &                                                                                       !< current integration point
        el
    end subroutine plastic_nonlocal_lpanditstangent
 
 
    module subroutine plastic_isotropic_lianditstangent(li,dli_dmi,mi,instance,of)
      real(preal), dimension(3,3),     intent(out) :: &
        li
      real(preal), dimension(3,3,3,3), intent(out)  :: &
        dli_dmi
 
      real(preal), dimension(3,3),     intent(in) :: &
        mi
      integer,                         intent(in) :: &
        instance, &
        of
    end subroutine plastic_isotropic_lianditstangent
 
 
    module subroutine plastic_isotropic_dotstate(mp,instance,of)
      real(preal), dimension(3,3),  intent(in) :: &
        mp
      integer,                      intent(in) :: &
        instance, &
        of
    end subroutine plastic_isotropic_dotstate
 
    module subroutine plastic_phenopowerlaw_dotstate(mp,instance,of)
      real(preal), dimension(3,3),  intent(in) :: &
        mp
      integer,                      intent(in) :: &
        instance, &
        of
    end subroutine plastic_phenopowerlaw_dotstate
 
    module subroutine plastic_kinehardening_dotstate(mp,instance,of)
      real(preal), dimension(3,3),  intent(in) :: &
        mp
      integer,                      intent(in) :: &
        instance, &
        of
    end subroutine plastic_kinehardening_dotstate
 
    module subroutine plastic_dislotwin_dotstate(mp,t,instance,of)
      real(preal), dimension(3,3),  intent(in) :: &
        mp
      real(preal),                  intent(in) :: &
        t
      integer,                      intent(in) :: &
        instance, &
        of
    end subroutine plastic_dislotwin_dotstate
 
    module subroutine plastic_disloucla_dotstate(mp,t,instance,of)
      real(preal), dimension(3,3),  intent(in) :: &
        mp
      real(preal),                  intent(in) :: &
        t
      integer,                      intent(in) :: &
        instance, &
        of
    end subroutine plastic_disloucla_dotstate
 
    module subroutine plastic_nonlocal_dotstate(mp, f, fp, temperature,timestep, &
                                                instance,of,ip,el)
      real(preal), dimension(3,3), intent(in) ::&
        mp
      real(preal), dimension(3,3,homogenization_maxNgrains,discretization_nIP,discretization_nElem), intent(in) :: &
        f, &                                                                                        !< deformation gradient
        fp
      real(preal), intent(in) :: &
        temperature, &                                                                              !< temperature
        timestep
      integer, intent(in) :: &
        instance, &
        of, &
        ip, &                                                                                       !< current integration point
        el
    end subroutine plastic_nonlocal_dotstate
 
 
    module subroutine plastic_dislotwin_dependentstate(t,instance,of)
      integer,       intent(in) :: &
        instance, &
        of
      real(preal),   intent(in) :: &
        t
    end subroutine plastic_dislotwin_dependentstate
 
    module subroutine plastic_disloucla_dependentstate(instance,of)
      integer,       intent(in) :: &
        instance, &
        of
    end subroutine plastic_disloucla_dependentstate
 
    module subroutine plastic_nonlocal_dependentstate(f, fp, instance, of, ip, el)
      real(preal), dimension(3,3), intent(in) :: &
        f, &
        fp
      integer, intent(in) :: &
        instance, &
        of, &
        ip, &
        el
    end subroutine plastic_nonlocal_dependentstate
 
 
    module subroutine plastic_kinehardening_deltastate(mp,instance,of)
      real(preal), dimension(3,3),  intent(in) :: &
        mp
      integer,                      intent(in) :: &
        instance, &
        of
    end subroutine plastic_kinehardening_deltastate
 
    module subroutine plastic_nonlocal_deltastate(mp,instance,of,ip,el)
      real(preal), dimension(3,3), intent(in) :: &
        mp
      integer, intent(in) :: &
        instance, &
        of, &
        ip, &
        el
    end subroutine plastic_nonlocal_deltastate
 
 
    module function plastic_dislotwin_homogenizedc(ipc,ip,el) result(homogenizedc)
      real(preal), dimension(6,6) :: &
        homogenizedc
      integer,     intent(in) :: &
        ipc, &                                                                                      !< component-ID of integration point
        ip, &                                                                                       !< integration point
        el
    end function plastic_dislotwin_homogenizedc
 
    module subroutine plastic_nonlocal_updatecompatibility(orientation,instance,i,e)
      integer, intent(in) :: &
        instance, &
        i, &
        e
      type(rotation), dimension(1,discretization_nIP,discretization_nElem), intent(in) :: &
        orientation
    end subroutine plastic_nonlocal_updatecompatibility
 
 
    module subroutine plastic_isotropic_results(instance,group)
      integer,          intent(in) :: instance
      character(len=*), intent(in) :: group
    end subroutine plastic_isotropic_results
 
    module subroutine plastic_phenopowerlaw_results(instance,group)
      integer,          intent(in) :: instance
      character(len=*), intent(in) :: group
    end subroutine plastic_phenopowerlaw_results
 
    module subroutine plastic_kinehardening_results(instance,group)
      integer,          intent(in) :: instance
      character(len=*), intent(in) :: group
    end subroutine plastic_kinehardening_results
 
    module subroutine plastic_dislotwin_results(instance,group)
      integer,          intent(in) :: instance
      character(len=*), intent(in) :: group
    end subroutine plastic_dislotwin_results
 
    module subroutine plastic_disloucla_results(instance,group)
      integer,          intent(in) :: instance
      character(len=*), intent(in) :: group
    end subroutine plastic_disloucla_results
 
    module subroutine plastic_nonlocal_results(instance,group)
      integer,          intent(in) :: instance
      character(len=*), intent(in) :: group
    end subroutine plastic_nonlocal_results
 
  end interface
 
  public :: &
    plastic_nonlocal_updatecompatibility, &
    constitutive_init, &
    constitutive_homogenizedc, &
    constitutive_dependentstate, &
    constitutive_lpanditstangents, &
    constitutive_lianditstangents, &
    constitutive_initialfi, &
    constitutive_sanditstangents, &
    constitutive_collectdotstate, &
    constitutive_collectdeltastate, &
    constitutive_results
 
contains
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine constitutive_init
 
  integer :: &
    ph, &                                                                                           !< counter in phase loop
    s
 
!--------------------------------------------------------------------------------------------------
! initialized plasticity
  if (any(phase_plasticity == plasticity_none_id))          call plastic_none_init
  if (any(phase_plasticity == plasticity_isotropic_id))     call plastic_isotropic_init
  if (any(phase_plasticity == plasticity_phenopowerlaw_id)) call plastic_phenopowerlaw_init
  if (any(phase_plasticity == plasticity_kinehardening_id)) call plastic_kinehardening_init
  if (any(phase_plasticity == plasticity_dislotwin_id))     call plastic_dislotwin_init
  if (any(phase_plasticity == plasticity_disloucla_id))     call plastic_disloucla_init
  if (any(phase_plasticity == plasticity_nonlocal_id)) then
    call plastic_nonlocal_init
  else
    call geometry_plastic_nonlocal_disable
  endif
!--------------------------------------------------------------------------------------------------
! initialize source mechanisms
  if (any(phase_source == source_thermal_dissipation_id))     call source_thermal_dissipation_init
  if (any(phase_source == source_thermal_externalheat_id))    call source_thermal_externalheat_init
  if (any(phase_source == source_damage_isobrittle_id))       call source_damage_isobrittle_init
  if (any(phase_source == source_damage_isoductile_id))       call source_damage_isoductile_init
  if (any(phase_source == source_damage_anisobrittle_id))     call source_damage_anisobrittle_init
  if (any(phase_source == source_damage_anisoductile_id))     call source_damage_anisoductile_init
 
!--------------------------------------------------------------------------------------------------
! initialize kinematic mechanisms
  if (any(phase_kinematics == kinematics_cleavage_opening_id))  call kinematics_cleavage_opening_init
  if (any(phase_kinematics == kinematics_slipplane_opening_id)) call kinematics_slipplane_opening_init
  if (any(phase_kinematics == kinematics_thermal_expansion_id)) call kinematics_thermal_expansion_init
 
  write(6,'(/,a)')   ' <<<+-  constitutive init  -+>>>'; flush(6)
 
  constitutive_source_maxsizedotstate = 0
  phaseloop2:do ph = 1,material_nphase
!--------------------------------------------------------------------------------------------------
! partition and inititalize state
    plasticstate(ph)%partionedState0 = plasticstate(ph)%state0
    plasticstate(ph)%state           = plasticstate(ph)%partionedState0
    forall(s = 1:phase_nsources(ph))
      sourcestate(ph)%p(s)%partionedState0 = sourcestate(ph)%p(s)%state0
      sourcestate(ph)%p(s)%state           = sourcestate(ph)%p(s)%partionedState0
    end forall
!--------------------------------------------------------------------------------------------------
! determine max size of source state
    constitutive_source_maxsizedotstate   = max(constitutive_source_maxsizedotstate, &
                                                maxval(sourcestate(ph)%p%sizeDotState))
  enddo phaseloop2
  constitutive_plasticity_maxsizedotstate = maxval(plasticstate%sizeDotState)
 
end subroutine constitutive_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function constitutive_homogenizedc(ipc,ip,el)
 
  real(preal), dimension(6,6) :: constitutive_homogenizedc
  integer, intent(in) :: &
    ipc, &                                                                                          !< component-ID of integration point
    ip, &                                                                                           !< integration point
    el
 
  plasticitytype: select case (phase_plasticity(material_phaseat(ipc,el)))
    case (plasticity_dislotwin_id) plasticitytype
      constitutive_homogenizedc = plastic_dislotwin_homogenizedc(ipc,ip,el)
    case default plasticitytype
      constitutive_homogenizedc = lattice_c66(1:6,1:6,material_phaseat(ipc,el))
  end select plasticitytype
 
end function constitutive_homogenizedc
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine constitutive_dependentstate(F, Fp, ipc, ip, el)
 
  integer, intent(in) :: &
    ipc, &                                                                                          !< component-ID of integration point
    ip, &                                                                                           !< integration point
    el
  real(preal),   intent(in), dimension(3,3) :: &
    f, &                                                                                           !< elastic deformation gradient
    fp
  integer :: &
    ho, &                                                                                           !< homogenization
    tme, &                                                                                          !< thermal member position
    instance, of
 
  ho  = material_homogenizationat(el)
  tme = thermalmapping(ho)%p(ip,el)
  of  = material_phasememberat(ipc,ip,el)
  instance = phase_plasticityinstance(material_phaseat(ipc,el))
 
  plasticitytype: select case (phase_plasticity(material_phaseat(ipc,el)))
    case (plasticity_dislotwin_id) plasticitytype
      call plastic_dislotwin_dependentstate(temperature(ho)%p(tme),instance,of)
    case (plasticity_disloucla_id) plasticitytype
      call plastic_disloucla_dependentstate(instance,of)
    case (plasticity_nonlocal_id) plasticitytype
      call plastic_nonlocal_dependentstate (f,fp,instance,of,ip,el)
  end select plasticitytype
 
end subroutine constitutive_dependentstate
 
 
!--------------------------------------------------------------------------------------------------
! ToDo: Discuss wheter it makes sense if crystallite handles the configuration conversion, i.e.
! Mp in, dLp_dMp out
!--------------------------------------------------------------------------------------------------
subroutine constitutive_lpanditstangents(Lp, dLp_dS, dLp_dFi, &
                                         S, Fi, ipc, ip, el)
  integer, intent(in) :: &
    ipc, &                                                                                          !< component-ID of integration point
    ip, &                                                                                           !< integration point
    el
  real(preal),   intent(in),  dimension(3,3) :: &
    s, &                                                                                            !< 2nd Piola-Kirchhoff stress
    fi
  real(preal),   intent(out), dimension(3,3) :: &
    lp
  real(preal),   intent(out), dimension(3,3,3,3) :: &
    dlp_ds, &
    dlp_dfi
  real(preal), dimension(3,3,3,3) :: &
    dlp_dmp
  real(preal), dimension(3,3) :: &
    mp
  integer :: &
    ho, &                                                                                           !< homogenization
    tme
  integer :: &
    i, j, instance, of
 
  ho = material_homogenizationat(el)
  tme = thermalmapping(ho)%p(ip,el)
 
  mp = matmul(matmul(transpose(fi),fi),s)
  of = material_phasememberat(ipc,ip,el)
  instance = phase_plasticityinstance(material_phaseat(ipc,el))
 
  plasticitytype: select case (phase_plasticity(material_phaseat(ipc,el)))
 
    case (plasticity_none_id) plasticitytype
      lp = 0.0_preal
      dlp_dmp = 0.0_preal
 
    case (plasticity_isotropic_id) plasticitytype
      call plastic_isotropic_lpanditstangent   (lp,dlp_dmp,mp,instance,of)
 
    case (plasticity_phenopowerlaw_id) plasticitytype
      call plastic_phenopowerlaw_lpanditstangent(lp,dlp_dmp,mp,instance,of)
 
    case (plasticity_kinehardening_id) plasticitytype
      call plastic_kinehardening_lpanditstangent(lp,dlp_dmp,mp,instance,of)
 
    case (plasticity_nonlocal_id) plasticitytype
      call plastic_nonlocal_lpanditstangent     (lp,dlp_dmp,mp, temperature(ho)%p(tme),instance,of,ip,el)
 
    case (plasticity_dislotwin_id) plasticitytype
      call plastic_dislotwin_lpanditstangent    (lp,dlp_dmp,mp,temperature(ho)%p(tme),instance,of)
 
    case (plasticity_disloucla_id) plasticitytype
      call plastic_disloucla_lpanditstangent    (lp,dlp_dmp,mp,temperature(ho)%p(tme),instance,of)
 
  end select plasticitytype
 
  do i=1,3; do j=1,3
    dlp_dfi(i,j,1:3,1:3) = matmul(matmul(fi,s),transpose(dlp_dmp(i,j,1:3,1:3))) + &
                           matmul(matmul(fi,dlp_dmp(i,j,1:3,1:3)),s)
    dlp_ds(i,j,1:3,1:3)  = matmul(matmul(transpose(fi),fi),dlp_dmp(i,j,1:3,1:3))                     ! ToDo: @PS: why not:   dLp_dMp:(FiT Fi)
  enddo; enddo
 
end subroutine constitutive_lpanditstangents
 
 
!--------------------------------------------------------------------------------------------------
! ToDo: MD: S is Mi?
!--------------------------------------------------------------------------------------------------
subroutine constitutive_lianditstangents(Li, dLi_dS, dLi_dFi, &
                                         S, Fi, ipc, ip, el)
 
  integer, intent(in) :: &
    ipc, &                                                                                          !< component-ID of integration point
    ip, &                                                                                           !< integration point
    el
  real(preal),   intent(in),  dimension(3,3) :: &
    s
  real(preal),   intent(in),  dimension(3,3) :: &
    fi
  real(preal),   intent(out), dimension(3,3) :: &
    li
  real(preal),   intent(out), dimension(3,3,3,3) :: &
    dli_ds, &                                                                                       !< derivative of Li with respect to S
    dli_dfi
 
  real(preal), dimension(3,3) :: &
    my_li, &                                                                                        !< intermediate velocity gradient
    fiinv, &
    temp_33
  real(preal), dimension(3,3,3,3) :: &
    my_dli_ds
  real(preal) :: &
    detfi
  integer :: &
    k, i, j, &
    instance, of
 
  li = 0.0_preal
  dli_ds  = 0.0_preal
  dli_dfi = 0.0_preal
 
  plasticitytype: select case (phase_plasticity(material_phaseat(ipc,el)))
    case (plasticity_isotropic_id) plasticitytype
      of = material_phasememberat(ipc,ip,el)
      instance = phase_plasticityinstance(material_phaseat(ipc,el))
      call plastic_isotropic_lianditstangent(my_li, my_dli_ds, s ,instance,of)
    case default plasticitytype
      my_li = 0.0_preal
      my_dli_ds = 0.0_preal
  end select plasticitytype
 
  li = li + my_li
  dli_ds = dli_ds + my_dli_ds
 
  kinematicsloop: do k = 1, phase_nkinematics(material_phaseat(ipc,el))
    kinematicstype: select case (phase_kinematics(k,material_phaseat(ipc,el)))
      case (kinematics_cleavage_opening_id) kinematicstype
        call kinematics_cleavage_opening_lianditstangent(my_li, my_dli_ds, s, ipc, ip, el)
      case (kinematics_slipplane_opening_id) kinematicstype
        call kinematics_slipplane_opening_lianditstangent(my_li, my_dli_ds, s, ipc, ip, el)
      case (kinematics_thermal_expansion_id) kinematicstype
        call kinematics_thermal_expansion_lianditstangent(my_li, my_dli_ds, ipc, ip, el)
      case default kinematicstype
        my_li = 0.0_preal
        my_dli_ds = 0.0_preal
    end select kinematicstype
    li = li + my_li
    dli_ds = dli_ds + my_dli_ds
  enddo kinematicsloop
 
  fiinv = math_inv33(fi)
  detfi = math_det33(fi)
  li = matmul(matmul(fi,li),fiinv)*detfi                                                            
  temp_33 = matmul(fiinv,li)
 
  do i = 1,3; do j = 1,3
    dli_ds(1:3,1:3,i,j)  = matmul(matmul(fi,dli_ds(1:3,1:3,i,j)),fiinv)*detfi
    dli_dfi(1:3,1:3,i,j) = dli_dfi(1:3,1:3,i,j) + li*fiinv(j,i)
    dli_dfi(1:3,i,1:3,j) = dli_dfi(1:3,i,1:3,j) + math_i3*temp_33(j,i) + li*fiinv(j,i)
  enddo; enddo
 
end subroutine constitutive_lianditstangents
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function constitutive_initialfi(ipc, ip, el)
 
  integer, intent(in) :: &
    ipc, &                                                                                          !< component-ID of integration point
    ip, &                                                                                           !< integration point
    el
  real(preal), dimension(3,3) :: &
    constitutive_initialfi
  integer :: &
    k
  integer :: &
    phase, &
    homog, offset
 
  constitutive_initialfi = math_i3
  phase = material_phaseat(ipc,el)
 
  kinematicsloop: do k = 1, phase_nkinematics(phase)                                                
    kinematicstype: select case (phase_kinematics(k,phase))
      case (kinematics_thermal_expansion_id) kinematicstype
        homog = material_homogenizationat(el)
        offset = thermalmapping(homog)%p(ip,el)
        constitutive_initialfi = &
          constitutive_initialfi + kinematics_thermal_expansion_initialstrain(homog,phase,offset)
    end select kinematicstype
  enddo kinematicsloop
 
end function constitutive_initialfi
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine constitutive_sanditstangents(S, dS_dFe, dS_dFi, Fe, Fi, ipc, ip, el)
 
  integer, intent(in) :: &
    ipc, &                                                                                          !< component-ID of integration point
    ip, &                                                                                           !< integration point
    el
  real(preal),   intent(in),  dimension(3,3) :: &
    fe, &                                                                                           !< elastic deformation gradient
    fi
  real(preal),   intent(out), dimension(3,3) :: &
    s
  real(preal),   intent(out), dimension(3,3,3,3) :: &
    ds_dfe, &                                                                                       !< derivative of 2nd P-K stress with respect to elastic deformation gradient
    ds_dfi
 
  call constitutive_hooke_sanditstangents(s, ds_dfe, ds_dfi, fe, fi, ipc, ip, el)
 
 
end subroutine constitutive_sanditstangents
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine constitutive_hooke_sanditstangents(S, dS_dFe, dS_dFi, &
                                              Fe, Fi, ipc, ip, el)
 
  integer, intent(in) :: &
    ipc, &                                                                                          !< component-ID of integration point
    ip, &                                                                                           !< integration point
    el
  real(pReal),   intent(in),  dimension(3,3) :: &
    Fe, &                                                                                           !< elastic deformation gradient
    Fi
  real(pReal),   intent(out), dimension(3,3) :: &
    S
  real(pReal),   intent(out), dimension(3,3,3,3) :: &
    dS_dFe, &                                                                                       !< derivative of 2nd P-K stress with respect to elastic deformation gradient
    dS_dFi
  real(pReal), dimension(3,3) :: E
  real(pReal), dimension(3,3,3,3) :: C
  integer :: &
    ho, &                                                                                           !< homogenization
    d
  integer :: &
    i, j
 
  ho = material_homogenizationat(el)
  c = math_66tosym3333(constitutive_homogenizedc(ipc,ip,el))
 
  degradationloop: do d = 1, phase_nstiffnessdegradations(material_phaseat(ipc,el))
    degradationtype: select case(phase_stiffnessdegradation(d,material_phaseat(ipc,el)))
      case (stiffness_degradation_damage_id) degradationtype
        c = c * damage(ho)%p(damagemapping(ho)%p(ip,el))**2
    end select degradationtype
  enddo degradationloop
 
  e = 0.5_preal*(matmul(transpose(fe),fe)-math_i3)                                                  
  s = math_mul3333xx33(c,matmul(matmul(transpose(fi),e),fi))                                        
 
  do i =1, 3;do j=1,3
    ds_dfe(i,j,1:3,1:3) = matmul(fe,matmul(matmul(fi,c(i,j,1:3,1:3)),transpose(fi)))                
    ds_dfi(i,j,1:3,1:3) = 2.0_preal*matmul(matmul(e,fi),c(i,j,1:3,1:3))                             
  enddo; enddo
 
end subroutine constitutive_hooke_sanditstangents
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine constitutive_collectdotstate(S, FArray, Fi, FpArray, subdt, ipc, ip, el)
 
  integer, intent(in) :: &
    ipc, &                                                                                          !< component-ID of integration point
    ip, &                                                                                           !< integration point
    el
  real(preal),  intent(in) :: &
    subdt
  real(preal),  intent(in), dimension(3,3,homogenization_maxNgrains,discretization_nIP,discretization_nElem) :: &
    farray, &                                                                                       !< elastic deformation gradient
    fparray
  real(preal),  intent(in), dimension(3,3) :: &
    fi
  real(preal),  intent(in), dimension(3,3) :: &
    s
  real(preal),              dimension(3,3) :: &
    mp
  integer :: &
    ho, &                                                                                           !< homogenization
    tme, &                                                                                          !< thermal member position
    i, &                                                                                            !< counter in source loop
    instance, of
 
  ho = material_homogenizationat(el)
  tme = thermalmapping(ho)%p(ip,el)
  of = material_phasememberat(ipc,ip,el)
  instance = phase_plasticityinstance(material_phaseat(ipc,el))
 
  mp = matmul(matmul(transpose(fi),fi),s)
 
  plasticitytype: select case (phase_plasticity(material_phaseat(ipc,el)))
 
    case (plasticity_isotropic_id) plasticitytype
      call plastic_isotropic_dotstate    (mp,instance,of)
 
    case (plasticity_phenopowerlaw_id) plasticitytype
      call plastic_phenopowerlaw_dotstate(mp,instance,of)
 
    case (plasticity_kinehardening_id) plasticitytype
      call plastic_kinehardening_dotstate(mp,instance,of)
 
    case (plasticity_dislotwin_id) plasticitytype
      call plastic_dislotwin_dotstate    (mp,temperature(ho)%p(tme),instance,of)
 
    case (plasticity_disloucla_id) plasticitytype
      call plastic_disloucla_dotstate    (mp,temperature(ho)%p(tme),instance,of)
 
    case (plasticity_nonlocal_id) plasticitytype
      call plastic_nonlocal_dotstate     (mp,farray,fparray,temperature(ho)%p(tme),subdt, &
                                          instance,of,ip,el)
  end select plasticitytype
 
  sourceloop: do i = 1, phase_nsources(material_phaseat(ipc,el))
 
    sourcetype: select case (phase_source(i,material_phaseat(ipc,el)))
 
      case (source_damage_anisobrittle_id) sourcetype
        call source_damage_anisobrittle_dotstate (s, ipc, ip, el) 
 
      case (source_damage_isoductile_id) sourcetype
        call source_damage_isoductile_dotstate   (   ipc, ip, el)
 
      case (source_damage_anisoductile_id) sourcetype
        call source_damage_anisoductile_dotstate (   ipc, ip, el)
 
      case (source_thermal_externalheat_id) sourcetype
        call source_thermal_externalheat_dotstate(material_phaseat(ipc,el),of)
 
    end select sourcetype
 
  enddo sourceloop
 
end subroutine constitutive_collectdotstate
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine constitutive_collectdeltastate(S, Fe, Fi, ipc, ip, el)
 
  integer, intent(in) :: &
    ipc, &                                                                                          !< component-ID of integration point
    ip, &                                                                                           !< integration point
    el
  real(preal),   intent(in), dimension(3,3) :: &
    s, &                                                                                            !< 2nd Piola Kirchhoff stress
    fe, &                                                                                           !< elastic deformation gradient
    fi
  real(preal),               dimension(3,3) :: &
    mp
  integer :: &
    i, &
    instance, of
 
  mp  = matmul(matmul(transpose(fi),fi),s)
  of = material_phasememberat(ipc,ip,el)
  instance = phase_plasticityinstance(material_phaseat(ipc,el))
 
  plasticitytype: select case (phase_plasticity(material_phaseat(ipc,el)))
 
    case (plasticity_kinehardening_id) plasticitytype
      call plastic_kinehardening_deltastate(mp,instance,of)
 
    case (plasticity_nonlocal_id) plasticitytype
      call plastic_nonlocal_deltastate(mp,instance,of,ip,el)
 
  end select plasticitytype
 
  sourceloop: do i = 1, phase_nsources(material_phaseat(ipc,el))
 
     sourcetype: select case (phase_source(i,material_phaseat(ipc,el)))
 
      case (source_damage_isobrittle_id) sourcetype
        call source_damage_isobrittle_deltastate  (constitutive_homogenizedc(ipc,ip,el), fe, &
                                                   ipc, ip, el)
 
    end select sourcetype
 
  enddo sourceloop
 
end subroutine constitutive_collectdeltastate
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine constitutive_results
 
  integer :: p
  character(len=pStringLen) :: group
  do p=1,size(config_name_phase)
    group = trim('current/constituent')//'/'//trim(config_name_phase(p))
    call results_closegroup(results_addgroup(group))
 
    group = trim(group)//'/plastic'
 
    call results_closegroup(results_addgroup(group))
    select case(phase_plasticity(p))
 
      case(plasticity_isotropic_id)
        call plastic_isotropic_results(phase_plasticityinstance(p),group)
 
      case(plasticity_phenopowerlaw_id)
        call plastic_phenopowerlaw_results(phase_plasticityinstance(p),group)
 
      case(plasticity_kinehardening_id)
        call plastic_kinehardening_results(phase_plasticityinstance(p),group)
 
      case(plasticity_dislotwin_id)
        call plastic_dislotwin_results(phase_plasticityinstance(p),group)
 
      case(plasticity_disloucla_id)
        call plastic_disloucla_results(phase_plasticityinstance(p),group)
 
      case(plasticity_nonlocal_id)
        call plastic_nonlocal_results(phase_plasticityinstance(p),group)
    end select
 
  enddo
 
end subroutine constitutive_results
 
end module constitutive
# 37 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_none.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
submodule(constitutive) plastic_none
 
contains
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine plastic_none_init
 
  integer :: &
    ninstance, &
    p, &
    nipcmyphase
 
  write(6,'(/,a)') ' <<<+-  plastic_'//plasticity_none_label//' init  -+>>>'; flush(6)
 
  ninstance = count(phase_plasticity == plasticity_none_id)
  if (iand(debug_level(debug_constitutive),debug_levelbasic) /= 0) &
    write(6,'(a16,1x,i5,/)') '# instances:',ninstance
 
  do p = 1, size(phase_plasticity)
    if (phase_plasticity(p) /= plasticity_none_id) cycle
 
    nipcmyphase = count(material_phaseat == p) * discretization_nip
    call material_allocateplasticstate(p,nipcmyphase,0,0,0)
 
  enddo
 
end subroutine plastic_none_init
 
end submodule plastic_none
# 38 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_isotropic.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
submodule(constitutive) plastic_isotropic
 
  type :: tparameters
    real(preal) :: &
      m, &                                                                                          !< Taylor factor
      dot_gamma_0, &                                                                                !< reference strain rate
      n, &                                                                                          !< stress exponent
      h0, &
      h_ln, &
      xi_inf, &                                                                                     !< maximum critical stress
      a, &
      c_1, &
      c_4, &
      c_3, &
      c_2
    integer :: &
      of_debug = 0
    logical :: &
      dilatation
    character(len=pStringLen), allocatable, dimension(:) :: &
      output
  end type tparameters
 
  type :: tisotropicstate
    real(preal), pointer, dimension(:) :: &
      xi, &
      gamma
  end type tisotropicstate
 
!--------------------------------------------------------------------------------------------------
! containers for parameters and state
 type(tparameters),     allocatable, dimension(:) :: param
 type(tisotropicstate), allocatable, dimension(:) :: &
   dotstate, &
   state
 
contains
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine plastic_isotropic_init
 
  integer :: &
    ninstance, &
    p, &
    nipcmyphase, &
    sizestate, sizedotstate
  real(preal) :: &
    xi_0
  character(len=pStringLen) :: &
    extmsg = ''
 
  write(6,'(/,a)') ' <<<+-  plastic_'//plasticity_isotropic_label//' init  -+>>>'; flush(6)
 
  write(6,'(/,a)') ' Maiti and Eisenlohr, Scripta Materialia 145:37–40, 2018'
  write(6,'(a)')   ' https://doi.org/10.1016/j.scriptamat.2017.09.047'
 
  ninstance = count(phase_plasticity == plasticity_isotropic_id)
  if (iand(debug_level(debug_constitutive),debug_levelbasic) /= 0) &
    write(6,'(a16,1x,i5,/)') '# instances:',ninstance
 
  allocate(param(ninstance))
  allocate(state(ninstance))
  allocate(dotstate(ninstance))
 
  do p = 1, size(phase_plasticity)
    if (phase_plasticity(p) /= plasticity_isotropic_id) cycle
    associate(prm => param(phase_plasticityinstance(p)), &
              dot => dotstate(phase_plasticityinstance(p)), &
              stt => state(phase_plasticityinstance(p)), &
              config => config_phase(p))
 
    prm%output = config%getStrings('(output)',defaultval=emptystringarray)
 
 
 
 
 
 
    xi_0            = config%getFloat('tau0')
    prm%xi_inf      = config%getFloat('tausat')
    prm%dot_gamma_0 = config%getFloat('gdot0')
    prm%n           = config%getFloat('n')
    prm%h0          = config%getFloat('h0')
    prm%M           = config%getFloat('m')
    prm%h_ln        = config%getFloat('h0_slopelnrate', defaultval=0.0_preal)
    prm%c_1         = config%getFloat('tausat_sinhfita',defaultval=0.0_preal)
    prm%c_4         = config%getFloat('tausat_sinhfitb',defaultval=0.0_preal)
    prm%c_3         = config%getFloat('tausat_sinhfitc',defaultval=0.0_preal)
    prm%c_2         = config%getFloat('tausat_sinhfitd',defaultval=0.0_preal)
    prm%a           = config%getFloat('a')
 
    prm%dilatation  = config%keyExists('/dilatation/')
 
!--------------------------------------------------------------------------------------------------
!  sanity checks
    if (xi_0            <  0.0_preal) extmsg = trim(extmsg)//' xi_0'
    if (prm%dot_gamma_0 <= 0.0_preal) extmsg = trim(extmsg)//' dot_gamma_0'
    if (prm%n           <= 0.0_preal) extmsg = trim(extmsg)//' n'
    if (prm%a           <= 0.0_preal) extmsg = trim(extmsg)//' a'
    if (prm%M           <= 0.0_preal) extmsg = trim(extmsg)//' M'
 
!--------------------------------------------------------------------------------------------------
! allocate state arrays
    nipcmyphase = count(material_phaseat == p) * discretization_nip
    sizedotstate = size(['xi               ','accumulated_shear'])
    sizestate = sizedotstate
 
    call material_allocateplasticstate(p,nipcmyphase,sizestate,sizedotstate,0)
 
!--------------------------------------------------------------------------------------------------
! state aliases and initialization
    stt%xi  => plasticstate(p)%state   (1,:)
    stt%xi  =  xi_0
    dot%xi  => plasticstate(p)%dotState(1,:)
    plasticstate(p)%atol(1) = config%getFloat('atol_xi',defaultval=1.0_preal)
    if (plasticstate(p)%atol(1) < 0.0_preal) extmsg = trim(extmsg)//' atol_xi'
 
    stt%gamma  => plasticstate(p)%state   (2,:)
    dot%gamma  => plasticstate(p)%dotState(2,:)
    plasticstate(p)%atol(2) = config%getFloat('atol_gamma',defaultval=1.0e-6_preal)
    if (plasticstate(p)%atol(2) < 0.0_preal) extmsg = trim(extmsg)//' atol_gamma'
    ! global alias
    plasticstate(p)%slipRate        => plasticstate(p)%dotState(2:2,:)
 
    plasticstate(p)%state0 = plasticstate(p)%state                                                  ! ToDo: this could be done centrally
 
    end associate
 
!--------------------------------------------------------------------------------------------------
!  exit if any parameter is out of range
    if (extmsg /= '') call io_error(211,ext_msg=trim(extmsg)//'('//plasticity_isotropic_label//')')
 
  enddo
 
end subroutine plastic_isotropic_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine plastic_isotropic_lpanditstangent(lp,dlp_dmp,mp,instance,of)
 
  real(preal), dimension(3,3),     intent(out) :: &
    lp
  real(preal), dimension(3,3,3,3), intent(out) :: &
    dlp_dmp
 
  real(preal), dimension(3,3), intent(in) :: &
    mp
  integer,                     intent(in) :: &
    instance, &
    of
 
  real(preal), dimension(3,3) :: &
    mp_dev
  real(preal) :: &
    dot_gamma, &                                                                                    !< strainrate
    norm_mp_dev, &                                                                                  !< norm of the deviatoric part of the Mandel stress
    squarenorm_mp_dev
  integer :: &
    k, l, m, n
 
  associate(prm => param(instance), stt => state(instance))
 
  mp_dev = math_deviatoric33(mp)
  squarenorm_mp_dev = math_tensordot(mp_dev,mp_dev)
  norm_mp_dev = sqrt(squarenorm_mp_dev)
 
  if (norm_mp_dev > 0.0_preal) then
    dot_gamma = prm%dot_gamma_0 * (sqrt(1.5_preal) * norm_mp_dev/(prm%M*stt%xi(of))) **prm%n
 
    lp = dot_gamma/prm%M * mp_dev/norm_mp_dev
# 194 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_isotropic.f90"
    forall (k=1:3,l=1:3,m=1:3,n=1:3) &
      dlp_dmp(k,l,m,n) = (prm%n-1.0_preal) * mp_dev(k,l)*mp_dev(m,n) / squarenorm_mp_dev
    forall (k=1:3,l=1:3) &
      dlp_dmp(k,l,k,l) = dlp_dmp(k,l,k,l) + 1.0_preal
    forall (k=1:3,m=1:3) &
      dlp_dmp(k,k,m,m) = dlp_dmp(k,k,m,m) - 1.0_preal/3.0_preal
    dlp_dmp = dot_gamma / prm%M * dlp_dmp / norm_mp_dev
  else
    lp = 0.0_preal
    dlp_dmp = 0.0_preal
  end if
 
  end associate
 
end subroutine plastic_isotropic_lpanditstangent
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine plastic_isotropic_lianditstangent(li,dli_dmi,mi,instance,of)
 
  real(preal), dimension(3,3),     intent(out) :: &
    li
  real(preal), dimension(3,3,3,3), intent(out)  :: &
    dli_dmi
 
  real(preal), dimension(3,3), intent(in) :: &
    mi
  integer,                     intent(in) :: &
    instance, &
    of
 
  real(preal) :: &
    tr
  integer :: &
    k, l, m, n
 
  associate(prm => param(instance), stt => state(instance))
 
  tr=math_trace33(math_spherical33(mi))
 
  if (prm%dilatation .and. abs(tr) > 0.0_preal) then                                                 ! no stress or J2 plasticity --> Li and its derivative are zero
    li = math_i3 &
       * prm%dot_gamma_0/prm%M * (3.0_preal*prm%M*stt%xi(of))**(-prm%n) &
       * tr * abs(tr)**(prm%n-1.0_preal)
 
# 249 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_isotropic.f90"
 
    forall (k=1:3,l=1:3,m=1:3,n=1:3) &
      dli_dmi(k,l,m,n) = prm%n / tr * li(k,l) * math_i3(m,n)
 
  else
    li      = 0.0_preal
    dli_dmi = 0.0_preal
  endif
 
  end associate
 
 end subroutine plastic_isotropic_lianditstangent
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine plastic_isotropic_dotstate(mp,instance,of)
 
  real(preal), dimension(3,3),  intent(in) :: &
    mp
  integer,                      intent(in) :: &
    instance, &
    of
 
  real(preal) :: &
    dot_gamma, &                                                                                    !< strainrate
    xi_inf_star, &                                                                                  !< saturation xi
    norm_mp
 
  associate(prm => param(instance), stt => state(instance), dot => dotstate(instance))
 
  if (prm%dilatation) then
    norm_mp = sqrt(math_tensordot(mp,mp))
  else
    norm_mp = sqrt(math_tensordot(math_deviatoric33(mp),math_deviatoric33(mp)))
  endif
 
  dot_gamma = prm%dot_gamma_0 * (sqrt(1.5_preal) * norm_mp /(prm%M*stt%xi(of))) **prm%n
 
  if (dot_gamma > 1e-12_preal) then
    if (deq0(prm%c_1)) then
      xi_inf_star = prm%xi_inf
    else
      xi_inf_star = prm%xi_inf &
                  + asinh( (dot_gamma / prm%c_1)**(1.0_preal / prm%c_2))**(1.0_preal / prm%c_3) &
                  / prm%c_4 * (dot_gamma / prm%dot_gamma_0)**(1.0_preal / prm%n)
    endif
    dot%xi(of) = dot_gamma &
               * ( prm%h0 + prm%h_ln * log(dot_gamma) ) &
               * abs( 1.0_preal - stt%xi(of)/xi_inf_star )**prm%a &
               * sign(1.0_preal, 1.0_preal - stt%xi(of)/xi_inf_star)
  else
    dot%xi(of) = 0.0_preal
  endif
 
  dot%gamma(of) = dot_gamma                                                                         ! ToDo: not really used
 
  end associate
 
end subroutine plastic_isotropic_dotstate
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine plastic_isotropic_results(instance,group)
 
  integer,          intent(in) :: instance
  character(len=*), intent(in) :: group
 
  integer :: o
 
  associate(prm => param(instance), stt => state(instance))
  outputsloop: do o = 1,size(prm%output)
    select case(trim(prm%output(o)))
      case ('flowstress')                                                                           ! ToDo: should be 'xi'
        call results_writedataset(group,stt%xi,'xi','resistance against plastic flow','Pa')
    end select
  enddo outputsloop
  end associate
 
end subroutine plastic_isotropic_results
 
 
end submodule plastic_isotropic
# 39 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_phenopowerlaw.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
submodule(constitutive) plastic_phenopowerlaw
 
  type :: tparameters
    real(preal) :: &
      gdot0_slip  = 1.0_preal, &                                                                    
      gdot0_twin  = 1.0_preal, &                                                                    
      n_slip      = 1.0_preal, &                                                                    
      n_twin      = 1.0_preal, &                                                                    
      spr         = 1.0_preal, &                                                                    
      c_1         = 1.0_preal, &
      c_2         = 1.0_preal, &
      c_3         = 1.0_preal, &
      c_4         = 1.0_preal, &
      h0_slipslip = 1.0_preal, &                                                                    
      h0_twinslip = 1.0_preal, &                                                                    
      h0_twintwin = 1.0_preal, &                                                                    
      a_slip      = 1.0_preal
    real(preal),               allocatable, dimension(:) :: &
      xi_slip_sat, &                                                                                !< maximum critical shear stress for slip
      h_int, &                                                                                      !< per family hardening activity (optional)
      gamma_twin_char
    real(preal),               allocatable, dimension(:,:) :: &
      interaction_slipslip, &                                                                       !< slip resistance from slip activity
      interaction_sliptwin, &                                                                       !< slip resistance from twin activity
      interaction_twinslip, &                                                                       !< twin resistance from slip activity
      interaction_twintwin
    real(preal),               allocatable, dimension(:,:,:) :: &
      p_sl, &
      p_tw, &
      nonschmid_pos, &
      nonschmid_neg
    integer :: &
      sum_n_sl, &                                                                                   !< total number of active slip system
      sum_n_tw
    logical :: &
      nonschmidactive = .false.
    character(len=pStringLen), allocatable, dimension(:) :: &
      output
  end type tparameters
 
  type :: tphenopowerlawstate
    real(preal), pointer, dimension(:,:) :: &
      xi_slip, &
      xi_twin, &
      gamma_slip, &
      gamma_twin
  end type tphenopowerlawstate
 
!--------------------------------------------------------------------------------------------------
! containers for parameters and state
  type(tparameters),         allocatable, dimension(:) :: param
  type(tphenopowerlawstate), allocatable, dimension(:) :: &
    dotstate, &
    state
 
contains
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine plastic_phenopowerlaw_init
 
  integer :: &
    ninstance, &
    p, i, &
    nipcmyphase, &
    sizestate, sizedotstate, &
    startindex, endindex
  integer,     dimension(:), allocatable :: &
    n_sl, n_tw
  real(preal), dimension(:), allocatable :: &
    xi_slip_0, &                                                                                    !< initial critical shear stress for slip
    xi_twin_0, &                                                                                    !< initial critical shear stress for twin
    a
  character(len=pStringLen) :: &
    extmsg = ''
 
  write(6,'(/,a)') ' <<<+-  plastic_'//plasticity_phenopowerlaw_label//' init  -+>>>'; flush(6)
 
  ninstance = count(phase_plasticity == plasticity_phenopowerlaw_id)
  if (iand(debug_level(debug_constitutive),debug_levelbasic) /= 0) &
    write(6,'(a16,1x,i5,/)') '# instances:',ninstance
 
  allocate(param(ninstance))
  allocate(state(ninstance))
  allocate(dotstate(ninstance))
 
  do p = 1, size(phase_plasticity)
    if (phase_plasticity(p) /= plasticity_phenopowerlaw_id) cycle
    associate(prm => param(phase_plasticityinstance(p)), &
              dot => dotstate(phase_plasticityinstance(p)), &
              stt => state(phase_plasticityinstance(p)), &
              config => config_phase(p))
 
!--------------------------------------------------------------------------------------------------
! slip related parameters
    n_sl         = config%getInts('nslip',defaultval=emptyintarray)
    prm%sum_N_sl = sum(abs(n_sl))
    slipactive: if (prm%sum_N_sl > 0) then
      prm%P_sl = lattice_schmidmatrix_slip(n_sl,config%getString('lattice_structure'),&
                                           config%getFloat('c/a',defaultval=0.0_preal))
 
      if(trim(config%getString('lattice_structure')) == 'bcc') then
        a = config%getFloats('nonschmid_coefficients',defaultval = emptyrealarray)
        if(size(a) > 0) prm%nonSchmidActive = .true.
        prm%nonSchmid_pos  = lattice_nonschmidmatrix(n_sl,a,+1)
        prm%nonSchmid_neg  = lattice_nonschmidmatrix(n_sl,a,-1)
      else
        prm%nonSchmid_pos  = prm%P_sl
        prm%nonSchmid_neg  = prm%P_sl
      endif
      prm%interaction_SlipSlip = lattice_interaction_slipbyslip(n_sl, &
                                                                config%getFloats('interaction_slipslip'), &
                                                                config%getString('lattice_structure'))
 
      xi_slip_0       = config%getFloats('tau0_slip',   requiredsize=size(n_sl))
      prm%xi_slip_sat = config%getFloats('tausat_slip', requiredsize=size(n_sl))
      prm%H_int       = config%getFloats('h_int',       requiredsize=size(n_sl), &
                                         defaultval=[(0.0_preal,i=1,size(n_sl))])
 
      prm%gdot0_slip  = config%getFloat('gdot0_slip')
      prm%n_slip      = config%getFloat('n_slip')
      prm%a_slip      = config%getFloat('a_slip')
      prm%h0_SlipSlip = config%getFloat('h0_slipslip')
 
      ! expand: family => system
      xi_slip_0       = math_expand(xi_slip_0,      n_sl)
      prm%xi_slip_sat = math_expand(prm%xi_slip_sat,n_sl)
      prm%H_int       = math_expand(prm%H_int,      n_sl)
 
      ! sanity checks
      if (    prm%gdot0_slip  <= 0.0_preal)      extmsg = trim(extmsg)//' gdot0_slip'
      if (    prm%a_slip      <= 0.0_preal)      extmsg = trim(extmsg)//' a_slip'
      if (    prm%n_slip      <= 0.0_preal)      extmsg = trim(extmsg)//' n_slip'
      if (any(xi_slip_0       <= 0.0_preal))     extmsg = trim(extmsg)//' xi_slip_0'
      if (any(prm%xi_slip_sat <= 0.0_preal))     extmsg = trim(extmsg)//' xi_slip_sat'
 
    else slipactive
      xi_slip_0 = emptyrealarray
      allocate(prm%xi_slip_sat,prm%H_int,source=emptyrealarray)
      allocate(prm%interaction_SlipSlip(0,0))
    endif slipactive
 
!--------------------------------------------------------------------------------------------------
! twin related parameters
    n_tw         = config%getInts('ntwin', defaultval=emptyintarray)
    prm%sum_N_tw = sum(abs(n_tw))
    twinactive: if (prm%sum_N_tw > 0) then
      prm%P_tw                 = lattice_schmidmatrix_twin(n_tw,config%getString('lattice_structure'),&
                                                           config%getFloat('c/a',defaultval=0.0_preal))
      prm%interaction_TwinTwin = lattice_interaction_twinbytwin(n_tw,&
                                                                config%getFloats('interaction_twintwin'), &
                                                                config%getString('lattice_structure'))
      prm%gamma_twin_char      = lattice_characteristicshear_twin(n_tw,config%getString('lattice_structure'),&
                                                                  config%getFloat('c/a'))
 
      xi_twin_0       = config%getFloats('tau0_twin',requiredsize=size(n_tw))
 
      prm%c_1         = config%getFloat('twin_c',defaultval=0.0_preal)
      prm%c_2         = config%getFloat('twin_b',defaultval=1.0_preal)
      prm%c_3         = config%getFloat('twin_e',defaultval=0.0_preal)
      prm%c_4         = config%getFloat('twin_d',defaultval=0.0_preal)
      prm%gdot0_twin  = config%getFloat('gdot0_twin')
      prm%n_twin      = config%getFloat('n_twin')
      prm%spr         = config%getFloat('s_pr')
      prm%h0_TwinTwin = config%getFloat('h0_twintwin')
 
      ! expand: family => system
      xi_twin_0       = math_expand(xi_twin_0,n_tw)
 
      ! sanity checks
      if (prm%gdot0_twin <= 0.0_preal)  extmsg = trim(extmsg)//' gdot0_twin'
      if (prm%n_twin     <= 0.0_preal)  extmsg = trim(extmsg)//' n_twin'
 
    else twinactive
      xi_twin_0 = emptyrealarray
      allocate(prm%gamma_twin_char,source=emptyrealarray)
      allocate(prm%interaction_TwinTwin(0,0))
    endif twinactive
 
!--------------------------------------------------------------------------------------------------
! slip-twin related parameters
    slipandtwinactive: if (prm%sum_N_sl > 0 .and. prm%sum_N_tw > 0) then
      prm%h0_TwinSlip          = config%getFloat('h0_twinslip')
      prm%interaction_SlipTwin = lattice_interaction_slipbytwin(n_sl,n_tw,&
                                                                config%getFloats('interaction_sliptwin'), &
                                                                config%getString('lattice_structure'))
      prm%interaction_TwinSlip = lattice_interaction_twinbyslip(n_tw,n_sl,&
                                                                config%getFloats('interaction_twinslip'), &
                                                                config%getString('lattice_structure'))
    else slipandtwinactive
      allocate(prm%interaction_SlipTwin(prm%sum_N_sl,prm%sum_N_tw))                                 ! at least one dimension is 0
      allocate(prm%interaction_TwinSlip(prm%sum_N_tw,prm%sum_N_sl))                                 ! at least one dimension is 0
      prm%h0_TwinSlip = 0.0_preal
    endif slipandtwinactive
 
!--------------------------------------------------------------------------------------------------
!  output pararameters
    prm%output = config%getStrings('(output)',defaultval=emptystringarray)
 
!--------------------------------------------------------------------------------------------------
! allocate state arrays
    nipcmyphase = count(material_phaseat == p) * discretization_nip
    sizedotstate = size(['xi_sl   ','gamma_sl']) * prm%sum_N_sl &
                 + size(['xi_tw   ','gamma_tw']) * prm%sum_N_tw
    sizestate = sizedotstate
 
    call material_allocateplasticstate(p,nipcmyphase,sizestate,sizedotstate,0)
 
!--------------------------------------------------------------------------------------------------
! state aliases and initialization
    startindex = 1
    endindex   = prm%sum_N_sl
    stt%xi_slip => plasticstate(p)%state   (startindex:endindex,:)
    stt%xi_slip =  spread(xi_slip_0, 2, nipcmyphase)
    dot%xi_slip => plasticstate(p)%dotState(startindex:endindex,:)
    plasticstate(p)%atol(startindex:endindex) = config%getFloat('atol_xi',defaultval=1.0_preal)
    if(any(plasticstate(p)%atol(startindex:endindex) < 0.0_preal)) extmsg = trim(extmsg)//' atol_xi'
 
    startindex = endindex + 1
    endindex   = endindex + prm%sum_N_tw
    stt%xi_twin => plasticstate(p)%state   (startindex:endindex,:)
    stt%xi_twin =  spread(xi_twin_0, 2, nipcmyphase)
    dot%xi_twin => plasticstate(p)%dotState(startindex:endindex,:)
    plasticstate(p)%atol(startindex:endindex) = config%getFloat('atol_xi',defaultval=1.0_preal)
    if(any(plasticstate(p)%atol(startindex:endindex) < 0.0_preal)) extmsg = trim(extmsg)//' atol_xi'
 
    startindex = endindex + 1
    endindex   = endindex + prm%sum_N_sl
    stt%gamma_slip => plasticstate(p)%state   (startindex:endindex,:)
    dot%gamma_slip => plasticstate(p)%dotState(startindex:endindex,:)
    plasticstate(p)%atol(startindex:endindex) = config%getFloat('atol_gamma',defaultval=1.0e-6_preal)
    if(any(plasticstate(p)%atol(startindex:endindex) < 0.0_preal)) extmsg = trim(extmsg)//' atol_gamma'
    ! global alias
    plasticstate(p)%slipRate => plasticstate(p)%dotState(startindex:endindex,:)
 
    startindex = endindex + 1
    endindex   = endindex + prm%sum_N_tw
    stt%gamma_twin => plasticstate(p)%state   (startindex:endindex,:)
    dot%gamma_twin => plasticstate(p)%dotState(startindex:endindex,:)
    plasticstate(p)%atol(startindex:endindex) = config%getFloat('atol_gamma',defaultval=1.0e-6_preal)
    if(any(plasticstate(p)%atol(startindex:endindex) < 0.0_preal)) extmsg = trim(extmsg)//' atol_gamma'
 
    plasticstate(p)%state0 = plasticstate(p)%state                                                  ! ToDo: this could be done centrally
 
    end associate
 
!--------------------------------------------------------------------------------------------------
!  exit if any parameter is out of range
    if (extmsg /= '') call io_error(211,ext_msg=trim(extmsg)//'('//plasticity_phenopowerlaw_label//')')
 
  enddo
 
end subroutine plastic_phenopowerlaw_init
 
 
!--------------------------------------------------------------------------------------------------
!  equally (Taylor assumption). Twinning happens only in untwinned volume
!--------------------------------------------------------------------------------------------------
pure module subroutine plastic_phenopowerlaw_lpanditstangent(lp,dlp_dmp,mp,instance,of)
 
  real(preal), dimension(3,3),     intent(out) :: &
    lp
  real(preal), dimension(3,3,3,3), intent(out) :: &
    dlp_dmp
 
  real(preal), dimension(3,3), intent(in) :: &
    mp
  integer,               intent(in) :: &
    instance, &
    of
 
  integer :: &
    i,k,l,m,n
  real(preal), dimension(param(instance)%sum_N_sl) :: &
    gdot_slip_pos,gdot_slip_neg, &
    dgdot_dtauslip_pos,dgdot_dtauslip_neg
  real(preal), dimension(param(instance)%sum_N_tw) :: &
    gdot_twin,dgdot_dtautwin
 
  lp = 0.0_preal
  dlp_dmp = 0.0_preal
 
  associate(prm => param(instance))
 
  call kinetics_slip(mp,instance,of,gdot_slip_pos,gdot_slip_neg,dgdot_dtauslip_pos,dgdot_dtauslip_neg)
  slipsystems: do i = 1, prm%sum_N_sl
    lp = lp + (gdot_slip_pos(i)+gdot_slip_neg(i))*prm%P_sl(1:3,1:3,i)
    forall (k=1:3,l=1:3,m=1:3,n=1:3) &
      dlp_dmp(k,l,m,n) = dlp_dmp(k,l,m,n) &
                       + dgdot_dtauslip_pos(i) * prm%P_sl(k,l,i) * prm%nonSchmid_pos(m,n,i) &
                       + dgdot_dtauslip_neg(i) * prm%P_sl(k,l,i) * prm%nonSchmid_neg(m,n,i)
  enddo slipsystems
 
  call kinetics_twin(mp,instance,of,gdot_twin,dgdot_dtautwin)
  twinsystems: do i = 1, prm%sum_N_tw
    lp = lp + gdot_twin(i)*prm%P_tw(1:3,1:3,i)
    forall (k=1:3,l=1:3,m=1:3,n=1:3) &
      dlp_dmp(k,l,m,n) = dlp_dmp(k,l,m,n) &
                       + dgdot_dtautwin(i)*prm%P_tw(k,l,i)*prm%P_tw(m,n,i)
  enddo twinsystems
 
  end associate
 
end subroutine plastic_phenopowerlaw_lpanditstangent
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine plastic_phenopowerlaw_dotstate(mp,instance,of)
 
  real(preal), dimension(3,3),  intent(in) :: &
    mp
  integer,                      intent(in) :: &
    instance, &
    of
 
  real(preal) :: &
    c_slipslip,c_twinslip,c_twintwin, &
    xi_slip_sat_offset,&
    sumgamma,sumf
  real(preal), dimension(param(instance)%sum_N_sl) :: &
    left_slipslip,right_slipslip, &
    gdot_slip_pos,gdot_slip_neg
 
  associate(prm => param(instance), stt => state(instance), dot => dotstate(instance))
 
  sumgamma = sum(stt%gamma_slip(:,of))
  sumf     = sum(stt%gamma_twin(:,of)/prm%gamma_twin_char)
 
!--------------------------------------------------------------------------------------------------
! system-independent (nonlinear) prefactors to M_Xx (X influenced by x) matrices
  c_slipslip = prm%h0_slipslip * (1.0_preal + prm%c_1*sumf** prm%c_2)
  c_twinslip = prm%h0_TwinSlip * sumgamma**prm%c_3
  c_twintwin = prm%h0_TwinTwin * sumf**prm%c_4
 
!--------------------------------------------------------------------------------------------------
!  calculate left and right vectors
  left_slipslip  = 1.0_preal + prm%H_int
  xi_slip_sat_offset = prm%spr*sqrt(sumf)
  right_slipslip = abs(1.0_preal-stt%xi_slip(:,of) / (prm%xi_slip_sat+xi_slip_sat_offset)) **prm%a_slip &
                 * sign(1.0_preal,1.0_preal-stt%xi_slip(:,of) / (prm%xi_slip_sat+xi_slip_sat_offset))
 
!--------------------------------------------------------------------------------------------------
! shear rates
  call kinetics_slip(mp,instance,of,gdot_slip_pos,gdot_slip_neg)
  dot%gamma_slip(:,of) = abs(gdot_slip_pos+gdot_slip_neg)
  call kinetics_twin(mp,instance,of,dot%gamma_twin(:,of))
 
!--------------------------------------------------------------------------------------------------
! hardening
  dot%xi_slip(:,of) = c_slipslip * left_slipslip * &
                      matmul(prm%interaction_SlipSlip,dot%gamma_slip(:,of)*right_slipslip) &
                    + matmul(prm%interaction_SlipTwin,dot%gamma_twin(:,of))
 
  dot%xi_twin(:,of) = c_twinslip * matmul(prm%interaction_TwinSlip,dot%gamma_slip(:,of)) &
                    + c_twintwin * matmul(prm%interaction_TwinTwin,dot%gamma_twin(:,of))
  end associate
 
end subroutine plastic_phenopowerlaw_dotstate
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine plastic_phenopowerlaw_results(instance,group)
 
  integer,          intent(in) :: instance
  character(len=*), intent(in) :: group
 
  integer :: o
 
  associate(prm => param(instance), stt => state(instance))
  outputsloop: do o = 1,size(prm%output)
    select case(trim(prm%output(o)))
 
      case('resistance_slip')
        if(prm%sum_N_sl>0) call results_writedataset(group,stt%xi_slip,   'xi_sl', &
                                                     'resistance against plastic slip','Pa')
      case('accumulatedshear_slip')
        if(prm%sum_N_sl>0) call results_writedataset(group,stt%gamma_slip,'gamma_sl', &
                                                     'plastic shear','1')
 
      case('resistance_twin')
        if(prm%sum_N_tw>0) call results_writedataset(group,stt%xi_twin,   'xi_tw', &
                                                     'resistance against twinning','Pa')
      case('accumulatedshear_twin')
        if(prm%sum_N_tw>0) call results_writedataset(group,stt%gamma_twin,'gamma_tw', &
                                                     'twinning shear','1')
 
    end select
  enddo outputsloop
  end associate
 
end subroutine plastic_phenopowerlaw_results
 
 
!--------------------------------------------------------------------------------------------------
!         stress.
! NOTE: Against the common convention, the result (i.e. intent(out)) variables are the last to
! have the optional arguments at the end.
!--------------------------------------------------------------------------------------------------
pure subroutine kinetics_slip(Mp,instance,of, &
                              gdot_slip_pos,gdot_slip_neg,dgdot_dtau_slip_pos,dgdot_dtau_slip_neg)
 
  real(preal), dimension(3,3),  intent(in) :: &
    mp
  integer,                      intent(in) :: &
    instance, &
    of
 
  real(preal),                  intent(out), dimension(param(instance)%sum_N_sl) :: &
    gdot_slip_pos, &
    gdot_slip_neg
  real(preal),                  intent(out), optional, dimension(param(instance)%sum_N_sl) :: &
    dgdot_dtau_slip_pos, &
    dgdot_dtau_slip_neg
 
  real(preal), dimension(param(instance)%sum_N_sl) :: &
    tau_slip_pos, &
    tau_slip_neg
  integer :: i
 
  associate(prm => param(instance), stt => state(instance))
 
  do i = 1, prm%sum_N_sl
    tau_slip_pos(i) =       math_tensordot(mp,prm%nonSchmid_pos(1:3,1:3,i))
    tau_slip_neg(i) = merge(math_tensordot(mp,prm%nonSchmid_neg(1:3,1:3,i)), &
                            0.0_preal, prm%nonSchmidActive)
  enddo
 
  where(dneq0(tau_slip_pos))
    gdot_slip_pos = prm%gdot0_slip * merge(0.5_preal,1.0_preal, prm%nonSchmidActive) &              ! 1/2 if non-Schmid active
                  * sign(abs(tau_slip_pos/stt%xi_slip(:,of))**prm%n_slip,  tau_slip_pos)
  else where
    gdot_slip_pos = 0.0_preal
  end where
 
  where(dneq0(tau_slip_neg))
    gdot_slip_neg = prm%gdot0_slip * 0.5_preal &                                                    ! only used if non-Schmid active, always 1/2
                  * sign(abs(tau_slip_neg/stt%xi_slip(:,of))**prm%n_slip,  tau_slip_neg)
  else where
    gdot_slip_neg = 0.0_preal
  end where
 
  if (present(dgdot_dtau_slip_pos)) then
    where(dneq0(gdot_slip_pos))
      dgdot_dtau_slip_pos = gdot_slip_pos*prm%n_slip/tau_slip_pos
    else where
      dgdot_dtau_slip_pos = 0.0_preal
    end where
  endif
  if (present(dgdot_dtau_slip_neg)) then
    where(dneq0(gdot_slip_neg))
      dgdot_dtau_slip_neg = gdot_slip_neg*prm%n_slip/tau_slip_neg
    else where
      dgdot_dtau_slip_neg = 0.0_preal
    end where
  endif
  end associate
 
end subroutine kinetics_slip
 
 
!--------------------------------------------------------------------------------------------------
!         stress. Twinning is assumed to take place only in untwinned volume.
! NOTE: Against the common convention, the result (i.e. intent(out)) variables are the last to
! have the optional arguments at the end.
!--------------------------------------------------------------------------------------------------
pure subroutine kinetics_twin(Mp,instance,of,&
                              gdot_twin,dgdot_dtau_twin)
 
  real(preal), dimension(3,3),  intent(in) :: &
    mp
  integer,                      intent(in) :: &
    instance, &
    of
 
  real(preal), dimension(param(instance)%sum_N_tw), intent(out) :: &
    gdot_twin
  real(preal), dimension(param(instance)%sum_N_tw), intent(out), optional :: &
    dgdot_dtau_twin
 
  real(preal), dimension(param(instance)%sum_N_tw) :: &
    tau_twin
  integer :: i
 
  associate(prm => param(instance), stt => state(instance))
 
  do i = 1, prm%sum_N_tw
    tau_twin(i)  = math_tensordot(mp,prm%P_tw(1:3,1:3,i))
  enddo
 
  where(tau_twin > 0.0_preal)
    gdot_twin = (1.0_preal-sum(stt%gamma_twin(:,of)/prm%gamma_twin_char)) &                         ! only twin in untwinned volume fraction
              * prm%gdot0_twin*(abs(tau_twin)/stt%xi_twin(:,of))**prm%n_twin
  else where
    gdot_twin = 0.0_preal
  end where
 
  if (present(dgdot_dtau_twin)) then
    where(dneq0(gdot_twin))
      dgdot_dtau_twin = gdot_twin*prm%n_twin/tau_twin
    else where
      dgdot_dtau_twin = 0.0_preal
    end where
  endif
 
  end associate
 
end subroutine kinetics_twin
 
end submodule plastic_phenopowerlaw
# 40 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_kinehardening.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
submodule(constitutive) plastic_kinehardening
 
  type :: tparameters
    real(preal) :: &
      gdot0 = 1.0_preal, &                                                                          
      n     = 1.0_preal                                                                             
    real(preal),              allocatable, dimension(:) :: &
      theta0, &                                                                                     !< initial hardening rate of forward stress for each slip
      theta1, &                                                                                     !< asymptotic hardening rate of forward stress for each slip
      theta0_b, &                                                                                   !< initial hardening rate of back stress for each slip
      theta1_b, &                                                                                   !< asymptotic hardening rate of back stress for each slip
      tau1, &
      tau1_b
    real(preal),              allocatable, dimension(:,:) :: &
      interaction_slipslip
    real(preal),              allocatable, dimension(:,:,:) :: &
      p, &
      nonschmid_pos, &
      nonschmid_neg
    integer :: &
      sum_n_sl, &                                                                                   !< total number of active slip system
      of_debug = 0
    logical :: &
      nonschmidactive = .false.
    character(len=pStringLen), allocatable, dimension(:) :: &
      output
  end type tparameters
 
  type :: tkinehardeningstate
    real(preal), pointer, dimension(:,:) :: &                                                       !< vectors along NipcMyInstance
      crss, &                                                                                       !< critical resolved stress
      crss_back, &                                                                                  !< critical resolved back stress
      sense, &                                                                                      !< sense of acting shear stress (-1 or +1)
      chi0, &                                                                                       !< backstress at last switch of stress sense
      gamma0, &                                                                                     !< accumulated shear at last switch of stress sense
      accshear
  end type tkinehardeningstate
 
!--------------------------------------------------------------------------------------------------
! containers for parameters and state
  type(tparameters),         allocatable, dimension(:) :: param
  type(tkinehardeningstate), allocatable, dimension(:) :: &
    dotstate, &
    deltastate, &
    state
 
contains
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine plastic_kinehardening_init
 
  integer :: &
    ninstance, &
    p, o, &
    nipcmyphase, &
    sizestate, sizedeltastate, sizedotstate, &
    startindex, endindex
  integer,     dimension(:), allocatable :: &
    n_sl
  real(preal), dimension(:), allocatable :: &
    xi_0, &                                                                                         !< initial resistance against plastic flow
    a
  character(len=pStringLen) :: &
    extmsg = ''
 
  write(6,'(/,a)') ' <<<+-  plastic_'//plasticity_kinehardening_label//' init  -+>>>'; flush(6)
 
  ninstance = count(phase_plasticity == plasticity_kinehardening_id)
  if (iand(debug_level(debug_constitutive),debug_levelbasic) /= 0) &
    write(6,'(a16,1x,i5,/)') '# instances:',ninstance
 
  allocate(param(ninstance))
  allocate(state(ninstance))
  allocate(dotstate(ninstance))
  allocate(deltastate(ninstance))
 
  do p = 1, size(phase_plasticityinstance)
    if (phase_plasticity(p) /= plasticity_kinehardening_id) cycle
    associate(prm => param(phase_plasticityinstance(p)), &
              dot => dotstate(phase_plasticityinstance(p)), &
              dlt => deltastate(phase_plasticityinstance(p)), &
              stt => state(phase_plasticityinstance(p)),&
              config => config_phase(p))
 
    prm%output = config%getStrings('(output)',defaultval=emptystringarray)
 
 
 
 
 
 
 
!--------------------------------------------------------------------------------------------------
! slip related parameters
    n_sl         = config%getInts('nslip',defaultval=emptyintarray)
    prm%sum_N_sl = sum(abs(n_sl))
    slipactive: if (prm%sum_N_sl > 0) then
      prm%P = lattice_schmidmatrix_slip(n_sl,config%getString('lattice_structure'),&
                                        config%getFloat('c/a',defaultval=0.0_preal))
 
      if(trim(config%getString('lattice_structure')) == 'bcc') then
        a = config%getFloats('nonschmid_coefficients',defaultval = emptyrealarray)
        if(size(a) > 0) prm%nonSchmidActive = .true.
        prm%nonSchmid_pos  = lattice_nonschmidmatrix(n_sl,a,+1)
        prm%nonSchmid_neg  = lattice_nonschmidmatrix(n_sl,a,-1)
      else
        prm%nonSchmid_pos  = prm%P
        prm%nonSchmid_neg  = prm%P
      endif
      prm%interaction_SlipSlip = lattice_interaction_slipbyslip(n_sl, &
                                                                config%getFloats('interaction_slipslip'), &
                                                                config%getString('lattice_structure'))
 
      xi_0         = config%getFloats('crss0',    requiredsize=size(n_sl))
      prm%tau1     = config%getFloats('tau1',     requiredsize=size(n_sl))
      prm%tau1_b   = config%getFloats('tau1_b',   requiredsize=size(n_sl))
      prm%theta0   = config%getFloats('theta0',   requiredsize=size(n_sl))
      prm%theta1   = config%getFloats('theta1',   requiredsize=size(n_sl))
      prm%theta0_b = config%getFloats('theta0_b', requiredsize=size(n_sl))
      prm%theta1_b = config%getFloats('theta1_b', requiredsize=size(n_sl))
 
      prm%gdot0    = config%getFloat('gdot0')
      prm%n        = config%getFloat('n_slip')
 
      ! expand: family => system
      xi_0         = math_expand(xi_0,        n_sl)
      prm%tau1     = math_expand(prm%tau1,    n_sl)
      prm%tau1_b   = math_expand(prm%tau1_b,  n_sl)
      prm%theta0   = math_expand(prm%theta0,  n_sl)
      prm%theta1   = math_expand(prm%theta1,  n_sl)
      prm%theta0_b = math_expand(prm%theta0_b,n_sl)
      prm%theta1_b = math_expand(prm%theta1_b,n_sl)
 
!--------------------------------------------------------------------------------------------------
!  sanity checks
      if (    prm%gdot0  <= 0.0_preal)   extmsg = trim(extmsg)//' gdot0'
      if (    prm%n      <= 0.0_preal)   extmsg = trim(extmsg)//' n_slip'
      if (any(xi_0       <= 0.0_preal))  extmsg = trim(extmsg)//' crss0'
      if (any(prm%tau1   <= 0.0_preal))  extmsg = trim(extmsg)//' tau1'
      if (any(prm%tau1_b <= 0.0_preal))  extmsg = trim(extmsg)//' tau1_b'
 
      !ToDo: Any sensible checks for theta?
    else slipactive
      xi_0 = emptyrealarray
      allocate(prm%tau1,prm%tau1_b,prm%theta0,prm%theta1,prm%theta0_b,prm%theta1_b,source=emptyrealarray)
      allocate(prm%interaction_SlipSlip(0,0))
    endif slipactive
 
!--------------------------------------------------------------------------------------------------
! allocate state arrays
    nipcmyphase = count(material_phaseat == p) * discretization_nip
    sizedotstate   = size(['crss     ','crss_back', 'accshear ']) * prm%sum_N_sl
    sizedeltastate = size(['sense ',   'chi0  ',    'gamma0'   ]) * prm%sum_N_sl
    sizestate = sizedotstate + sizedeltastate
 
    call material_allocateplasticstate(p,nipcmyphase,sizestate,sizedotstate,sizedeltastate)
 
!--------------------------------------------------------------------------------------------------
! state aliases and initialization
    startindex = 1
    endindex   = prm%sum_N_sl
    stt%crss => plasticstate(p)%state   (startindex:endindex,:)
    stt%crss = spread(xi_0, 2, nipcmyphase)
    dot%crss => plasticstate(p)%dotState(startindex:endindex,:)
    plasticstate(p)%atol(startindex:endindex) = config%getFloat('atol_xi',defaultval=1.0_preal)
    if(any(plasticstate(p)%atol(startindex:endindex) < 0.0_preal)) extmsg = trim(extmsg)//' atol_xi'
 
    startindex = endindex + 1
    endindex   = endindex + prm%sum_N_sl
    stt%crss_back => plasticstate(p)%state   (startindex:endindex,:)
    dot%crss_back => plasticstate(p)%dotState(startindex:endindex,:)
    plasticstate(p)%atol(startindex:endindex) = config%getFloat('atol_xi',defaultval=1.0_preal)
 
    startindex = endindex + 1
    endindex   = endindex + prm%sum_N_sl
    stt%accshear => plasticstate(p)%state   (startindex:endindex,:)
    dot%accshear => plasticstate(p)%dotState(startindex:endindex,:)
    plasticstate(p)%atol(startindex:endindex) = config%getFloat('atol_gamma',defaultval=1.0e-6_preal)
    if(any(plasticstate(p)%atol(startindex:endindex) < 0.0_preal)) extmsg = trim(extmsg)//' atol_gamma'
    ! global alias
    plasticstate(p)%slipRate => plasticstate(p)%dotState(startindex:endindex,:)
 
    o = plasticstate(p)%offsetDeltaState
    startindex = endindex + 1
    endindex   = endindex + prm%sum_N_sl
    stt%sense => plasticstate(p)%state     (startindex  :endindex  ,:)
    dlt%sense => plasticstate(p)%deltaState(startindex-o:endindex-o,:)
 
    startindex = endindex + 1
    endindex   = endindex +  prm%sum_N_sl
    stt%chi0 => plasticstate(p)%state     (startindex  :endindex  ,:)
    dlt%chi0 => plasticstate(p)%deltaState(startindex-o:endindex-o,:)
 
    startindex = endindex + 1
    endindex   = endindex +  prm%sum_N_sl
    stt%gamma0 => plasticstate(p)%state     (startindex  :endindex  ,:)
    dlt%gamma0 => plasticstate(p)%deltaState(startindex-o:endindex-o,:)
 
    plasticstate(p)%state0 = plasticstate(p)%state                                                  ! ToDo: this could be done centrally
 
    end associate
 
!--------------------------------------------------------------------------------------------------
!  exit if any parameter is out of range
    if (extmsg /= '') call io_error(211,ext_msg=trim(extmsg)//'('//plasticity_kinehardening_label//')')
 
  enddo
 
 
end subroutine plastic_kinehardening_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure module subroutine plastic_kinehardening_lpanditstangent(lp,dlp_dmp,mp,instance,of)
 
  real(preal), dimension(3,3),     intent(out) :: &
    lp
  real(preal), dimension(3,3,3,3), intent(out) :: &
    dlp_dmp
 
  real(preal), dimension(3,3), intent(in) :: &
    mp
  integer,               intent(in) :: &
    instance, &
    of
 
  integer :: &
    i,k,l,m,n
  real(preal), dimension(param(instance)%sum_N_sl) :: &
    gdot_pos,gdot_neg, &
    dgdot_dtau_pos,dgdot_dtau_neg
 
  lp = 0.0_preal
  dlp_dmp = 0.0_preal
 
  associate(prm => param(instance))
 
  call kinetics(mp,instance,of,gdot_pos,gdot_neg,dgdot_dtau_pos,dgdot_dtau_neg)
 
  do i = 1, prm%sum_N_sl
    lp = lp + (gdot_pos(i)+gdot_neg(i))*prm%P(1:3,1:3,i)
    forall (k=1:3,l=1:3,m=1:3,n=1:3) &
      dlp_dmp(k,l,m,n) = dlp_dmp(k,l,m,n) &
                       + dgdot_dtau_pos(i) * prm%P(k,l,i) * prm%nonSchmid_pos(m,n,i) &
                       + dgdot_dtau_neg(i) * prm%P(k,l,i) * prm%nonSchmid_neg(m,n,i)
  enddo
 
  end associate
 
end subroutine plastic_kinehardening_lpanditstangent
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine plastic_kinehardening_dotstate(mp,instance,of)
 
  real(preal), dimension(3,3),  intent(in) :: &
    mp
  integer,                      intent(in) :: &
    instance, &
    of
 
  real(preal) :: &
    sumgamma
  real(preal), dimension(param(instance)%sum_N_sl) :: &
    gdot_pos,gdot_neg
 
 
  associate(prm => param(instance), stt => state(instance), dot => dotstate(instance))
 
  call kinetics(mp,instance,of,gdot_pos,gdot_neg)
  dot%accshear(:,of) = abs(gdot_pos+gdot_neg)
  sumgamma = sum(stt%accshear(:,of))
 
 
  dot%crss(:,of) = matmul(prm%interaction_SlipSlip,dot%accshear(:,of)) &
                 * (  prm%theta1 &
                     + (prm%theta0 - prm%theta1 + prm%theta0*prm%theta1*sumgamma/prm%tau1) &
                     * exp(-sumgamma*prm%theta0/prm%tau1) &
                   )
 
  dot%crss_back(:,of) = stt%sense(:,of)*dot%accshear(:,of) * &
           ( prm%theta1_b + &
             (prm%theta0_b - prm%theta1_b &
               + prm%theta0_b*prm%theta1_b/(prm%tau1_b+stt%chi0(:,of))*(stt%accshear(:,of)-stt%gamma0(:,of))&
             ) *exp(-(stt%accshear(:,of)-stt%gamma0(:,of)) *prm%theta0_b/(prm%tau1_b+stt%chi0(:,of))) &
           )
 
  end associate
 
end subroutine plastic_kinehardening_dotstate
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine plastic_kinehardening_deltastate(mp,instance,of)
 
  real(preal), dimension(3,3),  intent(in) :: &
    mp
  integer,                      intent(in) :: &
    instance, &
    of
 
  real(preal), dimension(param(instance)%sum_N_sl) :: &
    gdot_pos,gdot_neg, &
    sense
 
  associate(prm => param(instance), stt => state(instance), dlt => deltastate(instance))
 
  call kinetics(mp,instance,of,gdot_pos,gdot_neg)
  sense = merge(state(instance)%sense(:,of), &                                                      ! keep existing...
                sign(1.0_preal,gdot_pos+gdot_neg), &                                                ! ...or have a defined
                deq0(gdot_pos+gdot_neg,1e-10_preal))                                                ! current sense of shear direction
 
# 338 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_kinehardening.f90"
 
!--------------------------------------------------------------------------------------------------
! switch in sense of shear?
  where(dneq(sense,stt%sense(:,of),0.1_preal))
    dlt%sense (:,of) = sense - stt%sense(:,of)                                                      ! switch sense
    dlt%chi0  (:,of) = abs(stt%crss_back(:,of)) - stt%chi0(:,of)                                    ! remember current backstress magnitude
    dlt%gamma0(:,of) = stt%accshear(:,of) - stt%gamma0(:,of)                                        ! remember current accumulated shear
  else where
    dlt%sense (:,of) = 0.0_preal
    dlt%chi0  (:,of) = 0.0_preal
    dlt%gamma0(:,of) = 0.0_preal
  end where
 
  end associate
 
end subroutine plastic_kinehardening_deltastate
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine plastic_kinehardening_results(instance,group)
 
  integer,          intent(in) :: instance
  character(len=*), intent(in) :: group
 
  integer :: o
 
  associate(prm => param(instance), stt => state(instance))
  outputsloop: do o = 1,size(prm%output)
    select case(trim(prm%output(o)))
     case('resistance')
       if(prm%sum_N_sl>0) call results_writedataset(group,stt%crss,'xi_sl', &
                                                    'resistance against plastic slip','Pa')
     case('backstress')                                                                             ! ToDo: should be 'tau_back'
       if(prm%sum_N_sl>0) call results_writedataset(group,stt%crss_back,'tau_back', &
                                                    'back stress against plastic slip','Pa')
     case ('sense')
       if(prm%sum_N_sl>0) call results_writedataset(group,stt%sense,'sense_of_shear', &
                                                    'tbd','1')
     case ('chi0')
       if(prm%sum_N_sl>0) call results_writedataset(group,stt%chi0,'chi0', &
                                                    'tbd','Pa')
     case ('gamma0')
       if(prm%sum_N_sl>0) call results_writedataset(group,stt%gamma0,'gamma0', &
                                                    'tbd','1')
     case ('accumulatedshear')
       if(prm%sum_N_sl>0) call results_writedataset(group,stt%accshear,'gamma_sl', &
                                                    'plastic shear','1')
    end select
  enddo outputsloop
  end associate
 
end subroutine plastic_kinehardening_results
 
 
!--------------------------------------------------------------------------------------------------
!         stress.
! NOTE: Against the common convention, the result (i.e. intent(out)) variables are the last to
! have the optional arguments at the end.
!--------------------------------------------------------------------------------------------------
pure subroutine kinetics(Mp,instance,of, &
                         gdot_pos,gdot_neg,dgdot_dtau_pos,dgdot_dtau_neg)
 
  real(preal), dimension(3,3),  intent(in) :: &
    mp
  integer,                intent(in) :: &
    instance, &
    of
 
  real(preal),                  intent(out), dimension(param(instance)%sum_N_sl) :: &
    gdot_pos, &
    gdot_neg
  real(preal),                  intent(out), optional, dimension(param(instance)%sum_N_sl) :: &
    dgdot_dtau_pos, &
    dgdot_dtau_neg
 
  real(preal), dimension(param(instance)%sum_N_sl) :: &
    tau_pos, &
    tau_neg
  integer :: i
 
  associate(prm => param(instance), stt => state(instance))
 
  do i = 1, prm%sum_N_sl
    tau_pos(i) =       math_tensordot(mp,prm%nonSchmid_pos(1:3,1:3,i)) - stt%crss_back(i,of)
    tau_neg(i) = merge(math_tensordot(mp,prm%nonSchmid_neg(1:3,1:3,i)) - stt%crss_back(i,of), &
                       0.0_preal, prm%nonSchmidActive)
  enddo
 
  where(dneq0(tau_pos))
    gdot_pos = prm%gdot0 * merge(0.5_preal,1.0_preal, prm%nonSchmidActive) &                         ! 1/2 if non-Schmid active
             * sign(abs(tau_pos/stt%crss(:,of))**prm%n,  tau_pos)
  else where
    gdot_pos = 0.0_preal
  end where
 
  where(dneq0(tau_neg))
    gdot_neg = prm%gdot0 * 0.5_preal &                                                              ! only used if non-Schmid active, always 1/2
             * sign(abs(tau_neg/stt%crss(:,of))**prm%n,  tau_neg)
  else where
    gdot_neg = 0.0_preal
  end where
 
  if (present(dgdot_dtau_pos)) then
    where(dneq0(gdot_pos))
      dgdot_dtau_pos = gdot_pos*prm%n/tau_pos
    else where
      dgdot_dtau_pos = 0.0_preal
    end where
  endif
  if (present(dgdot_dtau_neg)) then
    where(dneq0(gdot_neg))
      dgdot_dtau_neg = gdot_neg*prm%n/tau_neg
    else where
      dgdot_dtau_neg = 0.0_preal
    end where
  endif
  end associate
 
end subroutine kinetics
 
end submodule plastic_kinehardening
# 41 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_dislotwin.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
submodule(constitutive) plastic_dislotwin
 
  real(preal), parameter :: &
    kb = 1.38e-23_preal                                                                             
 
  type :: tparameters
    real(preal) :: &
      mu                  = 1.0_preal, &                                                            
      nu                  = 1.0_preal, &                                                            
      d0                  = 1.0_preal, &                                                            
      qsd                 = 1.0_preal, &                                                            
      omega               = 1.0_preal, &                                                            
      d                   = 1.0_preal, &                                                            
      p_sb                = 1.0_preal, &                                                            
      q_sb                = 1.0_preal, &                                                            
      cedgedipmindistance = 1.0_preal, &                                                            
      i_tw                = 1.0_preal, &                                                            
      tau_0               = 1.0_preal, &                                                            
      l_tw                = 1.0_preal, &                                                            
      l_tr                = 1.0_preal, &                                                            
      xc_twin             = 1.0_preal, &                                                            
      xc_trans            = 1.0_preal, &                                                            
      v_cs                = 1.0_preal, &                                                            
      sbresistance        = 1.0_preal, &                                                            
      sbvelocity          = 1.0_preal, &                                                            
      e_sb                = 1.0_preal, &                                                            
      sfe_0k              = 1.0_preal, &                                                            
      dsfe_dt             = 1.0_preal, &                                                            
      gamma_fcc_hex       = 1.0_preal, &                                                            
      i_tr                = 1.0_preal, &                                                            
      h                   = 1.0_preal                                                               
    real(preal),               allocatable, dimension(:) :: &
      b_sl, &                                                                                       !< absolute length of burgers vector [m] for each slip system
      b_tw, &                                                                                       !< absolute length of burgers vector [m] for each twin system
      b_tr, &                                                                                       !< absolute length of burgers vector [m] for each transformation system
      delta_f,&                                                                                     !< activation energy for glide [J] for each slip system
      v0, &                                                                                         !< dislocation velocity prefactor [m/s] for each slip system
      dot_n_0_tw, &                                                                                 !< twin nucleation rate [1/m�s] for each twin system
      dot_N_0_tr, &                                                                                 !< trans nucleation rate [1/m³s] for each trans system
      t_tw, &                                                                                       !< twin thickness [m] for each twin system
      CLambdaSlip, &                                                                                !< Adj. parameter for distance between 2 forest dislocations for each slip system
      t_tr, &                                                                                       !< martensite lamellar thickness [m] for each trans system and instance
      p, &                                                                                          !< p-exponent in glide velocity
      q, &                                                                                          !< q-exponent in glide velocity
      r, &                                                                                          !< r-exponent in twin nucleation rate
      s, &                                                                                          !< s-exponent in trans nucleation rate
      gamma_char, &                                                                                 !< characteristic shear for twins
      B                                                                                             !< drag coefficient
    real(pReal),               allocatable, dimension(:,:) :: &
      h_sl_sl, &                                                                                    !<
      h_sl_tw, &                                                                                    !<
      h_tw_tw, &                                                                                    !<
      h_sl_tr, &                                                                                    !<
      h_tr_tr, &                                                                                    !<
      n0_sl, &                                                                                      !< slip system normal
      forestProjection, &
      C66
    real(pReal),               allocatable, dimension(:,:,:) :: &
      P_sl, &
      P_tw, &
      P_tr, &
      C66_tw, &
      C66_tr
    integer :: &
      sum_N_sl, &                                                                                   !< total number of active slip system
      sum_N_tw, &                                                                                   !< total number of active twin system
      sum_N_tr                                                                                      !< total number of active transformation system
    integer,                   allocatable, dimension(:,:) :: &
      fcc_twinNucleationSlipPair                                                                    ! ToDo: Better name? Is also use for trans
    character(len=pStringLen), allocatable, dimension(:) :: &
      output
    logical :: &
      ExtendedDislocations, &                                                                       !< consider split into partials for climb calculation
      fccTwinTransNucleation, &                                                                     !< twinning and transformation models are for fcc
      dipoleFormation                                                                               !< flag indicating consideration of dipole formation
  end type                                                                                          !< container type for internal constitutive parameters

  type :: tDislotwinState
    real(pReal),                  dimension(:,:),   pointer :: &
      rho_mob, &
      rho_dip, &
      gamma_sl, &
      f_tw, &
      f_tr
  end type tDislotwinState

  type :: tDislotwinMicrostructure
    real(pReal),                  dimension(:,:),   allocatable :: &
      Lambda_sl, &                                                                                  !< mean free path between 2 obstacles seen by a moving dislocation
      Lambda_tw, &                                                                                  !< mean free path between 2 obstacles seen by a growing twin
      Lambda_tr, &                                                                                  !< mean free path between 2 obstacles seen by a growing martensite
      tau_pass, &
      tau_hat_tw, &
      tau_hat_tr, &
      V_tw, &                                                                                       !< volume of a new twin
      V_tr, &                                                                                       !< volume of a new martensite disc
      tau_r_tw, &                                                                                   !< stress to bring partials close together (twin)
      tau_r_tr                                                                                      !< stress to bring partials close together (trans)
  end type tDislotwinMicrostructure

!--------------------------------------------------------------------------------------------------
! containers for parameters and state
  type(tParameters),              allocatable, dimension(:) :: param
  type(tDislotwinState),          allocatable, dimension(:) :: &
    dotState, &
    state
  type(tDislotwinMicrostructure), allocatable, dimension(:) :: dependentState

contains


!--------------------------------------------------------------------------------------------------
!> @brief Perform module initialization.
!> @details reads in material parameters, allocates arrays, and does sanity checks
!--------------------------------------------------------------------------------------------------
module subroutine plastic_dislotwin_init

  integer :: &
    Ninstance, &
    p, i, &
    NipcMyPhase, &
    sizeState, sizeDotState, &
    startIndex, endIndex
  integer,     dimension(:), allocatable :: &
    N_sl, N_tw, N_tr
  real(pReal), allocatable, dimension(:) :: &
    rho_mob_0, &                                                                                    !< initial unipolar dislocation density per slip system
    rho_dip_0                                                                                       !< initial dipole dislocation density per slip system
  character(len=pStringLen) :: &
    extmsg = ''

  write(6,'(/,a)') ' <<<+-  constitutive_'//PLASTICITY_DISLOTWIN_LABEL//' init  -+>>>'; flush(6)

  write(6,'(/,a)') ' Ma and Roters, Acta Materialia 52(12):3603–3612, 2004'
  write(6,'(a)')   ' https://doi.org/10.1016/j.actamat.2004.04.012'

  write(6,'(/,a)') ' Roters et al., Computational Materials Science 39:91–95, 2007'
  write(6,'(a)')   ' https://doi.org/10.1016/j.commatsci.2006.04.014'

  write(6,'(/,a)') ' Wong et al., Acta Materialia 118:140–151, 2016'
  write(6,'(a,/)') ' https://doi.org/10.1016/j.actamat.2016.07.032'

  Ninstance = count(phase_plasticity == PLASTICITY_DISLOTWIN_ID)

  if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0) &
    write(6,'(a16,1x,i5,/)') '# instances:',Ninstance

  allocate(param(Ninstance))
  allocate(state(Ninstance))
  allocate(dotState(Ninstance))
  allocate(dependentState(Ninstance))

  do p = 1, size(phase_plasticity)
    if (phase_plasticity(p) /= PLASTICITY_DISLOTWIN_ID) cycle
    associate(prm => param(phase_plasticityInstance(p)), &
              dot => dotState(phase_plasticityInstance(p)), &
              stt => state(phase_plasticityInstance(p)), &
              dst => dependentState(phase_plasticityInstance(p)), &
              config   => config_phase(p))

    prm%output = config%getStrings('(output)', defaultVal=emptyStringArray)

    ! This data is read in already in lattice
    prm%mu  = lattice_mu(p)
    prm%nu  = lattice_nu(p)
    prm%C66 = lattice_C66(1:6,1:6,p)

!--------------------------------------------------------------------------------------------------
! slip related parameters
    N_sl         = config%getInts('nslip',defaultVal=emptyIntArray)
    prm%sum_N_sl = sum(abs(N_sl))
    slipActive: if (prm%sum_N_sl > 0) then
      prm%P_sl    = lattice_SchmidMatrix_slip(N_sl,config%getString('lattice_structure'),&
                                              config%getFloat('c/a',defaultVal=0.0_pReal))
      prm%h_sl_sl = lattice_interaction_SlipBySlip(N_sl,config%getFloats('interaction_slipslip'), &
                                                   config%getString('lattice_structure'))
      prm%forestProjection = lattice_forestProjection_edge(N_sl,config%getString('lattice_structure'),&
                                                           config%getFloat('c/a',defaultVal=0.0_pReal))
      prm%forestProjection = transpose(prm%forestProjection)

      prm%n0_sl            = lattice_slip_normal(N_sl,config%getString('lattice_structure'),&
                                                 config%getFloat('c/a',defaultVal=0.0_pReal))
      prm%fccTwinTransNucleation = merge(.true., .false., lattice_structure(p) == lattice_FCC_ID) &
                                 .and. (N_sl(1) == 12)
      if(prm%fccTwinTransNucleation) prm%fcc_twinNucleationSlipPair = lattice_FCC_TWINNUCLEATIONSLIPPAIR

      rho_mob_0                = config%getFloats('rhoedge0',   requiredSize=size(N_sl))
      rho_dip_0                = config%getFloats('rhoedgedip0',requiredSize=size(N_sl))
      prm%v0                   = config%getFloats('v0',         requiredSize=size(N_sl))
      prm%b_sl                 = config%getFloats('slipburgers',requiredSize=size(N_sl))
      prm%Delta_F              = config%getFloats('qedge',      requiredSize=size(N_sl))
      prm%CLambdaSlip          = config%getFloats('clambdaslip',requiredSize=size(N_sl))
      prm%p                    = config%getFloats('p_slip',     requiredSize=size(N_sl))
      prm%q                    = config%getFloats('q_slip',     requiredSize=size(N_sl))
      prm%B                    = config%getFloats('b',          requiredSize=size(N_sl), &
                                                  defaultVal=[(0.0_pReal, i=1,size(N_sl))])

      prm%tau_0                = config%getFloat('solidsolutionstrength')
      prm%CEdgeDipMinDistance  = config%getFloat('cedgedipmindistance')
      prm%D0                   = config%getFloat('d0')
      prm%Qsd                  = config%getFloat('qsd')
      prm%ExtendedDislocations = config%keyExists('/extend_dislocations/')
      if (prm%ExtendedDislocations) then
        prm%SFE_0K             = config%getFloat('sfe_0k')
        prm%dSFE_dT            = config%getFloat('dsfe_dt')
      endif

      prm%dipoleformation = .not. config%keyExists('/nodipoleformation/')

      ! multiplication factor according to crystal structure (nearest neighbors bcc vs fcc/hex)
      ! details: Argon & Moffat, Acta Metallurgica, Vol. 29, pg 293 to 299, 1981
      prm%omega = config%getFloat('omega',  defaultVal = 1000.0_pReal) &
                * merge(12.0_pReal,8.0_pReal,any(lattice_structure(p) == [lattice_FCC_ID,lattice_HEX_ID]))

      ! expand: family => system
      rho_mob_0        = math_expand(rho_mob_0,       N_sl)
      rho_dip_0        = math_expand(rho_dip_0,       N_sl)
      prm%v0           = math_expand(prm%v0,          N_sl)
      prm%b_sl         = math_expand(prm%b_sl,        N_sl)
      prm%Delta_F      = math_expand(prm%Delta_F,     N_sl)
      prm%CLambdaSlip  = math_expand(prm%CLambdaSlip, N_sl)
      prm%p            = math_expand(prm%p,           N_sl)
      prm%q            = math_expand(prm%q,           N_sl)
      prm%B            = math_expand(prm%B,           N_sl)

      ! sanity checks
      if (    prm%D0           <= 0.0_pReal)          extmsg = trim(extmsg)//' D0'
      if (    prm%Qsd          <= 0.0_pReal)          extmsg = trim(extmsg)//' Qsd'
      if (any(rho_mob_0        <  0.0_pReal))         extmsg = trim(extmsg)//' rho_mob_0'
      if (any(rho_dip_0        <  0.0_pReal))         extmsg = trim(extmsg)//' rho_dip_0'
      if (any(prm%v0           <  0.0_pReal))         extmsg = trim(extmsg)//' v0'
      if (any(prm%b_sl         <= 0.0_pReal))         extmsg = trim(extmsg)//' b_sl'
      if (any(prm%Delta_F      <= 0.0_pReal))         extmsg = trim(extmsg)//' Delta_F'
      if (any(prm%CLambdaSlip  <= 0.0_pReal))         extmsg = trim(extmsg)//' CLambdaSlip'
      if (any(prm%B            <  0.0_pReal))         extmsg = trim(extmsg)//' B'
      if (any(prm%p<=0.0_pReal .or. prm%p>1.0_pReal)) extmsg = trim(extmsg)//' p'
      if (any(prm%q< 1.0_pReal .or. prm%q>2.0_pReal)) extmsg = trim(extmsg)//' q'
    else slipActive
      rho_mob_0 = emptyRealArray; rho_dip_0 = emptyRealArray
      allocate(prm%b_sl,prm%Delta_F,prm%v0,prm%CLambdaSlip,prm%p,prm%q,prm%B,source=emptyRealArray)
      allocate(prm%forestProjection(0,0),prm%h_sl_sl(0,0))
    endif slipActive

!--------------------------------------------------------------------------------------------------
! twin related parameters
    N_tw         = config%getInts('ntwin', defaultVal=emptyIntArray)
    prm%sum_N_tw = sum(abs(N_tw))
    twinActive: if (prm%sum_N_tw > 0) then
      prm%P_tw  = lattice_SchmidMatrix_twin(N_tw,config%getString('lattice_structure'),&
                                                   config%getFloat('c/a',defaultVal=0.0_pReal))
      prm%h_tw_tw   = lattice_interaction_TwinByTwin(N_tw,&
                                                     config%getFloats('interaction_twintwin'), &
                                                     config%getString('lattice_structure'))

      prm%b_tw      = config%getFloats('twinburgers',  requiredSize=size(N_tw))
      prm%t_tw      = config%getFloats('twinsize',     requiredSize=size(N_tw))
      prm%r         = config%getFloats('r_twin',       requiredSize=size(N_tw))

      prm%xc_twin   = config%getFloat('xc_twin')
      prm%L_tw      = config%getFloat('l0_twin')
      prm%i_tw      = config%getFloat('cmfptwin')

      prm%gamma_char= lattice_characteristicShear_Twin(N_tw,config%getString('lattice_structure'),&
                                                       config%getFloat('c/a',defaultVal=0.0_pReal))

      prm%C66_tw    = lattice_C66_twin(N_tw,prm%C66,config%getString('lattice_structure'),&
                                       config%getFloat('c/a',defaultVal=0.0_pReal))

      if (.not. prm%fccTwinTransNucleation) then
        prm%dot_N_0_tw = config%getFloats('ndot0_twin')
        prm%dot_N_0_tw = math_expand(prm%dot_N_0_tw,N_tw)
      endif

      ! expand: family => system
      prm%b_tw = math_expand(prm%b_tw,N_tw)
      prm%t_tw = math_expand(prm%t_tw,N_tw)
      prm%r    = math_expand(prm%r,N_tw)

      ! sanity checks
      if (    prm%xc_twin       < 0.0_pReal)  extmsg = trim(extmsg)//' xc_twin'
      if (    prm%L_tw          < 0.0_pReal)  extmsg = trim(extmsg)//' L_tw'
      if (    prm%i_tw          < 0.0_pReal)  extmsg = trim(extmsg)//' i_tw'
      if (any(prm%b_tw          < 0.0_pReal)) extmsg = trim(extmsg)//' b_tw'
      if (any(prm%t_tw          < 0.0_pReal)) extmsg = trim(extmsg)//' t_tw'
      if (any(prm%r             < 0.0_pReal)) extmsg = trim(extmsg)//' r'
      if (.not. prm%fccTwinTransNucleation) then
        if (any(prm%dot_N_0_tw  < 0.0_pReal)) extmsg = trim(extmsg)//' dot_N_0_tw'
      endif
    else twinActive
      allocate(prm%gamma_char,prm%b_tw,prm%dot_N_0_tw,prm%t_tw,prm%r,source=emptyRealArray)
      allocate(prm%h_tw_tw(0,0))
    endif twinActive

!--------------------------------------------------------------------------------------------------
! transformation related parameters
    N_tr         = config%getInts('ntrans', defaultVal=emptyIntArray)
    prm%sum_N_tr = sum(abs(N_tr))
    transActive: if (prm%sum_N_tr > 0) then
      prm%b_tr = config%getFloats('transburgers')
      prm%b_tr = math_expand(prm%b_tr,N_tr)

      prm%h             = config%getFloat('transstackheight', defaultVal=0.0_pReal) ! ToDo: How to handle that???
      prm%i_tr          = config%getFloat('cmfptrans',        defaultVal=0.0_pReal) ! ToDo: How to handle that???
      prm%gamma_fcc_hex = config%getFloat('deltag')
      prm%xc_trans      = config%getFloat('xc_trans',         defaultVal=0.0_pReal) ! ToDo: How to handle that???
      prm%L_tr          = config%getFloat('l0_trans')

      prm%h_tr_tr = lattice_interaction_TransByTrans(N_tr,config%getFloats('interaction_transtrans'), &
                                                     config%getString('lattice_structure'))

      prm%C66_tr  = lattice_C66_trans(N_tr,prm%C66,config%getString('trans_lattice_structure'), &
                                      0.0_pReal, &
                                      config%getFloat('a_bcc', defaultVal=0.0_pReal), &
                                      config%getFloat('a_fcc', defaultVal=0.0_pReal))

      prm%P_tr    = lattice_SchmidMatrix_trans(N_tr,config%getString('trans_lattice_structure'), &
                                               0.0_pReal, &
                                               config%getFloat('a_bcc', defaultVal=0.0_pReal), &
                                               config%getFloat('a_fcc', defaultVal=0.0_pReal))

      if (lattice_structure(p) /= lattice_FCC_ID) then
        prm%dot_N_0_tr = config%getFloats('ndot0_trans')
        prm%dot_N_0_tr = math_expand(prm%dot_N_0_tr,N_tr)
      endif
      prm%t_tr = config%getFloats('lamellarsize')
      prm%t_tr = math_expand(prm%t_tr,N_tr)
      prm%s    = config%getFloats('s_trans',defaultVal=[0.0_pReal])
      prm%s    = math_expand(prm%s,N_tr)

      ! sanity checks
      if (    prm%xc_trans      < 0.0_pReal)  extmsg = trim(extmsg)//' xc_trans'
      if (    prm%L_tr          < 0.0_pReal)  extmsg = trim(extmsg)//' L_tr'
      if (    prm%i_tr          < 0.0_pReal)  extmsg = trim(extmsg)//' i_tr'
      if (any(prm%t_tr          < 0.0_pReal)) extmsg = trim(extmsg)//' t_tr'
      if (any(prm%s             < 0.0_pReal)) extmsg = trim(extmsg)//' s'
      if (lattice_structure(p) /= lattice_FCC_ID) then
        if (any(prm%dot_N_0_tr  < 0.0_pReal)) extmsg = trim(extmsg)//' dot_N_0_tr'
      endif
    else transActive
      allocate(prm%s,prm%b_tr,prm%t_tr,prm%dot_N_0_tr,source=emptyRealArray)
      allocate(prm%h_tr_tr(0,0))
    endif transActive

!--------------------------------------------------------------------------------------------------
! shearband related parameters
    prm%sbVelocity = config%getFloat('shearbandvelocity',defaultVal=0.0_pReal)
    if (prm%sbVelocity > 0.0_pReal) then
      prm%sbResistance = config%getFloat('shearbandresistance')
      prm%E_sb         = config%getFloat('qedgepersbsystem')
      prm%p_sb         = config%getFloat('p_shearband')
      prm%q_sb         = config%getFloat('q_shearband')

      ! sanity checks
      if (prm%sbResistance  <  0.0_pReal) extmsg = trim(extmsg)//' shearbandresistance'
      if (prm%E_sb          <  0.0_pReal) extmsg = trim(extmsg)//' qedgepersbsystem'
      if (prm%p_sb          <= 0.0_pReal) extmsg = trim(extmsg)//' p_shearband'
      if (prm%q_sb          <= 0.0_pReal) extmsg = trim(extmsg)//' q_shearband'
    endif

!--------------------------------------------------------------------------------------------------
! parameters required for several mechanisms and their interactions
    if(prm%sum_N_sl + prm%sum_N_tw + prm%sum_N_tw > 0) &
      prm%D = config%getFloat('grainsize')

    twinOrSlipActive: if (prm%sum_N_tw + prm%sum_N_tr > 0) then
      prm%SFE_0K  = config%getFloat('sfe_0k')
      prm%dSFE_dT = config%getFloat('dsfe_dt')
      prm%V_cs    = config%getFloat('vcrossslip')
    endif twinOrSlipActive

    slipAndTwinActive: if (prm%sum_N_sl * prm%sum_N_tw > 0) then
      prm%h_sl_tw = lattice_interaction_SlipByTwin(N_sl,N_tw,&
                                                   config%getFloats('interaction_sliptwin'), &
                                                   config%getString('lattice_structure'))
      if (prm%fccTwinTransNucleation .and. size(N_tw) /= 1) extmsg = trim(extmsg)//' interaction_sliptwin'
    endif slipAndTwinActive

    slipAndTransActive: if (prm%sum_N_sl * prm%sum_N_tr > 0) then
      prm%h_sl_tr = lattice_interaction_SlipByTrans(N_sl,N_tr,&
                                                    config%getFloats('interaction_sliptrans'), &
                                            config%getString('lattice_structure'))
      if (prm%fccTwinTransNucleation .and. size(N_tr) /= 1) extmsg = trim(extmsg)//' interaction_sliptrans'
    endif slipAndTransActive

!--------------------------------------------------------------------------------------------------
! allocate state arrays
    NipcMyPhase  = count(material_phaseAt == p) * discretization_nIP
    sizeDotState = size(['rho_mob ','rho_dip ','gamma_sl']) * prm%sum_N_sl &
                 + size(['f_tw'])                           * prm%sum_N_tw &
                 + size(['f_tr'])                           * prm%sum_N_tr
    sizeState = sizeDotState

    call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,0)

!--------------------------------------------------------------------------------------------------
! locally defined state aliases and initialization of state0 and atol
    startIndex = 1
    endIndex   = prm%sum_N_sl
    stt%rho_mob=>plasticState(p)%state(startIndex:endIndex,:)
    stt%rho_mob= spread(rho_mob_0,2,NipcMyPhase)
    dot%rho_mob=>plasticState(p)%dotState(startIndex:endIndex,:)
    plasticState(p)%atol(startIndex:endIndex) = config%getFloat('atol_rho',defaultVal=1.0_pReal)
    if (any(plasticState(p)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_rho'

    startIndex = endIndex + 1
    endIndex   = endIndex + prm%sum_N_sl
    stt%rho_dip=>plasticState(p)%state(startIndex:endIndex,:)
    stt%rho_dip= spread(rho_dip_0,2,NipcMyPhase)
    dot%rho_dip=>plasticState(p)%dotState(startIndex:endIndex,:)
    plasticState(p)%atol(startIndex:endIndex) = config%getFloat('atol_rho',defaultVal=1.0_pReal)

    startIndex = endIndex + 1
    endIndex   = endIndex + prm%sum_N_sl
    stt%gamma_sl=>plasticState(p)%state(startIndex:endIndex,:)
    dot%gamma_sl=>plasticState(p)%dotState(startIndex:endIndex,:)
    plasticState(p)%atol(startIndex:endIndex) = 1.0e-2_pReal
    ! global alias
    plasticState(p)%slipRate        => plasticState(p)%dotState(startIndex:endIndex,:)

    startIndex = endIndex + 1
    endIndex   = endIndex + prm%sum_N_tw
    stt%f_tw=>plasticState(p)%state(startIndex:endIndex,:)
    dot%f_tw=>plasticState(p)%dotState(startIndex:endIndex,:)
    plasticState(p)%atol(startIndex:endIndex) = config%getFloat('f_twin',defaultVal=1.0e-7_pReal)
    if (any(plasticState(p)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' f_twin'

    startIndex = endIndex + 1
    endIndex   = endIndex + prm%sum_N_tr
    stt%f_tr=>plasticState(p)%state(startIndex:endIndex,:)
    dot%f_tr=>plasticState(p)%dotState(startIndex:endIndex,:)
    plasticState(p)%atol(startIndex:endIndex) = config%getFloat('f_trans',defaultVal=1.0e-6_pReal)
    if (any(plasticState(p)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' f_trans'

    allocate(dst%Lambda_sl             (prm%sum_N_sl,NipcMyPhase),source=0.0_pReal)
    allocate(dst%tau_pass              (prm%sum_N_sl,NipcMyPhase),source=0.0_pReal)

    allocate(dst%Lambda_tw             (prm%sum_N_tw,NipcMyPhase),source=0.0_pReal)
    allocate(dst%tau_hat_tw            (prm%sum_N_tw,NipcMyPhase),source=0.0_pReal)
    allocate(dst%tau_r_tw              (prm%sum_N_tw,NipcMyPhase),source=0.0_pReal)
    allocate(dst%V_tw                  (prm%sum_N_tw,NipcMyPhase),source=0.0_pReal)

    allocate(dst%Lambda_tr             (prm%sum_N_tr,NipcMyPhase),source=0.0_pReal)
    allocate(dst%tau_hat_tr            (prm%sum_N_tr,NipcMyPhase),source=0.0_pReal)
    allocate(dst%tau_r_tr              (prm%sum_N_tr,NipcMyPhase),source=0.0_pReal)
    allocate(dst%V_tr                  (prm%sum_N_tr,NipcMyPhase),source=0.0_pReal)

    plasticState(p)%state0 = plasticState(p)%state                                                  ! ToDo: this could be done centrally

    end associate

!--------------------------------------------------------------------------------------------------
!  exit if any parameter is out of range
    if (extmsg /= '') call IO_error(211,ext_msg=trim(extmsg)//'('//PLASTICITY_DISLOTWIN_LABEL//')')

  enddo

end subroutine plastic_dislotwin_init


!--------------------------------------------------------------------------------------------------
!> @brief Return the homogenized elasticity matrix.
!--------------------------------------------------------------------------------------------------
module function plastic_dislotwin_homogenizedC(ipc,ip,el) result(homogenizedC)

  real(pReal), dimension(6,6) :: &
    homogenizedC
  integer,     intent(in) :: &
    ipc, &                                                                                          !< component-ID of integration point
    ip, &                                                                                           !< integration point
    el                                                                                              !< element

  integer :: i, &
             of
  real(pReal) :: f_unrotated

  of = material_phasememberAt(ipc,ip,el)
  associate(prm => param(phase_plasticityInstance(material_phaseAt(ipc,el))),&
            stt => state(phase_plasticityInstance(material_phaseAT(ipc,el))))

  f_unrotated = 1.0_pReal &
              - sum(stt%f_tw(1:prm%sum_N_tw,of)) &
              - sum(stt%f_tr(1:prm%sum_N_tr,of))

  homogenizedC = f_unrotated * prm%C66
  do i=1,prm%sum_N_tw
    homogenizedC = homogenizedC &
                 + stt%f_tw(i,of)*prm%C66_tw(1:6,1:6,i)
  enddo
  do i=1,prm%sum_N_tr
    homogenizedC = homogenizedC &
                 + stt%f_tr(i,of)*prm%C66_tr(1:6,1:6,i)
  enddo

  end associate

end function plastic_dislotwin_homogenizedC


!--------------------------------------------------------------------------------------------------
!> @brief Calculate plastic velocity gradient and its tangent.
!--------------------------------------------------------------------------------------------------
module subroutine plastic_dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,T,instance,of)

  real(pReal), dimension(3,3),     intent(out) :: Lp
  real(pReal), dimension(3,3,3,3), intent(out) :: dLp_dMp
  real(pReal), dimension(3,3),     intent(in)  :: Mp
  integer,                         intent(in)  :: instance,of
  real(pReal),                     intent(in)  :: T

  integer :: i,k,l,m,n
  real(pReal) :: &
     f_unrotated,StressRatio_p,&
     BoltzmannRatio, &
     ddot_gamma_dtau, &
     tau
  real(pReal), dimension(param(instance)%sum_N_sl) :: &
    dot_gamma_sl,ddot_gamma_dtau_slip
  real(pReal), dimension(param(instance)%sum_N_tw) :: &
    dot_gamma_twin,ddot_gamma_dtau_twin
  real(pReal), dimension(param(instance)%sum_N_tr) :: &
    dot_gamma_tr,ddot_gamma_dtau_trans
  real(pReal):: dot_gamma_sb
  real(pReal), dimension(3,3) :: eigVectors, P_sb
  real(pReal), dimension(3)   :: eigValues
  real(pReal), dimension(3,6), parameter :: &
    sb_sComposition = &
      reshape(real([&
         1, 0, 1, &
         1, 0,-1, &
         1, 1, 0, &
         1,-1, 0, &
         0, 1, 1, &
         0, 1,-1  &
         ],pReal),[ 3,6]), &
    sb_mComposition = &
      reshape(real([&
         1, 0,-1, &
         1, 0,+1, &
         1,-1, 0, &
         1, 1, 0, &
         0, 1,-1, &
         0, 1, 1  &
         ],pReal),[ 3,6])

  associate(prm => param(instance), stt => state(instance))

  f_unrotated = 1.0_pReal &
              - sum(stt%f_tw(1:prm%sum_N_tw,of)) &
              - sum(stt%f_tr(1:prm%sum_N_tr,of))

  Lp = 0.0_pReal
  dLp_dMp = 0.0_pReal

  call kinetics_slip(Mp,T,instance,of,dot_gamma_sl,ddot_gamma_dtau_slip)
  slipContribution: do i = 1, prm%sum_N_sl
    Lp = Lp + dot_gamma_sl(i)*prm%P_sl(1:3,1:3,i)
    forall (k=1:3,l=1:3,m=1:3,n=1:3) &
      dLp_dMp(k,l,m,n) = dLp_dMp(k,l,m,n) &
                       + ddot_gamma_dtau_slip(i) * prm%P_sl(k,l,i) * prm%P_sl(m,n,i)
  enddo slipContribution

  !ToDo: Why do this before shear banding?
  Lp      = Lp      * f_unrotated
  dLp_dMp = dLp_dMp * f_unrotated

  shearBandingContribution: if(dNeq0(prm%sbVelocity)) then

    BoltzmannRatio = prm%E_sb/(kB*T)
    call math_eigh33(Mp,eigValues,eigVectors)                                                       ! is Mp symmetric by design?

    do i = 1,6
      P_sb = 0.5_pReal * math_outer(matmul(eigVectors,sb_sComposition(1:3,i)),&
                                    matmul(eigVectors,sb_mComposition(1:3,i)))
      tau = math_tensordot(Mp,P_sb)

      significantShearBandStress: if (abs(tau) > tol_math_check) then
        StressRatio_p = (abs(tau)/prm%sbResistance)**prm%p_sb
        dot_gamma_sb = sign(prm%sbVelocity*exp(-BoltzmannRatio*(1-StressRatio_p)**prm%q_sb), tau)
        ddot_gamma_dtau = abs(dot_gamma_sb)*BoltzmannRatio* prm%p_sb*prm%q_sb/ prm%sbResistance &
                   * (abs(tau)/prm%sbResistance)**(prm%p_sb-1.0_pReal) &
                   * (1.0_pReal-StressRatio_p)**(prm%q_sb-1.0_pReal)

        Lp = Lp + dot_gamma_sb * P_sb
        forall (k=1:3,l=1:3,m=1:3,n=1:3) &
          dLp_dMp(k,l,m,n) = dLp_dMp(k,l,m,n) &
                           + ddot_gamma_dtau * P_sb(k,l) * P_sb(m,n)
      endif significantShearBandStress
    enddo

  endif shearBandingContribution

  call kinetics_twin(Mp,T,dot_gamma_sl,instance,of,dot_gamma_twin,ddot_gamma_dtau_twin)
  twinContibution: do i = 1, prm%sum_N_tw
    Lp = Lp + dot_gamma_twin(i)*prm%P_tw(1:3,1:3,i) * f_unrotated
    forall (k=1:3,l=1:3,m=1:3,n=1:3) &
      dLp_dMp(k,l,m,n) = dLp_dMp(k,l,m,n) &
                       + ddot_gamma_dtau_twin(i)* prm%P_tw(k,l,i)*prm%P_tw(m,n,i) * f_unrotated
  enddo twinContibution

  call kinetics_trans(Mp,T,dot_gamma_sl,instance,of,dot_gamma_tr,ddot_gamma_dtau_trans)
  transContibution: do i = 1, prm%sum_N_tr
    Lp = Lp + dot_gamma_tr(i)*prm%P_tr(1:3,1:3,i) * f_unrotated
    forall (k=1:3,l=1:3,m=1:3,n=1:3) &
      dLp_dMp(k,l,m,n) = dLp_dMp(k,l,m,n) &
                       + ddot_gamma_dtau_trans(i)* prm%P_tr(k,l,i)*prm%P_tr(m,n,i) * f_unrotated
  enddo transContibution


  end associate

end subroutine plastic_dislotwin_LpAndItsTangent


!--------------------------------------------------------------------------------------------------
!> @brief Calculate the rate of change of microstructure.
!--------------------------------------------------------------------------------------------------
module subroutine plastic_dislotwin_dotState(Mp,T,instance,of)

  real(pReal), dimension(3,3),  intent(in):: &
    Mp                                                                                              !< Mandel stress
  real(pReal),                  intent(in) :: &
    T                                                                                               !< temperature at integration point
  integer,                      intent(in) :: &
    instance, &
    of

  integer :: i
  real(pReal) :: &
    f_unrotated, &
    rho_dip_distance, &
    v_cl, &                                                                                         !< climb velocity
    Gamma, &                                                                                        !< stacking fault energy
    tau, &
    sigma_cl, &                                                                                     !< climb stress
    b_d                                                                                             !< ratio of burgers vector to stacking fault width
  real(pReal), dimension(param(instance)%sum_N_sl) :: &
    dot_rho_dip_formation, &
    dot_rho_dip_climb, &
    rho_dip_distance_min, &
    dot_gamma_sl
  real(pReal), dimension(param(instance)%sum_N_tw) :: &
    dot_gamma_twin
  real(pReal), dimension(param(instance)%sum_N_tr) :: &
    dot_gamma_tr

  associate(prm => param(instance),    stt => state(instance), &
            dot => dotState(instance), dst => dependentState(instance))

  f_unrotated = 1.0_pReal &
              - sum(stt%f_tw(1:prm%sum_N_tw,of)) &
              - sum(stt%f_tr(1:prm%sum_N_tr,of))

  call kinetics_slip(Mp,T,instance,of,dot_gamma_sl)
  dot%gamma_sl(:,of) = abs(dot_gamma_sl)

  rho_dip_distance_min = prm%CEdgeDipMinDistance*prm%b_sl

  slipState: do i = 1, prm%sum_N_sl
    tau = math_tensordot(Mp,prm%P_sl(1:3,1:3,i))

    significantSlipStress: if (dEq0(tau)) then
      dot_rho_dip_formation(i) = 0.0_pReal
      dot_rho_dip_climb(i) = 0.0_pReal
    else significantSlipStress
      rho_dip_distance = 3.0_pReal*prm%mu*prm%b_sl(i)/(16.0_pReal*PI*abs(tau))
      rho_dip_distance = math_clip(rho_dip_distance, right = dst%Lambda_sl(i,of))
      rho_dip_distance = math_clip(rho_dip_distance, left  = rho_dip_distance_min(i))

      if (prm%dipoleFormation) then
        dot_rho_dip_formation(i) = 2.0_pReal*(rho_dip_distance-rho_dip_distance_min(i))/prm%b_sl(i) &
                                 * stt%rho_mob(i,of)*abs(dot_gamma_sl(i))
      else
        dot_rho_dip_formation(i) = 0.0_pReal
      endif

      if (dEq(rho_dip_distance,rho_dip_distance_min(i))) then
        dot_rho_dip_climb(i) = 0.0_pReal
      else
      !@details: Refer: Argon & Moffat, Acta Metallurgica, Vol. 29, pg 293 to 299, 1981
        sigma_cl = dot_product(prm%n0_sl(1:3,i),matmul(Mp,prm%n0_sl(1:3,i)))
        if (prm%ExtendedDislocations) then
          Gamma = prm%SFE_0K + prm%dSFE_dT * T
          b_d = 24.0_pReal*PI*(1.0_pReal - prm%nu)/(2.0_pReal + prm%nu)* Gamma/(prm%mu*prm%b_sl(i))
        else
          b_d = 1.0_pReal
        endif
        v_cl = 2.0_pReal*prm%omega*b_d**2.0_pReal*exp(-prm%Qsd/(kB*T)) &
             * (exp(abs(sigma_cl)*prm%b_sl(i)**3.0_pReal/(kB*T)) - 1.0_pReal)

        dot_rho_dip_climb(i) = 4.0_pReal*v_cl*stt%rho_dip(i,of) &
                             / (rho_dip_distance-rho_dip_distance_min(i))
      endif
    endif significantSlipStress
  enddo slipState

  dot%rho_mob(:,of) = abs(dot_gamma_sl)/(prm%b_sl*dst%Lambda_sl(:,of)) &
                    - dot_rho_dip_formation &
                    - 2.0_pReal*rho_dip_distance_min/prm%b_sl * stt%rho_mob(:,of)*abs(dot_gamma_sl)

  dot%rho_dip(:,of) = dot_rho_dip_formation &
                    - 2.0_pReal*rho_dip_distance_min/prm%b_sl * stt%rho_dip(:,of)*abs(dot_gamma_sl) &
                    - dot_rho_dip_climb

  call kinetics_twin(Mp,T,dot_gamma_sl,instance,of,dot_gamma_twin)
  dot%f_tw(:,of) = f_unrotated*dot_gamma_twin/prm%gamma_char

  call kinetics_trans(Mp,T,dot_gamma_sl,instance,of,dot_gamma_tr)
  dot%f_tr(:,of) = f_unrotated*dot_gamma_tr

  end associate

end subroutine plastic_dislotwin_dotState


!--------------------------------------------------------------------------------------------------
!> @brief Calculate derived quantities from state.
!--------------------------------------------------------------------------------------------------
module subroutine plastic_dislotwin_dependentState(T,instance,of)

  integer,       intent(in) :: &
    instance, &
    of
  real(pReal),   intent(in) :: &
    T

  real(pReal) :: &
    sumf_twin,Gamma,sumf_trans
  real(pReal), dimension(param(instance)%sum_N_sl) :: &
    inv_lambda_sl_sl, &                                                                             !< 1/mean free distance between 2 forest dislocations seen by a moving dislocation
    inv_lambda_sl_tw, &                                                                             !< 1/mean free distance between 2 twin stacks from different systems seen by a moving dislocation
    inv_lambda_sl_tr                                                                                !< 1/mean free distance between 2 martensite lamellar from different systems seen by a moving dislocation
  real(pReal), dimension(param(instance)%sum_N_tw) :: &
    inv_lambda_tw_tw, &                                                                             !< 1/mean free distance between 2 twin stacks from different systems seen by a growing twin
    f_over_t_tw
   real(pReal), dimension(param(instance)%sum_N_tr) :: &
    inv_lambda_tr_tr, &                                                                             !< 1/mean free distance between 2 martensite stacks from different systems seen by a growing martensite
    f_over_t_tr
  real(pReal), dimension(:), allocatable :: &
    x0


  associate(prm => param(instance),&
            stt => state(instance),&
            dst => dependentState(instance))

  sumf_twin  = sum(stt%f_tw(1:prm%sum_N_tw,of))
  sumf_trans = sum(stt%f_tr(1:prm%sum_N_tr,of))

  Gamma = prm%SFE_0K + prm%dSFE_dT * T

  !* rescaled volume fraction for topology
  f_over_t_tw = stt%f_tw(1:prm%sum_N_tw,of)/prm%t_tw                                                ! this is per system ...
  f_over_t_tr = sumf_trans/prm%t_tr                                                                 ! but this not
                                                                                                    ! ToDo ...Physically correct, but naming could be adjusted

  inv_lambda_sl_sl = sqrt(matmul(prm%forestProjection, &
                                 stt%rho_mob(:,of)+stt%rho_dip(:,of)))/prm%CLambdaSlip

  if (prm%sum_N_tw > 0 .and. prm%sum_N_sl > 0) &
    inv_lambda_sl_tw = matmul(prm%h_sl_tw,f_over_t_tw)/(1.0_pReal-sumf_twin)

  inv_lambda_tw_tw = matmul(prm%h_tw_tw,f_over_t_tw)/(1.0_pReal-sumf_twin)

  if (prm%sum_N_tr > 0 .and. prm%sum_N_sl > 0) &
    inv_lambda_sl_tr = matmul(prm%h_sl_tr,f_over_t_tr)/(1.0_pReal-sumf_trans)

  inv_lambda_tr_tr = matmul(prm%h_tr_tr,f_over_t_tr)/(1.0_pReal-sumf_trans)

  if ((prm%sum_N_tw > 0) .or. (prm%sum_N_tr > 0)) then                                              ! ToDo: better logic needed here
    dst%Lambda_sl(:,of) = prm%D &
                        / (1.0_pReal+prm%D*(inv_lambda_sl_sl + inv_lambda_sl_tw + inv_lambda_sl_tr))
  else
    dst%Lambda_sl(:,of) = prm%D &
                        / (1.0_pReal+prm%D*inv_lambda_sl_sl) !!!!!! correct?
  endif

  dst%Lambda_tw(:,of) = prm%i_tw*prm%D/(1.0_pReal+prm%D*inv_lambda_tw_tw)
  dst%Lambda_tr(:,of) = prm%i_tr*prm%D/(1.0_pReal+prm%D*inv_lambda_tr_tr)

  !* threshold stress for dislocation motion
  dst%tau_pass(:,of) = prm%mu*prm%b_sl* sqrt(matmul(prm%h_sl_sl,stt%rho_mob(:,of)+stt%rho_dip(:,of)))

  !* threshold stress for growing twin/martensite
  if(prm%sum_N_tw == prm%sum_N_sl) &
    dst%tau_hat_tw(:,of) = Gamma/(3.0_pReal*prm%b_tw) &
                         + 3.0_pReal*prm%b_tw*prm%mu/(prm%L_tw*prm%b_sl) ! slip burgers here correct?
  if(prm%sum_N_tr == prm%sum_N_sl) &
    dst%tau_hat_tr(:,of) = Gamma/(3.0_pReal*prm%b_tr) &
                         + 3.0_pReal*prm%b_tr*prm%mu/(prm%L_tr*prm%b_sl) & ! slip burgers here correct?
                         + prm%h*prm%gamma_fcc_hex/ (3.0_pReal*prm%b_tr)

  dst%V_tw(:,of) = (PI/4.0_pReal)*prm%t_tw*dst%Lambda_tw(:,of)**2.0_pReal
  dst%V_tr(:,of) = (PI/4.0_pReal)*prm%t_tr*dst%Lambda_tr(:,of)**2.0_pReal


  x0 = prm%mu*prm%b_tw**2.0_pReal/(Gamma*8.0_pReal*PI)*(2.0_pReal+prm%nu)/(1.0_pReal-prm%nu)        ! ToDo: In the paper, this is the burgers vector for slip and is the same for twin and trans
  dst%tau_r_tw(:,of) = prm%mu*prm%b_tw/(2.0_pReal*PI)*(1.0_pReal/(x0+prm%xc_twin)+cos(pi/3.0_pReal)/x0)

  x0 = prm%mu*prm%b_tr**2.0_pReal/(Gamma*8.0_pReal*PI)*(2.0_pReal+prm%nu)/(1.0_pReal-prm%nu)        ! ToDo: In the paper, this is the burgers vector for slip
  dst%tau_r_tr(:,of) = prm%mu*prm%b_tr/(2.0_pReal*PI)*(1.0_pReal/(x0+prm%xc_trans)+cos(pi/3.0_pReal)/x0)

  end associate

end subroutine plastic_dislotwin_dependentState


!--------------------------------------------------------------------------------------------------
!> @brief Write results to HDF5 output file.
!--------------------------------------------------------------------------------------------------
module subroutine plastic_dislotwin_results(instance,group)

  integer,          intent(in) :: instance
  character(len=*), intent(in) :: group

  integer :: o

 associate(prm => param(instance), stt => state(instance), dst => dependentState(instance))
  outputsLoop: do o = 1,size(prm%output)
    select case(trim(prm%output(o)))

      case('rho_mob')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_mob,'rho_mob',&
                                                     'mobile dislocation density','1/m²')
      case('rho_dip')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_dip,'rho_dip',&
                                                     'dislocation dipole density''1/m²')
      case('gamma_sl')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%gamma_sl,'gamma_sl',&
                                                     'plastic shear','1')
      case('lambda_sl')
        if(prm%sum_N_sl>0) call results_writeDataset(group,dst%Lambda_sl,'Lambda_sl',&
                                                     'mean free path for slip','m')
      case('tau_pass')
        if(prm%sum_N_sl>0) call results_writeDataset(group,dst%tau_pass,'tau_pass',&
                                                     'passing stress for slip','Pa')

      case('f_tw')
        if(prm%sum_N_tw>0) call results_writeDataset(group,stt%f_tw,'f_tw',&
                                                     'twinned volume fraction','m³/m³')
      case('lambda_tw')
        if(prm%sum_N_tw>0) call results_writeDataset(group,dst%Lambda_tw,'Lambda_tw',&
                                                     'mean free path for twinning','m')
      case('tau_hat_tw')
        if(prm%sum_N_tw>0) call results_writeDataset(group,dst%tau_hat_tw,'tau_hat_tw',&
                                                     'threshold stress for twinning','Pa')

      case('f_tr')
        if(prm%sum_N_tr>0) call results_writeDataset(group,stt%f_tr,'f_tr',&
                                                     'martensite volume fraction','m³/m³')

    end select
  enddo outputsLoop
  end associate

end subroutine plastic_dislotwin_results


!--------------------------------------------------------------------------------------------------
!> @brief Calculate shear rates on slip systems, their derivatives with respect to resolved
!         stress, and the resolved stress.
!> @details Derivatives and resolved stress are calculated only optionally.
! NOTE: Against the common convention, the result (i.e. intent(out)) variables are the last to
! have the optional arguments at the end
!--------------------------------------------------------------------------------------------------
pure subroutine kinetics_slip(Mp,T,instance,of, &
                              dot_gamma_sl,ddot_gamma_dtau_slip,tau_slip)

  real(pReal), dimension(3,3),  intent(in) :: &
    Mp                                                                                              !< Mandel stress
  real(pReal),                  intent(in) :: &
    T                                                                                               !< temperature
  integer,                      intent(in) :: &
    instance, &
    of

  real(pReal), dimension(param(instance)%sum_N_sl), intent(out) :: &
    dot_gamma_sl
  real(pReal), dimension(param(instance)%sum_N_sl), optional, intent(out) :: &
    ddot_gamma_dtau_slip, &
    tau_slip
  real(pReal), dimension(param(instance)%sum_N_sl) :: &
    ddot_gamma_dtau

  real(pReal), dimension(param(instance)%sum_N_sl) :: &
    tau, &
    stressRatio, &
    StressRatio_p, &
    BoltzmannRatio, &
    v_wait_inverse, &                                                                               !< inverse of the effective velocity of a dislocation waiting at obstacles (unsigned)
    v_run_inverse, &                                                                                !< inverse of the velocity of a free moving dislocation (unsigned)
    dV_wait_inverse_dTau, &
    dV_run_inverse_dTau, &
    dV_dTau, &
    tau_eff                                                                                         !< effective resolved stress
  integer :: i

  associate(prm => param(instance), stt => state(instance), dst => dependentState(instance))

  do i = 1, prm%sum_N_sl
    tau(i) = math_tensordot(Mp,prm%P_sl(1:3,1:3,i))
  enddo

  tau_eff = abs(tau)-dst%tau_pass(:,of)

  significantStress: where(tau_eff > tol_math_check)
    stressRatio    = tau_eff/prm%tau_0
    StressRatio_p  = stressRatio** prm%p
    BoltzmannRatio = prm%Delta_F/(kB*T)
    v_wait_inverse = prm%v0**(-1.0_pReal) * exp(BoltzmannRatio*(1.0_pReal-StressRatio_p)** prm%q)
    v_run_inverse  = prm%B/(tau_eff*prm%b_sl)

    dot_gamma_sl = sign(stt%rho_mob(:,of)*prm%b_sl/(v_wait_inverse+v_run_inverse),tau)

    dV_wait_inverse_dTau = -1.0_pReal * v_wait_inverse * prm%p * prm%q * BoltzmannRatio &
                         * (stressRatio**(prm%p-1.0_pReal)) &
                         * (1.0_pReal-StressRatio_p)**(prm%q-1.0_pReal) &
                         / prm%tau_0
    dV_run_inverse_dTau  = -1.0_pReal * v_run_inverse/tau_eff
    dV_dTau              = -1.0_pReal * (dV_wait_inverse_dTau+dV_run_inverse_dTau) &
                         / (v_wait_inverse+v_run_inverse)**2.0_pReal
    ddot_gamma_dtau = dV_dTau*stt%rho_mob(:,of)*prm%b_sl
  else where significantStress
    dot_gamma_sl    = 0.0_pReal
    ddot_gamma_dtau = 0.0_pReal
  end where significantStress

  end associate

  if(present(ddot_gamma_dtau_slip)) ddot_gamma_dtau_slip = ddot_gamma_dtau
  if(present(tau_slip))             tau_slip             = tau

end subroutine kinetics_slip


!--------------------------------------------------------------------------------------------------
!> @brief Calculate shear rates on twin systems and their derivatives with respect to resolved
!         stress.
!> @details Derivatives are calculated only optionally.
! NOTE: Against the common convention, the result (i.e. intent(out)) variables are the last to
! have the optional arguments at the end.
!--------------------------------------------------------------------------------------------------
pure subroutine kinetics_twin(Mp,T,dot_gamma_sl,instance,of,&
                              dot_gamma_twin,ddot_gamma_dtau_twin)

  real(pReal), dimension(3,3),  intent(in) :: &
    Mp                                                                                              !< Mandel stress
  real(pReal),                  intent(in) :: &
    T                                                                                               !< temperature
  integer,                      intent(in) :: &
    instance, &
    of
  real(pReal), dimension(param(instance)%sum_N_sl), intent(in) :: &
    dot_gamma_sl

  real(pReal), dimension(param(instance)%sum_N_tw), intent(out) :: &
    dot_gamma_twin
  real(pReal), dimension(param(instance)%sum_N_tw), optional, intent(out) :: &
    ddot_gamma_dtau_twin

  real, dimension(param(instance)%sum_N_tw) :: &
    tau, &
    Ndot0, &
    stressRatio_r, &
    ddot_gamma_dtau

  integer :: i,s1,s2

  associate(prm => param(instance), stt => state(instance), dst => dependentState(instance))

  do i = 1, prm%sum_N_tw
    tau(i) = math_tensordot(Mp,prm%P_tw(1:3,1:3,i))
    isFCC: if (prm%fccTwinTransNucleation) then
      s1=prm%fcc_twinNucleationSlipPair(1,i)
      s2=prm%fcc_twinNucleationSlipPair(2,i)
      if (tau(i) < dst%tau_r_tw(i,of)) then                                                         ! ToDo: correct?
        Ndot0=(abs(dot_gamma_sl(s1))*(stt%rho_mob(s2,of)+stt%rho_dip(s2,of))+&
               abs(dot_gamma_sl(s2))*(stt%rho_mob(s1,of)+stt%rho_dip(s1,of)))/&                     ! ToDo: MD: it would be more consistent to use shearrates from state
                (prm%L_tw*prm%b_sl(i))*&
                (1.0_pReal-exp(-prm%V_cs/(kB*T)*(dst%tau_r_tw(i,of)-tau(i))))                       ! P_ncs
      else
        Ndot0=0.0_pReal
      end if
    else isFCC
      Ndot0=prm%dot_N_0_tw(i)
    endif isFCC
  enddo

  significantStress: where(tau > tol_math_check)
    StressRatio_r   = (dst%tau_hat_tw(:,of)/tau)**prm%r
    dot_gamma_twin  = prm%gamma_char * dst%V_tw(:,of) * Ndot0*exp(-StressRatio_r)
    ddot_gamma_dtau = (dot_gamma_twin*prm%r/tau)*StressRatio_r
  else where significantStress
    dot_gamma_twin  = 0.0_pReal
    ddot_gamma_dtau = 0.0_pReal
  end where significantStress

  end associate

  if(present(ddot_gamma_dtau_twin)) ddot_gamma_dtau_twin = ddot_gamma_dtau

end subroutine kinetics_twin


!--------------------------------------------------------------------------------------------------
!> @brief Calculate shear rates on transformation systems and their derivatives with respect to
!         resolved stress.
!> @details Derivatives are calculated only optionally.
! NOTE: Against the common convention, the result (i.e. intent(out)) variables are the last to
! have the optional arguments at the end.
!--------------------------------------------------------------------------------------------------
pure subroutine kinetics_trans(Mp,T,dot_gamma_sl,instance,of,&
                              dot_gamma_tr,ddot_gamma_dtau_trans)

  real(pReal), dimension(3,3),  intent(in) :: &
    Mp                                                                                              !< Mandel stress
  real(pReal),                  intent(in) :: &
    T                                                                                               !< temperature
  integer,                      intent(in) :: &
    instance, &
    of
  real(pReal), dimension(param(instance)%sum_N_sl), intent(in) :: &
    dot_gamma_sl

  real(pReal), dimension(param(instance)%sum_N_tr), intent(out) :: &
    dot_gamma_tr
  real(pReal), dimension(param(instance)%sum_N_tr), optional, intent(out) :: &
    ddot_gamma_dtau_trans

  real, dimension(param(instance)%sum_N_tr) :: &
    tau, &
    Ndot0, &
    stressRatio_s, &
    ddot_gamma_dtau

  integer :: i,s1,s2
  associate(prm => param(instance), stt => state(instance), dst => dependentState(instance))

  do i = 1, prm%sum_N_tr
    tau(i) = math_tensordot(Mp,prm%P_tr(1:3,1:3,i))
    isFCC: if (prm%fccTwinTransNucleation) then
      s1=prm%fcc_twinNucleationSlipPair(1,i)
      s2=prm%fcc_twinNucleationSlipPair(2,i)
      if (tau(i) < dst%tau_r_tr(i,of)) then                                                         ! ToDo: correct?
        Ndot0=(abs(dot_gamma_sl(s1))*(stt%rho_mob(s2,of)+stt%rho_dip(s2,of))+&
               abs(dot_gamma_sl(s2))*(stt%rho_mob(s1,of)+stt%rho_dip(s1,of)))/&                     ! ToDo: MD: it would be more consistent to use shearrates from state
                (prm%L_tr*prm%b_sl(i))*&
                (1.0_pReal-exp(-prm%V_cs/(kB*T)*(dst%tau_r_tr(i,of)-tau(i))))                       ! P_ncs
      else
        Ndot0=0.0_pReal
      end if
    else isFCC
      Ndot0=prm%dot_N_0_tr(i)
    endif isFCC
  enddo

  significantStress: where(tau > tol_math_check)
    StressRatio_s   = (dst%tau_hat_tr(:,of)/tau)**prm%s
    dot_gamma_tr    = dst%V_tr(:,of) * Ndot0*exp(-StressRatio_s)
    ddot_gamma_dtau = (dot_gamma_tr*prm%s/tau)*StressRatio_s
  else where significantStress
    dot_gamma_tr  = 0.0_pReal
    ddot_gamma_dtau = 0.0_pReal
  end where significantStress

  end associate

  if(present(ddot_gamma_dtau_trans)) ddot_gamma_dtau_trans = ddot_gamma_dtau

end subroutine kinetics_trans

end submodule plastic_dislotwin
# 42 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2

# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_disloUCLA.f90" 1
!--------------------------------------------------------------------------------------------------
!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH
!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH
!> @author David Cereceda, Lawrence Livermore National Laboratory
!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH
!> @brief crystal plasticity model for bcc metals, especially Tungsten
!--------------------------------------------------------------------------------------------------
submodule(constitutive) plastic_disloUCLA

  real(pReal), parameter :: &
    kB = 1.38e-23_pReal                                                                             !< Boltzmann constant in J/Kelvin

  type :: tParameters
    real(pReal) :: &
      D    = 1.0_pReal, &                                                                           !< grain size
      mu   = 1.0_pReal, &                                                                           !< equivalent shear modulus
      D_0  = 1.0_pReal, &                                                                           !< prefactor for self-diffusion coefficient
      Q_cl = 1.0_pReal                                                                              !< activation energy for dislocation climb
    real(pReal),               allocatable, dimension(:) :: &
      b_sl, &                                                                                       !< magnitude of burgers vector [m]
      D_a, &
      i_sl, &                                                                                       !< Adj. parameter for distance between 2 forest dislocations
      atomicVolume, &
      tau_0, &
      !* mobility law parameters
      delta_F, &                                                                                    !< activation energy for glide [J]
      v0, &                                                                                         !< dislocation velocity prefactor [m/s]
      p, &                                                                                          !< p-exponent in glide velocity
      q, &                                                                                          !< q-exponent in glide velocity
      B, &                                                                                          !< friction coefficient
      kink_height, &                                                                                !< height of the kink pair
      w, &                                                                                          !< width of the kink pair
      omega                                                                                         !< attempt frequency for kink pair nucleation
    real(pReal),               allocatable, dimension(:,:) :: &
      h_sl_sl, &                                                                                    !< slip resistance from slip activity
      forestProjection
    real(pReal),               allocatable, dimension(:,:,:) :: &
      P_sl, &
      nonSchmid_pos, &
      nonSchmid_neg
    integer :: &
      sum_N_sl                                                                                      !< total number of active slip system
    character(len=pStringLen), allocatable, dimension(:) :: &
      output
    logical :: &
      dipoleFormation                                                                               !< flag indicating consideration of dipole formation
  end type                                                                                          !< container type for internal constitutive parameters

  type :: tDisloUCLAState
    real(pReal), dimension(:,:), pointer :: &
      rho_mob, &
      rho_dip, &
      gamma_sl
  end type tDisloUCLAState

  type :: tDisloUCLAdependentState
    real(pReal), dimension(:,:), allocatable :: &
      Lambda_sl, &
      threshold_stress
  end type tDisloUCLAdependentState

!--------------------------------------------------------------------------------------------------
! containers for parameters and state
  type(tParameters),              allocatable, dimension(:) :: param
  type(tDisloUCLAState),          allocatable, dimension(:) :: &
    dotState, &
    state
  type(tDisloUCLAdependentState), allocatable, dimension(:) :: dependentState

contains


!--------------------------------------------------------------------------------------------------
!> @brief Perform module initialization.
!> @details reads in material parameters, allocates arrays, and does sanity checks
!--------------------------------------------------------------------------------------------------
module subroutine plastic_disloUCLA_init

  integer :: &
    Ninstance, &
    p, i, &
    NipcMyPhase, &
    sizeState, sizeDotState, &
    startIndex, endIndex
  integer,    dimension(:), allocatable :: &
    N_sl
  real(pReal),dimension(:), allocatable :: &
    rho_mob_0, &                                                                                    !< initial dislocation density
    rho_dip_0, &                                                                                    !< initial dipole density
    a                                                                                               !< non-Schmid coefficients
  character(len=pStringLen) :: &
    extmsg = ''

  write(6,'(/,a)') ' <<<+-  plastic_'//PLASTICITY_DISLOUCLA_LABEL//' init  -+>>>'; flush(6)

  write(6,'(/,a)') ' Cereceda et al., International Journal of Plasticity 78:242–256, 2016'
  write(6,'(a)')   ' https://dx.doi.org/10.1016/j.ijplas.2015.09.002'

  Ninstance = count(phase_plasticity == PLASTICITY_DISLOUCLA_ID)
  if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0) &
    write(6,'(a16,1x,i5,/)') '# instances:',Ninstance

  allocate(param(Ninstance))
  allocate(state(Ninstance))
  allocate(dotState(Ninstance))
  allocate(dependentState(Ninstance))

  do p = 1, size(phase_plasticity)
    if (phase_plasticity(p) /= PLASTICITY_DISLOUCLA_ID) cycle
    associate(prm => param(phase_plasticityInstance(p)), &
              dot => dotState(phase_plasticityInstance(p)), &
              stt => state(phase_plasticityInstance(p)), &
              dst => dependentState(phase_plasticityInstance(p)), &
              config => config_phase(p))

    prm%output = config%getStrings('(output)',defaultVal=emptyStringArray)

    ! This data is read in already in lattice
    prm%mu = lattice_mu(p)

!--------------------------------------------------------------------------------------------------
! slip related parameters
    N_sl         = config%getInts('nslip',defaultVal=emptyIntArray)
    prm%sum_N_sl = sum(abs(N_sl))
    slipActive: if (prm%sum_N_sl > 0) then
      prm%P_sl = lattice_SchmidMatrix_slip(N_sl,config%getString('lattice_structure'),&
                                           config%getFloat('c/a',defaultVal=0.0_pReal))

      if(trim(config%getString('lattice_structure')) == 'bcc') then
        a = config%getFloats('nonschmid_coefficients',defaultVal = emptyRealArray)
        prm%nonSchmid_pos = lattice_nonSchmidMatrix(N_sl,a,+1)
        prm%nonSchmid_neg = lattice_nonSchmidMatrix(N_sl,a,-1)
      else
        prm%nonSchmid_pos = prm%P_sl
        prm%nonSchmid_neg = prm%P_sl
      endif

      prm%h_sl_sl = lattice_interaction_SlipBySlip(N_sl,config%getFloats('interaction_slipslip'), &
                                                   config%getString('lattice_structure'))
      prm%forestProjection = lattice_forestProjection_edge(N_sl,config%getString('lattice_structure'),&
                                                           config%getFloat('c/a',defaultVal=0.0_pReal))
      prm%forestProjection = transpose(prm%forestProjection)

      rho_mob_0       = config%getFloats('rhoedge0',       requiredSize=size(N_sl))
      rho_dip_0       = config%getFloats('rhoedgedip0',    requiredSize=size(N_sl))
      prm%v0          = config%getFloats('v0',             requiredSize=size(N_sl))
      prm%b_sl        = config%getFloats('slipburgers',    requiredSize=size(N_sl))
      prm%delta_F     = config%getFloats('qedge',          requiredSize=size(N_sl))

      prm%i_sl        = config%getFloats('clambdaslip',    requiredSize=size(N_sl))
      prm%tau_0       = config%getFloats('tau_peierls',    requiredSize=size(N_sl))
      prm%p           = config%getFloats('p_slip',         requiredSize=size(N_sl), &
                                         defaultVal=[(1.0_pReal,i=1,size(N_sl))])
      prm%q           = config%getFloats('q_slip',         requiredSize=size(N_sl), &
                                         defaultVal=[(1.0_pReal,i=1,size(N_sl))])
      prm%kink_height = config%getFloats('kink_height',    requiredSize=size(N_sl))
      prm%w           = config%getFloats('kink_width',     requiredSize=size(N_sl))
      prm%omega       = config%getFloats('omega',          requiredSize=size(N_sl))
      prm%B           = config%getFloats('friction_coeff', requiredSize=size(N_sl))

      prm%D               = config%getFloat('grainsize')
      prm%D_0             = config%getFloat('d0')
      prm%Q_cl            = config%getFloat('qsd')
      prm%atomicVolume    = config%getFloat('catomicvolume')       * prm%b_sl**3.0_pReal
      prm%D_a             = config%getFloat('cedgedipmindistance') * prm%b_sl
      prm%dipoleformation = config%getFloat('dipoleformationfactor') > 0.0_pReal                    !should be on by default, ToDo: change to /key/-type key

      ! expand: family => system
      rho_mob_0          = math_expand(rho_mob_0,          N_sl)
      rho_dip_0          = math_expand(rho_dip_0,          N_sl)
      prm%q              = math_expand(prm%q,              N_sl)
      prm%p              = math_expand(prm%p,              N_sl)
      prm%delta_F        = math_expand(prm%delta_F,        N_sl)
      prm%b_sl           = math_expand(prm%b_sl,           N_sl)
      prm%kink_height    = math_expand(prm%kink_height,    N_sl)
      prm%w              = math_expand(prm%w,              N_sl)
      prm%omega          = math_expand(prm%omega,          N_sl)
      prm%tau_0          = math_expand(prm%tau_0,          N_sl)
      prm%v0             = math_expand(prm%v0,             N_sl)
      prm%B              = math_expand(prm%B,              N_sl)
      prm%i_sl           = math_expand(prm%i_sl,           N_sl)
      prm%atomicVolume   = math_expand(prm%atomicVolume,   N_sl)
      prm%D_a            = math_expand(prm%D_a,            N_sl)

      ! sanity checks
      if (    prm%D_0          <= 0.0_pReal)  extmsg = trim(extmsg)//' D_0'
      if (    prm%Q_cl         <= 0.0_pReal)  extmsg = trim(extmsg)//' Q_cl'
      if (any(rho_mob_0        <  0.0_pReal)) extmsg = trim(extmsg)//' rhoedge0'
      if (any(rho_dip_0        <  0.0_pReal)) extmsg = trim(extmsg)//' rhoedgedip0'
      if (any(prm%v0           <  0.0_pReal)) extmsg = trim(extmsg)//' v0'
      if (any(prm%b_sl         <= 0.0_pReal)) extmsg = trim(extmsg)//' b_sl'
      if (any(prm%delta_F      <= 0.0_pReal)) extmsg = trim(extmsg)//' qedge'
      if (any(prm%tau_0        <  0.0_pReal)) extmsg = trim(extmsg)//' tau_0'
      if (any(prm%D_a          <= 0.0_pReal)) extmsg = trim(extmsg)//' cedgedipmindistance or b_sl'
      if (any(prm%atomicVolume <= 0.0_pReal)) extmsg = trim(extmsg)//' catomicvolume or b_sl'

    else slipActive
      rho_mob_0= emptyRealArray; rho_dip_0 = emptyRealArray
      allocate(prm%b_sl,prm%D_a,prm%i_sl,prm%atomicVolume,prm%tau_0, &
               prm%delta_F,prm%v0,prm%p,prm%q,prm%B,prm%kink_height,prm%w,prm%omega, &
               source = emptyRealArray)
      allocate(prm%forestProjection(0,0))
      allocate(prm%h_sl_sl         (0,0))
    endif slipActive

!--------------------------------------------------------------------------------------------------
! allocate state arrays
    NipcMyPhase = count(material_phaseAt == p) * discretization_nIP
    sizeDotState = size(['rho_mob ','rho_dip ','gamma_sl']) * prm%sum_N_sl
    sizeState = sizeDotState

    call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,0)

!--------------------------------------------------------------------------------------------------
! state aliases and initialization
    startIndex = 1
    endIndex   = prm%sum_N_sl
    stt%rho_mob => plasticState(p)%state(startIndex:endIndex,:)
    stt%rho_mob =  spread(rho_mob_0,2,NipcMyPhase)
    dot%rho_mob => plasticState(p)%dotState(startIndex:endIndex,:)
    plasticState(p)%atol(startIndex:endIndex) = config%getFloat('atol_rho',defaultVal=1.0_pReal)
    if (any(plasticState(p)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_rho'

    startIndex = endIndex + 1
    endIndex   = endIndex + prm%sum_N_sl
    stt%rho_dip => plasticState(p)%state(startIndex:endIndex,:)
    stt%rho_dip =  spread(rho_dip_0,2,NipcMyPhase)
    dot%rho_dip => plasticState(p)%dotState(startIndex:endIndex,:)
    plasticState(p)%atol(startIndex:endIndex) = config%getFloat('atol_rho',defaultVal=1.0_pReal)

    startIndex = endIndex + 1
    endIndex   = endIndex + prm%sum_N_sl
    stt%gamma_sl => plasticState(p)%state(startIndex:endIndex,:)
    dot%gamma_sl => plasticState(p)%dotState(startIndex:endIndex,:)
    plasticState(p)%atol(startIndex:endIndex) = 1.0e-2_pReal
    ! global alias
    plasticState(p)%slipRate        => plasticState(p)%dotState(startIndex:endIndex,:)

    allocate(dst%Lambda_sl(prm%sum_N_sl,NipcMyPhase),         source=0.0_pReal)
    allocate(dst%threshold_stress(prm%sum_N_sl,NipcMyPhase),  source=0.0_pReal)

    plasticState(p)%state0 = plasticState(p)%state                                                  ! ToDo: this could be done centrally

    end associate

!--------------------------------------------------------------------------------------------------
!  exit if any parameter is out of range
    if (extmsg /= '') call IO_error(211,ext_msg=trim(extmsg)//'('//PLASTICITY_DISLOUCLA_LABEL//')')

  enddo

end subroutine plastic_disloUCLA_init


!--------------------------------------------------------------------------------------------------
!> @brief Calculate plastic velocity gradient and its tangent.
!--------------------------------------------------------------------------------------------------
pure module subroutine plastic_disloUCLA_LpAndItsTangent(Lp,dLp_dMp, &
                                                         Mp,T,instance,of)
  real(pReal), dimension(3,3),     intent(out) :: &
    Lp                                                                                              !< plastic velocity gradient
  real(pReal), dimension(3,3,3,3), intent(out) :: &
    dLp_dMp                                                                                         !< derivative of Lp with respect to the Mandel stress

  real(pReal), dimension(3,3), intent(in) :: &
    Mp                                                                                              !< Mandel stress
  real(pReal),                 intent(in) :: &
    T                                                                                               !< temperature
  integer,                     intent(in) :: &
    instance, &
    of

  integer :: &
    i,k,l,m,n
  real(pReal), dimension(param(instance)%sum_N_sl) :: &
    dot_gamma_pos,dot_gamma_neg, &
    ddot_gamma_dtau_pos,ddot_gamma_dtau_neg

  Lp = 0.0_pReal
  dLp_dMp = 0.0_pReal

  associate(prm => param(instance))

  call kinetics(Mp,T,instance,of,dot_gamma_pos,dot_gamma_neg,ddot_gamma_dtau_pos,ddot_gamma_dtau_neg)
  do i = 1, prm%sum_N_sl
    Lp = Lp + (dot_gamma_pos(i)+dot_gamma_neg(i))*prm%P_sl(1:3,1:3,i)
    forall (k=1:3,l=1:3,m=1:3,n=1:3) &
      dLp_dMp(k,l,m,n) = dLp_dMp(k,l,m,n) &
                       + ddot_gamma_dtau_pos(i) * prm%P_sl(k,l,i) * prm%nonSchmid_pos(m,n,i) &
                       + ddot_gamma_dtau_neg(i) * prm%P_sl(k,l,i) * prm%nonSchmid_neg(m,n,i)
  enddo

  end associate

end subroutine plastic_disloUCLA_LpAndItsTangent


!--------------------------------------------------------------------------------------------------
!> @brief Calculate the rate of change of microstructure.
!--------------------------------------------------------------------------------------------------
module subroutine plastic_disloUCLA_dotState(Mp,T,instance,of)

  real(pReal), dimension(3,3),  intent(in) :: &
    Mp                                                                                              !< Mandel stress
  real(pReal),                  intent(in) :: &
    T                                                                                               !< temperature
  integer,                      intent(in) :: &
    instance, &
    of

  real(pReal) :: &
    VacancyDiffusion
  real(pReal), dimension(param(instance)%sum_N_sl) :: &
    gdot_pos, gdot_neg,&
    tau_pos,&
    tau_neg, &
    v_cl, &
    dot_rho_dip_formation, &
    dot_rho_dip_climb, &
    dip_distance

  associate(prm => param(instance), stt => state(instance),dot => dotState(instance), dst => dependentState(instance))

  call kinetics(Mp,T,instance,of,&
                gdot_pos,gdot_neg, &
                tau_pos_out = tau_pos,tau_neg_out = tau_neg)

  dot%gamma_sl(:,of) = (gdot_pos+gdot_neg)                                                          ! ToDo: needs to be abs
  VacancyDiffusion = prm%D_0*exp(-prm%Q_cl/(kB*T))

  where(dEq0(tau_pos))                                                                              ! ToDo: use avg of pos and neg
    dot_rho_dip_formation = 0.0_pReal
    dot_rho_dip_climb     = 0.0_pReal
  else where
    dip_distance = math_clip(3.0_pReal*prm%mu*prm%b_sl/(16.0_pReal*PI*abs(tau_pos)), &
                             prm%D_a, &                                                             ! lower limit
                             dst%Lambda_sl(:,of))                                                   ! upper limit
    dot_rho_dip_formation = merge(2.0_pReal*dip_distance* stt%rho_mob(:,of)*abs(dot%gamma_sl(:,of))/prm%b_sl, & ! ToDo: ignore region of spontaneous annihilation
                                  0.0_pReal, &
                                  prm%dipoleformation)
    v_cl = (3.0_pReal*prm%mu*VacancyDiffusion*prm%atomicVolume/(2.0_pReal*pi*kB*T)) &
                  * (1.0_pReal/(dip_distance+prm%D_a))
    dot_rho_dip_climb = (4.0_pReal*v_cl*stt%rho_dip(:,of))/(dip_distance-prm%D_a)                   ! ToDo: Discuss with Franz: Stress dependency?
  end where

  dot%rho_mob(:,of) = abs(dot%gamma_sl(:,of))/(prm%b_sl*dst%Lambda_sl(:,of)) &                      ! multiplication
                    - dot_rho_dip_formation &
                    - (2.0_pReal*prm%D_a)/prm%b_sl*stt%rho_mob(:,of)*abs(dot%gamma_sl(:,of))        ! Spontaneous annihilation of 2 single edge dislocations
  dot%rho_dip(:,of) = dot_rho_dip_formation &
                    - (2.0_pReal*prm%D_a)/prm%b_sl*stt%rho_dip(:,of)*abs(dot%gamma_sl(:,of)) &      ! Spontaneous annihilation of a single edge dislocation with a dipole constituent
                    - dot_rho_dip_climb

  end associate

end subroutine plastic_disloUCLA_dotState


!--------------------------------------------------------------------------------------------------
!> @brief Calculate derived quantities from state.
!--------------------------------------------------------------------------------------------------
module subroutine plastic_disloUCLA_dependentState(instance,of)

  integer,      intent(in) :: &
    instance, &
    of

  real(pReal), dimension(param(instance)%sum_N_sl) :: &
    dislocationSpacing

  associate(prm => param(instance), stt => state(instance),dst => dependentState(instance))

  dislocationSpacing = sqrt(matmul(prm%forestProjection,stt%rho_mob(:,of)+stt%rho_dip(:,of)))
  dst%threshold_stress(:,of) = prm%mu*prm%b_sl &
                             * sqrt(matmul(prm%h_sl_sl,stt%rho_mob(:,of)+stt%rho_dip(:,of)))

  dst%Lambda_sl(:,of) = prm%D/(1.0_pReal+prm%D*dislocationSpacing/prm%i_sl)

  end associate

end subroutine plastic_disloUCLA_dependentState


!--------------------------------------------------------------------------------------------------
!> @brief Write results to HDF5 output file.
!--------------------------------------------------------------------------------------------------
module subroutine plastic_disloUCLA_results(instance,group)

  integer,          intent(in) :: instance
  character(len=*), intent(in) :: group

  integer :: o

  associate(prm => param(instance), stt => state(instance), dst => dependentState(instance))
  outputsLoop: do o = 1,size(prm%output)
    select case(trim(prm%output(o)))
      case('edge_density')                                                                          ! ToDo: should be rho_mob
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_mob,'rho_mob',&
                                                     'mobile dislocation density','1/m²')
      case('dipole_density')                                                                        ! ToDo: should be rho_dip
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_dip,'rho_dip',&
                                                     'dislocation dipole density''1/m²')
      case('shear_rate_slip')                                                                       ! should be gamma
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%gamma_sl,'dot_gamma_sl',&            ! this is not dot!!
                                                     'plastic shear','1')
      case('mfp_slip')                                                                              !ToDo: should be Lambda
        if(prm%sum_N_sl>0) call results_writeDataset(group,dst%Lambda_sl,'Lambda_sl',&
                                                     'mean free path for slip','m')
      case('threshold_stress_slip')                                                                 !ToDo: should be tau_pass
        if(prm%sum_N_sl>0) call results_writeDataset(group,dst%threshold_stress,'tau_pass',&
                                                     'threshold stress for slip','Pa')
    end select
  enddo outputsLoop
  end associate

end subroutine plastic_disloUCLA_results


!--------------------------------------------------------------------------------------------------
!> @brief Calculate shear rates on slip systems, their derivatives with respect to resolved
!         stress, and the resolved stress.
!> @details Derivatives and resolved stress are calculated only optionally.
! NOTE: Against the common convention, the result (i.e. intent(out)) variables are the last to
! have the optional arguments at the end
!--------------------------------------------------------------------------------------------------
pure subroutine kinetics(Mp,T,instance,of, &
                 dot_gamma_pos,dot_gamma_neg,ddot_gamma_dtau_pos,ddot_gamma_dtau_neg,tau_pos_out,tau_neg_out)

  real(pReal), dimension(3,3),  intent(in) :: &
    Mp                                                                                              !< Mandel stress
  real(pReal),                  intent(in) :: &
    T                                                                                               !< temperature
  integer,                      intent(in) :: &
    instance, &
    of

  real(pReal),                  intent(out), dimension(param(instance)%sum_N_sl) :: &
    dot_gamma_pos, &
    dot_gamma_neg
  real(pReal),                  intent(out), optional, dimension(param(instance)%sum_N_sl) :: &
    ddot_gamma_dtau_pos, &
    ddot_gamma_dtau_neg, &
    tau_pos_out, &
    tau_neg_out
  real(pReal), dimension(param(instance)%sum_N_sl) :: &
    StressRatio, &
    StressRatio_p,StressRatio_pminus1, &
    dvel, vel, &
    tau_pos,tau_neg, &
    t_n, t_k, dtk,dtn, &
    needsGoodName                                                                                   ! ToDo: @Karo: any idea?
  integer :: j

  associate(prm => param(instance), stt => state(instance), dst => dependentState(instance))

  do j = 1, prm%sum_N_sl
    tau_pos(j) = math_tensordot(Mp,prm%nonSchmid_pos(1:3,1:3,j))
    tau_neg(j) = math_tensordot(Mp,prm%nonSchmid_neg(1:3,1:3,j))
  enddo


  if (present(tau_pos_out)) tau_pos_out = tau_pos
  if (present(tau_neg_out)) tau_neg_out = tau_neg

  associate(BoltzmannRatio  => prm%delta_F/(kB*T), &
            dot_gamma_0     => stt%rho_mob(:,of)*prm%b_sl*prm%v0, &
            effectiveLength => dst%Lambda_sl(:,of) - prm%w)

  significantPositiveTau: where(abs(tau_pos)-dst%threshold_stress(:,of) > tol_math_check)
    StressRatio = (abs(tau_pos)-dst%threshold_stress(:,of))/prm%tau_0
    StressRatio_p       = StressRatio** prm%p
    StressRatio_pminus1 = StressRatio**(prm%p-1.0_pReal)
    needsGoodName       = exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q)

    t_n = prm%b_sl/(needsGoodName*prm%omega*effectiveLength)
    t_k = effectiveLength * prm%B /(2.0_pReal*prm%b_sl*tau_pos)

    vel = prm%kink_height/(t_n + t_k)

    dot_gamma_pos = dot_gamma_0 * sign(vel,tau_pos) * 0.5_pReal
  else where significantPositiveTau
    dot_gamma_pos = 0.0_pReal
  end where significantPositiveTau

  if (present(ddot_gamma_dtau_pos)) then
    significantPositiveTau2: where(abs(tau_pos)-dst%threshold_stress(:,of) > tol_math_check)
      dtn = -1.0_pReal * t_n * BoltzmannRatio * prm%p * prm%q * (1.0_pReal-StressRatio_p)**(prm%q - 1.0_pReal) &
          * (StressRatio)**(prm%p - 1.0_pReal) / prm%tau_0
      dtk = -1.0_pReal * t_k / tau_pos

      dvel = -1.0_pReal * prm%kink_height * (dtk + dtn) / (t_n + t_k)**2.0_pReal

      ddot_gamma_dtau_pos = dot_gamma_0 * dvel* 0.5_pReal
    else where significantPositiveTau2
      ddot_gamma_dtau_pos = 0.0_pReal
    end where significantPositiveTau2
  endif

  significantNegativeTau: where(abs(tau_neg)-dst%threshold_stress(:,of) > tol_math_check)
    StressRatio = (abs(tau_neg)-dst%threshold_stress(:,of))/prm%tau_0
    StressRatio_p       = StressRatio** prm%p
    StressRatio_pminus1 = StressRatio**(prm%p-1.0_pReal)
    needsGoodName       = exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q)

    t_n = prm%b_sl/(needsGoodName*prm%omega*effectiveLength)
    t_k = effectiveLength * prm%B /(2.0_pReal*prm%b_sl*tau_pos)

    vel = prm%kink_height/(t_n + t_k)

    dot_gamma_neg = dot_gamma_0 * sign(vel,tau_neg) * 0.5_pReal
  else where significantNegativeTau
    dot_gamma_neg = 0.0_pReal
  end where significantNegativeTau

  if (present(ddot_gamma_dtau_neg)) then
    significantNegativeTau2: where(abs(tau_neg)-dst%threshold_stress(:,of) > tol_math_check)
      dtn = -1.0_pReal * t_n * BoltzmannRatio * prm%p * prm%q * (1.0_pReal-StressRatio_p)**(prm%q - 1.0_pReal) &
          * (StressRatio)**(prm%p - 1.0_pReal) / prm%tau_0
      dtk = -1.0_pReal * t_k / tau_neg

      dvel = -1.0_pReal * prm%kink_height * (dtk + dtn) / (t_n + t_k)**2.0_pReal

      ddot_gamma_dtau_neg = dot_gamma_0 * dvel * 0.5_pReal
    else where significantNegativeTau2
      ddot_gamma_dtau_neg = 0.0_pReal
    end where significantNegativeTau2
  end if

  end associate
  end associate

end subroutine kinetics

end submodule plastic_disloUCLA
# 43 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2

# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_nonlocal.f90" 1
!--------------------------------------------------------------------------------------------------
!> @author Christoph Kords, Max-Planck-Institut für Eisenforschung GmbH
!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH
!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH
!> @brief material subroutine for plasticity including dislocation flux
!--------------------------------------------------------------------------------------------------
submodule(constitutive) plastic_nonlocal
  use geometry_plastic_nonlocal, only: &
    nIPneighbors    => geometry_plastic_nonlocal_nIPneighbors, &
    IPneighborhood  => geometry_plastic_nonlocal_IPneighborhood, &
    IPvolume        => geometry_plastic_nonlocal_IPvolume0, &
    IParea          => geometry_plastic_nonlocal_IParea0, &
    IPareaNormal    => geometry_plastic_nonlocal_IPareaNormal0

  real(pReal), parameter :: &
    kB = 1.38e-23_pReal                                                                             !< Boltzmann constant in J/Kelvin

  ! storage order of dislocation types
  integer, dimension(8), parameter :: &
    sgl = [1,2,3,4,5,6,7,8]                                                                         !< signed (single)
  integer, dimension(5), parameter :: &
    edg = [1,2,5,6,9], &                                                                            !< edge
    scr = [3,4,7,8,10]                                                                              !< screw
  integer, dimension(4), parameter :: &
    mob = [1,2,3,4], &                                                                              !< mobile
    imm = [5,6,7,8]                                                                                 !< immobile (blocked)
  integer, dimension(2), parameter :: &
    dip = [9,10], &                                                                                 !< dipole
    imm_edg = imm(1:2), &                                                                           !< immobile edge
    imm_scr = imm(3:4)                                                                              !< immobile screw
  integer, parameter :: &
    mob_edg_pos = 1, &                                                                              !< mobile edge positive
    mob_edg_neg = 2, &                                                                              !< mobile edge negative
    mob_scr_pos = 3, &                                                                              !< mobile screw positive
    mob_scr_neg = 4                                                                                 !< mobile screw positive

  ! BEGIN DEPRECATED
  integer, dimension(:,:,:), allocatable :: &
    iRhoU, &                                                                                        !< state indices for unblocked density
    iV, &                                                                                           !< state indices for dislcation velocities
    iD                                                                                              !< state indices for stable dipole height
  !END DEPRECATED

  real(pReal), dimension(:,:,:,:,:,:), allocatable :: &
    compatibility                                                                                   !< slip system compatibility between me and my neighbors

  type :: tInitialParameters                                                                        !< container type for internal constitutive parameters
    real(pReal) :: &
      rhoSglScatter, &                                                                              !< standard deviation of scatter in initial dislocation density
      rhoSglRandom, &
      rhoSglRandomBinning
    real(pReal), dimension(:), allocatable :: &
      rhoSglEdgePos0, &                                                                             !< initial edge_pos dislocation density
      rhoSglEdgeNeg0, &                                                                             !< initial edge_neg dislocation density
      rhoSglScrewPos0, &                                                                            !< initial screw_pos dislocation density
      rhoSglScrewNeg0, &                                                                            !< initial screw_neg dislocation density
      rhoDipEdge0, &                                                                                !< initial edge dipole dislocation density
      rhoDipScrew0                                                                                  !< initial screw dipole dislocation density
    integer,     dimension(:) ,allocatable :: &
      N_sl
  end type tInitialParameters

  type :: tParameters                                                                               !< container type for internal constitutive parameters
    real(pReal) :: &
      atomicVolume, &                                                                               !< atomic volume
      Dsd0, &                                                                                       !< prefactor for self-diffusion coefficient
      selfDiffusionEnergy, &                                                                        !< activation enthalpy for diffusion
      atol_rho, &                                                                                   !< absolute tolerance for dislocation density in state integration
      significantRho, &                                                                             !< density considered significant
      significantN, &                                                                               !< number of dislocations considered significant
      doublekinkwidth, &                                                                            !< width of a doubkle kink in multiples of the burgers vector length b
      solidSolutionEnergy, &                                                                        !< activation energy for solid solution in J
      solidSolutionSize, &                                                                          !< solid solution obstacle size in multiples of the burgers vector length
      solidSolutionConcentration, &                                                                 !< concentration of solid solution in atomic parts
      p, &                                                                                          !< parameter for kinetic law (Kocks,Argon,Ashby)
      q, &                                                                                          !< parameter for kinetic law (Kocks,Argon,Ashby)
      viscosity, &                                                                                  !< viscosity for dislocation glide in Pa s
      fattack, &                                                                                    !< attack frequency in Hz
      surfaceTransmissivity, &                                                                      !< transmissivity at free surface
      grainboundaryTransmissivity, &                                                                !< transmissivity at grain boundary (identified by different texture)
      CFLfactor, &                                                                                  !< safety factor for CFL flux condition
      fEdgeMultiplication, &                                                                        !< factor that determines how much edge dislocations contribute to multiplication (0...1)
      linetensionEffect, &
      edgeJogFactor, &
      mu, &
      nu
    real(pReal), dimension(:),      allocatable :: &
      minDipoleHeight_edge, &                                                                       !< minimum stable edge dipole height
      minDipoleHeight_screw, &                                                                      !< minimum stable screw dipole height
      peierlsstress_edge, &
      peierlsstress_screw, &
      lambda0, &                                                                                    !< mean free path prefactor for each
      burgers                                                                                       !< absolute length of burgers vector [m]
    real(pReal), dimension(:,:),   allocatable :: &
      slip_normal, &
      slip_direction, &
      slip_transverse, &
      minDipoleHeight, &                                                                            ! edge and screw
      peierlsstress, &                                                                              ! edge and screw
      interactionSlipSlip ,&                                                                        !< coefficients for slip-slip interaction
      forestProjection_Edge, &                                                                      !< matrix of forest projections of edge dislocations
      forestProjection_Screw                                                                        !< matrix of forest projections of screw dislocations
    real(pReal), dimension(:,:,:), allocatable :: &
      Schmid, &                                                                                     !< Schmid contribution
      nonSchmid_pos, &
      nonSchmid_neg                                                                                 !< combined projection of Schmid and non-Schmid contributions to the resolved shear stress (only for screws)
    integer :: &
      sum_N_sl
    integer,     dimension(:),     allocatable :: &
      colinearSystem                                                                                !< colinear system to the active slip system (only valid for fcc!)
    character(len=pStringLen), dimension(:), allocatable :: &
      output
    logical :: &
      shortRangeStressCorrection, &                                                                 !< use of short range stress correction by excess density gradient term
      nonSchmidActive = .false.
  end type tParameters

  type :: tNonlocalMicrostructure
    real(pReal), allocatable, dimension(:,:) :: &
     tau_pass, &
     tau_Back
  end type tNonlocalMicrostructure

  type :: tNonlocalState
    real(pReal), pointer, dimension(:,:) :: &
      rho, &                                                                                        ! < all dislocations
        rhoSgl, &
          rhoSglMobile, &                       ! iRhoU
            rho_sgl_mob_edg_pos, &
            rho_sgl_mob_edg_neg, &
            rho_sgl_mob_scr_pos, &
            rho_sgl_mob_scr_neg, &
          rhoSglImmobile, &
            rho_sgl_imm_edg_pos, &
            rho_sgl_imm_edg_neg, &
            rho_sgl_imm_scr_pos, &
            rho_sgl_imm_scr_neg, &
        rhoDip, &
          rho_dip_edg, &
          rho_dip_scr, &
        rho_forest, &
      gamma, &
      v, &
          v_edg_pos, &
          v_edg_neg, &
          v_scr_pos, &
          v_scr_neg
  end type tNonlocalState

  type(tNonlocalState), allocatable, dimension(:) :: &
    deltaState, &
    dotState, &
    state, &
    state0

  type(tParameters), dimension(:), allocatable :: param                                             !< containers of constitutive parameters (len Ninstance)

  type(tNonlocalMicrostructure), dimension(:), allocatable :: microstructure

contains

!--------------------------------------------------------------------------------------------------
!> @brief module initialization
!> @details reads in material parameters, allocates arrays, and does sanity checks
!--------------------------------------------------------------------------------------------------
module subroutine plastic_nonlocal_init

  integer :: &
    Ninstance, &
    p, &
    NipcMyPhase, &
    sizeState, sizeDotState, sizeDependentState, sizeDeltaState, &
    s1, s2, &
    s, t, l
  real(pReal), dimension(:), allocatable :: &
    a
  character(len=pStringLen) :: &
    extmsg  = ''
  type(tInitialParameters) :: &
    ini

  write(6,'(/,a)') ' <<<+-  constitutive_'//PLASTICITY_NONLOCAL_LABEL//' init  -+>>>'; flush(6)

  write(6,'(/,a)') ' Reuber et al., Acta Materialia 71:333–348, 2014'
  write(6,'(a)')   ' https://doi.org/10.1016/j.actamat.2014.03.012'

  write(6,'(/,a)') ' Kords, Dissertation RWTH Aachen, 2014'
  write(6,'(a)')   ' http://publications.rwth-aachen.de/record/229993'

  Ninstance = count(phase_plasticity == PLASTICITY_NONLOCAL_ID)
  if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0) &
    write(6,'(a16,1x,i5,/)') '# instances:',Ninstance

  allocate(param(Ninstance))
  allocate(state(Ninstance))
  allocate(state0(Ninstance))
  allocate(dotState(Ninstance))
  allocate(deltaState(Ninstance))
  allocate(microstructure(Ninstance))

  do p=1, size(config_phase)
    if (phase_plasticity(p) /= PLASTICITY_NONLOCAL_ID) cycle

    associate(prm => param(phase_plasticityInstance(p)), &
              dot => dotState(phase_plasticityInstance(p)), &
              stt => state(phase_plasticityInstance(p)), &
              st0 => state0(phase_plasticityInstance(p)), &
              del => deltaState(phase_plasticityInstance(p)), &
              dst => microstructure(phase_plasticityInstance(p)), &
              config => config_phase(p))

    prm%output = config%getStrings('(output)',defaultVal=emptyStringArray)

    prm%atol_rho   = config%getFloat('atol_rho',defaultVal=1.0e4_pReal)

    ! This data is read in already in lattice
    prm%mu = lattice_mu(p)
    prm%nu = lattice_nu(p)

    ini%N_sl     = config%getInts('nslip',defaultVal=emptyIntArray)
    prm%sum_N_sl = sum(abs(ini%N_sl))
    slipActive: if (prm%sum_N_sl > 0) then
      prm%Schmid = lattice_SchmidMatrix_slip(ini%N_sl,config%getString('lattice_structure'),&
                                             config%getFloat('c/a',defaultVal=0.0_pReal))

      if(trim(config%getString('lattice_structure')) == 'bcc') then
        a = config%getFloats('nonschmid_coefficients',defaultVal = emptyRealArray)
        if(size(a) > 0) prm%nonSchmidActive = .true.
        prm%nonSchmid_pos  = lattice_nonSchmidMatrix(ini%N_sl,a,+1)
        prm%nonSchmid_neg  = lattice_nonSchmidMatrix(ini%N_sl,a,-1)
      else
        prm%nonSchmid_pos  = prm%Schmid
        prm%nonSchmid_neg  = prm%Schmid
      endif

      prm%interactionSlipSlip = lattice_interaction_SlipBySlip(ini%N_sl, &
                                                               config%getFloats('interaction_slipslip'), &
                                                               config%getString('lattice_structure'))

      prm%forestProjection_edge  = lattice_forestProjection_edge (ini%N_sl,config%getString('lattice_structure'),&
                                                                  config%getFloat('c/a',defaultVal=0.0_pReal))
      prm%forestProjection_screw = lattice_forestProjection_screw(ini%N_sl,config%getString('lattice_structure'),&
                                                                  config%getFloat('c/a',defaultVal=0.0_pReal))

      prm%slip_direction  = lattice_slip_direction (ini%N_sl,config%getString('lattice_structure'),&
                                                    config%getFloat('c/a',defaultVal=0.0_pReal))
      prm%slip_transverse = lattice_slip_transverse(ini%N_sl,config%getString('lattice_structure'),&
                                                    config%getFloat('c/a',defaultVal=0.0_pReal))
      prm%slip_normal     = lattice_slip_normal    (ini%N_sl,config%getString('lattice_structure'),&
                                                    config%getFloat('c/a',defaultVal=0.0_pReal))

      ! collinear systems (only for octahedral slip systems in fcc)
      allocate(prm%colinearSystem(prm%sum_N_sl), source = -1)
      do s1 = 1, prm%sum_N_sl
        do s2 = 1, prm%sum_N_sl
           if (all(dEq0 (math_cross(prm%slip_direction(1:3,s1),prm%slip_direction(1:3,s2)))) .and. &
               any(dNeq0(math_cross(prm%slip_normal   (1:3,s1),prm%slip_normal   (1:3,s2))))) &
             prm%colinearSystem(s1) = s2
        enddo
      enddo

      ini%rhoSglEdgePos0  = config%getFloats('rhosgledgepos0',   requiredSize=size(ini%N_sl))
      ini%rhoSglEdgeNeg0  = config%getFloats('rhosgledgeneg0',   requiredSize=size(ini%N_sl))
      ini%rhoSglScrewPos0 = config%getFloats('rhosglscrewpos0',  requiredSize=size(ini%N_sl))
      ini%rhoSglScrewNeg0 = config%getFloats('rhosglscrewneg0',  requiredSize=size(ini%N_sl))
      ini%rhoDipEdge0     = config%getFloats('rhodipedge0',      requiredSize=size(ini%N_sl))
      ini%rhoDipScrew0    = config%getFloats('rhodipscrew0',     requiredSize=size(ini%N_sl))

      prm%lambda0         = config%getFloats('lambda0',          requiredSize=size(ini%N_sl))
      prm%burgers         = config%getFloats('burgers',          requiredSize=size(ini%N_sl))

      prm%lambda0 = math_expand(prm%lambda0,ini%N_sl)
      prm%burgers = math_expand(prm%burgers,ini%N_sl)

      prm%minDipoleHeight_edge  = config%getFloats('minimumdipoleheightedge',  requiredSize=size(ini%N_sl))
      prm%minDipoleHeight_screw = config%getFloats('minimumdipoleheightscrew', requiredSize=size(ini%N_sl))
      prm%minDipoleHeight_edge  = math_expand(prm%minDipoleHeight_edge, ini%N_sl)
      prm%minDipoleHeight_screw = math_expand(prm%minDipoleHeight_screw,ini%N_sl)
      allocate(prm%minDipoleHeight(prm%sum_N_sl,2))
      prm%minDipoleHeight(:,1)  = prm%minDipoleHeight_edge
      prm%minDipoleHeight(:,2)  = prm%minDipoleHeight_screw

      prm%peierlsstress_edge    = config%getFloats('peierlsstressedge',        requiredSize=size(ini%N_sl))
      prm%peierlsstress_screw   = config%getFloats('peierlsstressscrew',       requiredSize=size(ini%N_sl))
      prm%peierlsstress_edge    = math_expand(prm%peierlsstress_edge, ini%N_sl)
      prm%peierlsstress_screw   = math_expand(prm%peierlsstress_screw,ini%N_sl)
      allocate(prm%peierlsstress(prm%sum_N_sl,2))
      prm%peierlsstress(:,1)    = prm%peierlsstress_edge
      prm%peierlsstress(:,2)    = prm%peierlsstress_screw

      prm%significantRho              = config%getFloat('significantrho')
      prm%significantN                = config%getFloat('significantn', 0.0_pReal)
      prm%CFLfactor                   = config%getFloat('cflfactor',defaultVal=2.0_pReal)

      prm%atomicVolume                = config%getFloat('atomicvolume')
      prm%Dsd0                        = config%getFloat('selfdiffusionprefactor') !,'dsd0'
      prm%selfDiffusionEnergy         = config%getFloat('selfdiffusionenergy') !,'qsd'
      prm%linetensionEffect           = config%getFloat('linetension')
      prm%edgeJogFactor               = config%getFloat('edgejog')!,'edgejogs'
      prm%doublekinkwidth             = config%getFloat('doublekinkwidth')
      prm%solidSolutionEnergy         = config%getFloat('solidsolutionenergy')
      prm%solidSolutionSize           = config%getFloat('solidsolutionsize')
      prm%solidSolutionConcentration  = config%getFloat('solidsolutionconcentration')

      prm%p                           = config%getFloat('p')
      prm%q                           = config%getFloat('q')
      prm%viscosity                   = config%getFloat('viscosity')
      prm%fattack                     = config%getFloat('attackfrequency')

      ! ToDo: discuss logic
      ini%rhoSglScatter               = config%getFloat('rhosglscatter')
      ini%rhoSglRandom                = config%getFloat('rhosglrandom',0.0_pReal)
      if (config%keyExists('/rhosglrandom/')) &
        ini%rhoSglRandomBinning       = config%getFloat('rhosglrandombinning',0.0_pReal) !ToDo: useful default?
     ! if (rhoSglRandom(instance) < 0.0_pReal) &
     ! if (rhoSglRandomBinning(instance) <= 0.0_pReal) &

      prm%surfaceTransmissivity       = config%getFloat('surfacetransmissivity',defaultVal=1.0_pReal)
      prm%grainboundaryTransmissivity = config%getFloat('grainboundarytransmissivity',defaultVal=-1.0_pReal)
      prm%fEdgeMultiplication         = config%getFloat('edgemultiplication')
      prm%shortRangeStressCorrection  = config%keyExists('/shortrangestresscorrection/')

!--------------------------------------------------------------------------------------------------
!  sanity checks
      if (any(prm%burgers          <  0.0_pReal)) extmsg = trim(extmsg)//' burgers'
      if (any(prm%lambda0          <= 0.0_pReal)) extmsg = trim(extmsg)//' lambda0'

      if (any(ini%rhoSglEdgePos0   <  0.0_pReal)) extmsg = trim(extmsg)//' rhoSglEdgePos0'
      if (any(ini%rhoSglEdgeNeg0   <  0.0_pReal)) extmsg = trim(extmsg)//' rhoSglEdgeNeg0'
      if (any(ini%rhoSglScrewPos0  <  0.0_pReal)) extmsg = trim(extmsg)//' rhoSglScrewPos0'
      if (any(ini%rhoSglScrewNeg0  <  0.0_pReal)) extmsg = trim(extmsg)//' rhoSglScrewNeg0'
      if (any(ini%rhoDipEdge0      <  0.0_pReal)) extmsg = trim(extmsg)//' rhoDipEdge0'
      if (any(ini%rhoDipScrew0     <  0.0_pReal)) extmsg = trim(extmsg)//' rhoDipScrew0'

      if (any(prm%peierlsstress    <  0.0_pReal)) extmsg = trim(extmsg)//' peierlsstress'
      if (any(prm%minDipoleHeight  <  0.0_pReal)) extmsg = trim(extmsg)//' minDipoleHeight'

      if (prm%viscosity           <= 0.0_pReal)   extmsg = trim(extmsg)//' viscosity'
      if (prm%selfDiffusionEnergy <= 0.0_pReal)   extmsg = trim(extmsg)//' selfDiffusionEnergy'
      if (prm%fattack             <= 0.0_pReal)   extmsg = trim(extmsg)//' fattack'
      if (prm%doublekinkwidth     <= 0.0_pReal)   extmsg = trim(extmsg)//' doublekinkwidth'
      if (prm%Dsd0                < 0.0_pReal)    extmsg = trim(extmsg)//' Dsd0'
      if (prm%atomicVolume        <= 0.0_pReal)   extmsg = trim(extmsg)//' atomicVolume'            ! ToDo: in disloUCLA, the atomic volume is given as a factor

      if (prm%significantN         < 0.0_pReal)   extmsg = trim(extmsg)//' significantN'
      if (prm%significantrho       < 0.0_pReal)   extmsg = trim(extmsg)//' significantrho'
      if (prm%atol_rho             < 0.0_pReal)   extmsg = trim(extmsg)//' atol_rho'
      if (prm%CFLfactor            < 0.0_pReal)   extmsg = trim(extmsg)//' CFLfactor'

      if (prm%p <= 0.0_pReal .or. prm%p > 1.0_pReal) extmsg = trim(extmsg)//' p'
      if (prm%q <  1.0_pReal .or. prm%q > 2.0_pReal) extmsg = trim(extmsg)//' q'

      if (prm%linetensionEffect <  0.0_pReal .or. prm%linetensionEffect  > 1.0_pReal) &
                                                  extmsg = trim(extmsg)//' linetensionEffect'
      if (prm%edgeJogFactor     <  0.0_pReal .or. prm%edgeJogFactor      > 1.0_pReal) &
                                                  extmsg = trim(extmsg)//' edgeJogFactor'

      if (prm%solidSolutionEnergy        <= 0.0_pReal) extmsg = trim(extmsg)//' solidSolutionEnergy'
      if (prm%solidSolutionSize          <= 0.0_pReal) extmsg = trim(extmsg)//' solidSolutionSize'
      if (prm%solidSolutionConcentration <= 0.0_pReal) extmsg = trim(extmsg)//' solidSolutionConcentration'

      if (prm%grainboundaryTransmissivity  > 1.0_pReal) extmsg = trim(extmsg)//' grainboundaryTransmissivity'
      if (prm%surfaceTransmissivity  <  0.0_pReal .or. prm%surfaceTransmissivity  > 1.0_pReal) &
                                                        extmsg = trim(extmsg)//' surfaceTransmissivity'

      if (prm%fEdgeMultiplication  <  0.0_pReal .or. prm%fEdgeMultiplication  > 1.0_pReal) &
        extmsg = trim(extmsg)//' fEdgeMultiplication'

    endif slipActive

!--------------------------------------------------------------------------------------------------
! allocate state arrays
    NipcMyPhase  = count(material_phaseAt==p) * discretization_nIP
    sizeDotState = size([   'rhoSglEdgePosMobile   ','rhoSglEdgeNegMobile   ', &
                            'rhoSglScrewPosMobile  ','rhoSglScrewNegMobile  ', &
                            'rhoSglEdgePosImmobile ','rhoSglEdgeNegImmobile ', &
                            'rhoSglScrewPosImmobile','rhoSglScrewNegImmobile', &
                            'rhoDipEdge            ','rhoDipScrew           ', &
                            'gamma                 ' ]) * prm%sum_N_sl                              !< "basic" microstructural state variables that are independent from other state variables
    sizeDependentState = size([ 'rhoForest   ']) * prm%sum_N_sl                                     !< microstructural state variables that depend on other state variables
    sizeState          = sizeDotState + sizeDependentState &
                       + size([ 'velocityEdgePos     ','velocityEdgeNeg     ', &
                                'velocityScrewPos    ','velocityScrewNeg    ', &
                                'maxDipoleHeightEdge ','maxDipoleHeightScrew' ]) * prm%sum_N_sl     !< other dependent state variables that are not updated by microstructure
    sizeDeltaState            = sizeDotState

    call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,sizeDeltaState)

    plasticState(p)%nonlocal = .true.
    plasticState(p)%offsetDeltaState = 0                                                            ! ToDo: state structure does not follow convention

    st0%rho => plasticState(p)%state0                             (0*prm%sum_N_sl+1:10*prm%sum_N_sl,:)
    stt%rho => plasticState(p)%state                              (0*prm%sum_N_sl+1:10*prm%sum_N_sl,:)
    dot%rho => plasticState(p)%dotState                           (0*prm%sum_N_sl+1:10*prm%sum_N_sl,:)
    del%rho => plasticState(p)%deltaState                         (0*prm%sum_N_sl+1:10*prm%sum_N_sl,:)
    plasticState(p)%atol(1:10*prm%sum_N_sl) = prm%atol_rho

      stt%rhoSgl => plasticState(p)%state                         (0*prm%sum_N_sl+1: 8*prm%sum_N_sl,:)
      dot%rhoSgl => plasticState(p)%dotState                      (0*prm%sum_N_sl+1: 8*prm%sum_N_sl,:)
      del%rhoSgl => plasticState(p)%deltaState                    (0*prm%sum_N_sl+1: 8*prm%sum_N_sl,:)

        stt%rhoSglMobile => plasticState(p)%state                 (0*prm%sum_N_sl+1: 4*prm%sum_N_sl,:)
        dot%rhoSglMobile => plasticState(p)%dotState              (0*prm%sum_N_sl+1: 4*prm%sum_N_sl,:)
        del%rhoSglMobile => plasticState(p)%deltaState            (0*prm%sum_N_sl+1: 4*prm%sum_N_sl,:)

            stt%rho_sgl_mob_edg_pos => plasticState(p)%state      (0*prm%sum_N_sl+1: 1*prm%sum_N_sl,:)
            dot%rho_sgl_mob_edg_pos => plasticState(p)%dotState   (0*prm%sum_N_sl+1: 1*prm%sum_N_sl,:)
            del%rho_sgl_mob_edg_pos => plasticState(p)%deltaState (0*prm%sum_N_sl+1: 1*prm%sum_N_sl,:)

            stt%rho_sgl_mob_edg_neg => plasticState(p)%state      (1*prm%sum_N_sl+1: 2*prm%sum_N_sl,:)
            dot%rho_sgl_mob_edg_neg => plasticState(p)%dotState   (1*prm%sum_N_sl+1: 2*prm%sum_N_sl,:)
            del%rho_sgl_mob_edg_neg => plasticState(p)%deltaState (1*prm%sum_N_sl+1: 2*prm%sum_N_sl,:)

            stt%rho_sgl_mob_scr_pos => plasticState(p)%state      (2*prm%sum_N_sl+1: 3*prm%sum_N_sl,:)
            dot%rho_sgl_mob_scr_pos => plasticState(p)%dotState   (2*prm%sum_N_sl+1: 3*prm%sum_N_sl,:)
            del%rho_sgl_mob_scr_pos => plasticState(p)%deltaState (2*prm%sum_N_sl+1: 3*prm%sum_N_sl,:)

            stt%rho_sgl_mob_scr_neg => plasticState(p)%state      (3*prm%sum_N_sl+1: 4*prm%sum_N_sl,:)
            dot%rho_sgl_mob_scr_neg => plasticState(p)%dotState   (3*prm%sum_N_sl+1: 4*prm%sum_N_sl,:)
            del%rho_sgl_mob_scr_neg => plasticState(p)%deltaState (3*prm%sum_N_sl+1: 4*prm%sum_N_sl,:)

        stt%rhoSglImmobile => plasticState(p)%state               (4*prm%sum_N_sl+1: 8*prm%sum_N_sl,:)
        dot%rhoSglImmobile => plasticState(p)%dotState            (4*prm%sum_N_sl+1: 8*prm%sum_N_sl,:)
        del%rhoSglImmobile => plasticState(p)%deltaState          (4*prm%sum_N_sl+1: 8*prm%sum_N_sl,:)

            stt%rho_sgl_imm_edg_pos => plasticState(p)%state      (4*prm%sum_N_sl+1: 5*prm%sum_N_sl,:)
            dot%rho_sgl_imm_edg_pos => plasticState(p)%dotState   (4*prm%sum_N_sl+1: 5*prm%sum_N_sl,:)
            del%rho_sgl_imm_edg_pos => plasticState(p)%deltaState (4*prm%sum_N_sl+1: 5*prm%sum_N_sl,:)

            stt%rho_sgl_imm_edg_neg => plasticState(p)%state      (5*prm%sum_N_sl+1: 6*prm%sum_N_sl,:)
            dot%rho_sgl_imm_edg_neg => plasticState(p)%dotState   (5*prm%sum_N_sl+1: 6*prm%sum_N_sl,:)
            del%rho_sgl_imm_edg_neg => plasticState(p)%deltaState (5*prm%sum_N_sl+1: 6*prm%sum_N_sl,:)

            stt%rho_sgl_imm_scr_pos => plasticState(p)%state      (6*prm%sum_N_sl+1: 7*prm%sum_N_sl,:)
            dot%rho_sgl_imm_scr_pos => plasticState(p)%dotState   (6*prm%sum_N_sl+1: 7*prm%sum_N_sl,:)
            del%rho_sgl_imm_scr_pos => plasticState(p)%deltaState (6*prm%sum_N_sl+1: 7*prm%sum_N_sl,:)

            stt%rho_sgl_imm_scr_neg => plasticState(p)%state      (7*prm%sum_N_sl+1: 8*prm%sum_N_sl,:)
            dot%rho_sgl_imm_scr_neg => plasticState(p)%dotState   (7*prm%sum_N_sl+1: 8*prm%sum_N_sl,:)
            del%rho_sgl_imm_scr_neg => plasticState(p)%deltaState (7*prm%sum_N_sl+1: 8*prm%sum_N_sl,:)

      stt%rhoDip => plasticState(p)%state                         (8*prm%sum_N_sl+1:10*prm%sum_N_sl,:)
      dot%rhoDip => plasticState(p)%dotState                      (8*prm%sum_N_sl+1:10*prm%sum_N_sl,:)
      del%rhoDip => plasticState(p)%deltaState                    (8*prm%sum_N_sl+1:10*prm%sum_N_sl,:)

        stt%rho_dip_edg => plasticState(p)%state                  (8*prm%sum_N_sl+1: 9*prm%sum_N_sl,:)
        dot%rho_dip_edg => plasticState(p)%dotState               (8*prm%sum_N_sl+1: 9*prm%sum_N_sl,:)
        del%rho_dip_edg => plasticState(p)%deltaState             (8*prm%sum_N_sl+1: 9*prm%sum_N_sl,:)

        stt%rho_dip_scr => plasticState(p)%state                  (9*prm%sum_N_sl+1:10*prm%sum_N_sl,:)
        dot%rho_dip_scr => plasticState(p)%dotState               (9*prm%sum_N_sl+1:10*prm%sum_N_sl,:)
        del%rho_dip_scr => plasticState(p)%deltaState             (9*prm%sum_N_sl+1:10*prm%sum_N_sl,:)

    stt%gamma => plasticState(p)%state                      (10*prm%sum_N_sl + 1:11*prm%sum_N_sl,1:NipcMyPhase)
    dot%gamma => plasticState(p)%dotState                   (10*prm%sum_N_sl + 1:11*prm%sum_N_sl,1:NipcMyPhase)
    del%gamma => plasticState(p)%deltaState                 (10*prm%sum_N_sl + 1:11*prm%sum_N_sl,1:NipcMyPhase)
    plasticState(p)%atol(10*prm%sum_N_sl+1:11*prm%sum_N_sl )  = config%getFloat('atol_gamma', defaultVal = 1.0e-2_pReal)
    if(any(plasticState(p)%atol(10*prm%sum_N_sl+1:11*prm%sum_N_sl) < 0.0_pReal)) &
      extmsg = trim(extmsg)//' atol_gamma'
    plasticState(p)%slipRate => plasticState(p)%dotState    (10*prm%sum_N_sl + 1:11*prm%sum_N_sl,1:NipcMyPhase)

    stt%rho_forest => plasticState(p)%state                 (11*prm%sum_N_sl + 1:12*prm%sum_N_sl,1:NipcMyPhase)
    stt%v          => plasticState(p)%state                 (12*prm%sum_N_sl + 1:16*prm%sum_N_sl,1:NipcMyPhase)
        stt%v_edg_pos  => plasticState(p)%state             (12*prm%sum_N_sl + 1:13*prm%sum_N_sl,1:NipcMyPhase)
        stt%v_edg_neg  => plasticState(p)%state             (13*prm%sum_N_sl + 1:14*prm%sum_N_sl,1:NipcMyPhase)
        stt%v_scr_pos  => plasticState(p)%state             (14*prm%sum_N_sl + 1:15*prm%sum_N_sl,1:NipcMyPhase)
        stt%v_scr_neg  => plasticState(p)%state             (15*prm%sum_N_sl + 1:16*prm%sum_N_sl,1:NipcMyPhase)

    allocate(dst%tau_pass(prm%sum_N_sl,NipcMyPhase),source=0.0_pReal)
    allocate(dst%tau_back(prm%sum_N_sl,NipcMyPhase),source=0.0_pReal)
    end associate

    if (NipcMyPhase > 0) call stateInit(ini,p,NipcMyPhase)
    plasticState(p)%state0 = plasticState(p)%state

!--------------------------------------------------------------------------------------------------
!  exit if any parameter is out of range
    if (extmsg /= '') call IO_error(211,ext_msg=trim(extmsg)//'('//PLASTICITY_NONLOCAL_LABEL//')')

  enddo

  allocate(compatibility(2,maxval(param%sum_N_sl),maxval(param%sum_N_sl),nIPneighbors,&
                         discretization_nIP,discretization_nElem), source=0.0_pReal)

! BEGIN DEPRECATED----------------------------------------------------------------------------------
  allocate(iRhoU(maxval(param%sum_N_sl),4,Ninstance), source=0)
  allocate(iV(maxval(param%sum_N_sl),4,Ninstance),    source=0)
  allocate(iD(maxval(param%sum_N_sl),2,Ninstance),    source=0)

  initializeInstances: do p = 1, size(phase_plasticity)
    NipcMyPhase = count(material_phaseAt==p) * discretization_nIP
    myPhase2: if (phase_plasticity(p) == PLASTICITY_NONLOCAL_ID) then
      l = 0
      do t = 1,4
        do s = 1,param(phase_plasticityInstance(p))%sum_N_sl
          l = l + 1
          iRhoU(s,t,phase_plasticityInstance(p)) = l
        enddo
      enddo
      l = l + (4+2+1+1)*param(phase_plasticityInstance(p))%sum_N_sl ! immobile(4), dipole(2), shear, forest
      do t = 1,4
        do s = 1,param(phase_plasticityInstance(p))%sum_N_sl
          l = l + 1
          iV(s,t,phase_plasticityInstance(p)) = l
        enddo
      enddo
      do t = 1,2
        do s = 1,param(phase_plasticityInstance(p))%sum_N_sl
          l = l + 1
          iD(s,t,phase_plasticityInstance(p)) = l
        enddo
      enddo
      if (iD(param(phase_plasticityInstance(p))%sum_N_sl,2,phase_plasticityInstance(p)) /= plasticState(p)%sizeState) &
        call IO_error(0, ext_msg = 'state indices not properly set ('//PLASTICITY_NONLOCAL_LABEL//')')
    endif myPhase2
  enddo initializeInstances

end subroutine plastic_nonlocal_init


!--------------------------------------------------------------------------------------------------
!> @brief calculates quantities characterizing the microstructure
!--------------------------------------------------------------------------------------------------
module subroutine plastic_nonlocal_dependentState(F, Fp, instance, of, ip, el)

  real(pReal), dimension(3,3), intent(in) :: &
    F, &
    Fp
  integer, intent(in) :: &
    instance, &
    of, &
    ip, &
    el

  integer :: &
    no, &                                                                                           !< neighbor offset
    neighbor_el, &                                                                                  ! element number of neighboring material point
    neighbor_ip, &                                                                                  ! integration point of neighboring material point
    neighbor_instance, &                                                                            ! instance of this plasticity of neighboring material point
    c, &                                                                                            ! index of dilsocation character (edge, screw)
    s, &                                                                                            ! slip system index
    dir, &
    n
  real(pReal) :: &
    FVsize, &
    nRealNeighbors                                                                                  ! number of really existing neighbors
  integer, dimension(2) :: &
    neighbors
  real(pReal), dimension(2) :: &
    rhoExcessGradient, &
    rhoExcessGradient_over_rho, &
    rhoTotal
  real(pReal), dimension(3) :: &
    rhoExcessDifferences, &
    normal_latticeConf
  real(pReal), dimension(3,3) :: &
    invFe, &                                                                                        !< inverse of elastic deformation gradient
    invFp, &                                                                                        !< inverse of plastic deformation gradient
    connections, &
    invConnections
  real(pReal), dimension(3,nIPneighbors) :: &
    connection_latticeConf
  real(pReal), dimension(2,param(instance)%sum_N_sl) :: &
    rhoExcess
  real(pReal), dimension(param(instance)%sum_N_sl) :: &
    rho_edg_delta, &
    rho_scr_delta
  real(pReal), dimension(param(instance)%sum_N_sl,10) :: &
    rho, &
    rho0, &
    rho_neighbor0
  real(pReal), dimension(param(instance)%sum_N_sl,param(instance)%sum_N_sl) :: &
    myInteractionMatrix                                                                             ! corrected slip interaction matrix
  real(pReal), dimension(param(instance)%sum_N_sl,nIPneighbors) :: &
    rho_edg_delta_neighbor, &
    rho_scr_delta_neighbor
  real(pReal), dimension(2,maxval(param%sum_N_sl),nIPneighbors) :: &
    neighbor_rhoExcess, &                                                                           ! excess density at neighboring material point
    neighbor_rhoTotal                                                                               ! total density at neighboring material point
  real(pReal), dimension(3,param(instance)%sum_N_sl,2) :: &
    m                                                                                               ! direction of dislocation motion

  associate(prm => param(instance),dst => microstructure(instance), stt => state(instance))

  rho = getRho(instance,of,ip,el)

  stt%rho_forest(:,of) = matmul(prm%forestProjection_Edge, sum(abs(rho(:,edg)),2)) &
                       + matmul(prm%forestProjection_Screw,sum(abs(rho(:,scr)),2))


  ! coefficients are corrected for the line tension effect
  ! (see Kubin,Devincre,Hoc; 2008; Modeling dislocation storage rates and mean free paths in face-centered cubic crystals)
  if (any(lattice_structure(material_phaseAt(1,el)) == [LATTICE_bcc_ID,LATTICE_fcc_ID])) then
    myInteractionMatrix = prm%interactionSlipSlip &
                        * spread((  1.0_pReal - prm%linetensionEffect &
                                   + prm%linetensionEffect &
                                   * log(0.35_pReal * prm%burgers * sqrt(max(stt%rho_forest(:,of),prm%significantRho))) &
                                   / log(0.35_pReal * prm%burgers * 1e6_pReal))** 2.0_pReal,2,prm%sum_N_sl)
  else
    myInteractionMatrix = prm%interactionSlipSlip
  endif

  dst%tau_pass(:,of) = prm%mu * prm%burgers &
                     * sqrt(matmul(myInteractionMatrix,sum(abs(rho),2)))

!*** calculate the dislocation stress of the neighboring excess dislocation densities
!*** zero for material points of local plasticity

  !#################################################################################################
  ! ToDo: MD: this is most likely only correct for F_i = I
  !#################################################################################################

  rho0 = getRho0(instance,of,ip,el)
  if (.not. phase_localPlasticity(material_phaseAt(1,el)) .and. prm%shortRangeStressCorrection) then
    invFp = math_inv33(Fp)
    invFe = matmul(Fp,math_inv33(F))

    rho_edg_delta = rho0(:,mob_edg_pos) - rho0(:,mob_edg_neg)
    rho_scr_delta = rho0(:,mob_scr_pos) - rho0(:,mob_scr_neg)

    rhoExcess(1,:) = rho_edg_delta
    rhoExcess(2,:) = rho_scr_delta

    FVsize = IPvolume(ip,el) ** (1.0_pReal/3.0_pReal)

    !* loop through my neighborhood and get the connection vectors (in lattice frame) and the excess densities

    nRealNeighbors = 0.0_pReal
    neighbor_rhoTotal = 0.0_pReal
    do n = 1,nIPneighbors
      neighbor_el = IPneighborhood(1,n,ip,el)
      neighbor_ip = IPneighborhood(2,n,ip,el)
      no = material_phasememberAt(1,neighbor_ip,neighbor_el)
      if (neighbor_el > 0 .and. neighbor_ip > 0) then
        neighbor_instance = phase_plasticityInstance(material_phaseAt(1,neighbor_el))
        if (neighbor_instance == instance) then

            nRealNeighbors = nRealNeighbors + 1.0_pReal
            rho_neighbor0 = getRho0(instance,no,neighbor_ip,neighbor_el)

            rho_edg_delta_neighbor(:,n) = rho_neighbor0(:,mob_edg_pos) - rho_neighbor0(:,mob_edg_neg)
            rho_scr_delta_neighbor(:,n) = rho_neighbor0(:,mob_scr_pos) - rho_neighbor0(:,mob_scr_neg)

            neighbor_rhoTotal(1,:,n) = sum(abs(rho_neighbor0(:,edg)),2)
            neighbor_rhoTotal(2,:,n) = sum(abs(rho_neighbor0(:,scr)),2)

            connection_latticeConf(1:3,n) = matmul(invFe, discretization_IPcoords(1:3,neighbor_el+neighbor_ip-1) &
                                          - discretization_IPcoords(1:3,el+neighbor_ip-1))
            normal_latticeConf = matmul(transpose(invFp), IPareaNormal(1:3,n,ip,el))
            if (math_inner(normal_latticeConf,connection_latticeConf(1:3,n)) < 0.0_pReal) &         ! neighboring connection points in opposite direction to face normal: must be periodic image
              connection_latticeConf(1:3,n) = normal_latticeConf * IPvolume(ip,el)/IParea(n,ip,el)  ! instead take the surface normal scaled with the diameter of the cell
        else
          ! local neighbor or different lattice structure or different constitution instance -> use central values instead
          connection_latticeConf(1:3,n) = 0.0_pReal
          rho_edg_delta_neighbor(:,n) = rho_edg_delta
          rho_scr_delta_neighbor(:,n) = rho_scr_delta
        endif
      else
        ! free surface -> use central values instead
        connection_latticeConf(1:3,n) = 0.0_pReal
        rho_edg_delta_neighbor(:,n) = rho_edg_delta
        rho_scr_delta_neighbor(:,n) = rho_scr_delta
      endif
    enddo

    neighbor_rhoExcess(1,:,:) = rho_edg_delta_neighbor
    neighbor_rhoExcess(2,:,:) = rho_scr_delta_neighbor

    !* loop through the slip systems and calculate the dislocation gradient by
    !* 1. interpolation of the excess density in the neighorhood
    !* 2. interpolation of the dead dislocation density in the central volume
    m(1:3,:,1) =  prm%slip_direction
    m(1:3,:,2) = -prm%slip_transverse

    do s = 1,prm%sum_N_sl

      ! gradient from interpolation of neighboring excess density ...
      do c = 1,2
        do dir = 1,3
          neighbors(1) = 2 * dir - 1
          neighbors(2) = 2 * dir
          connections(dir,1:3) = connection_latticeConf(1:3,neighbors(1)) &
                               - connection_latticeConf(1:3,neighbors(2))
          rhoExcessDifferences(dir) = neighbor_rhoExcess(c,s,neighbors(1)) &
                                    - neighbor_rhoExcess(c,s,neighbors(2))
        enddo
        invConnections = math_inv33(connections)
        if (all(dEq0(invConnections))) call IO_error(-1,ext_msg='back stress calculation: inversion error')

        rhoExcessGradient(c) = math_inner(m(1:3,s,c), matmul(invConnections,rhoExcessDifferences))
      enddo

        ! ... plus gradient from deads ...
      rhoExcessGradient(1) = rhoExcessGradient(1) + sum(rho(s,imm_edg)) / FVsize
      rhoExcessGradient(2) = rhoExcessGradient(2) + sum(rho(s,imm_scr)) / FVsize

        ! ... normalized with the total density ...
      rhoTotal(1) = (sum(abs(rho(s,edg))) + sum(neighbor_rhoTotal(1,s,:))) / (1.0_pReal + nRealNeighbors)
      rhoTotal(2) = (sum(abs(rho(s,scr))) + sum(neighbor_rhoTotal(2,s,:))) / (1.0_pReal + nRealNeighbors)

      rhoExcessGradient_over_rho = 0.0_pReal
      where(rhoTotal > 0.0_pReal) rhoExcessGradient_over_rho = rhoExcessGradient / rhoTotal

        ! ... gives the local stress correction when multiplied with a factor
      dst%tau_back(s,of) = - prm%mu * prm%burgers(s) / (2.0_pReal * PI) &
                         * (  rhoExcessGradient_over_rho(1) / (1.0_pReal - prm%nu) &
                            + rhoExcessGradient_over_rho(2))
    enddo
  endif

# 721 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_nonlocal.f90"

 end associate

end subroutine plastic_nonlocal_dependentState


!--------------------------------------------------------------------------------------------------
!> @brief calculates plastic velocity gradient and its tangent
!--------------------------------------------------------------------------------------------------
module subroutine plastic_nonlocal_LpAndItsTangent(Lp,dLp_dMp, &
                                                   Mp,Temperature,instance,of,ip,el)
  real(pReal), dimension(3,3), intent(out) :: &
    Lp                                                                                              !< plastic velocity gradient
  real(pReal), dimension(3,3,3,3), intent(out) :: &
    dLp_dMp
  integer, intent(in) :: &
    instance, &
    of, &
    ip, &                                                                                           !< current integration point
    el                                                                                              !< current element number
  real(pReal), intent(in) :: &
    Temperature                                                                                     !< temperature

  real(pReal), dimension(3,3), intent(in) :: &
    Mp
                                                                                                    !< derivative of Lp with respect to Mp
  integer :: &
    ns, &                                                                                           !< short notation for the total number of active slip systems
    i, &
    j, &
    k, &
    l, &
    t, &                                                                                            !< dislocation type
    s                                                                                               !< index of my current slip system
  real(pReal), dimension(param(instance)%sum_N_sl,8) :: &
    rhoSgl                                                                                          !< single dislocation densities (including blocked)
  real(pReal), dimension(param(instance)%sum_N_sl,10) :: &
    rho
  real(pReal), dimension(param(instance)%sum_N_sl,4) :: &
    v, &                                                                                            !< velocity
    tauNS, &                                                                                        !< resolved shear stress including non Schmid and backstress terms
    dv_dtau, &                                                                                      !< velocity derivative with respect to the shear stress
    dv_dtauNS                                                                                       !< velocity derivative with respect to the shear stress
  real(pReal), dimension(param(instance)%sum_N_sl) :: &
    tau, &                                                                                          !< resolved shear stress including backstress terms
    gdotTotal                                                                                       !< shear rate

  associate(prm => param(instance),dst=>microstructure(instance),stt=>state(instance))
  ns = prm%sum_N_sl

  !*** shortcut to state variables
  rho = getRho(instance,of,ip,el)
  rhoSgl = rho(:,sgl)

  do s = 1,ns
    tau(s) = math_tensordot(Mp, prm%Schmid(1:3,1:3,s))
    tauNS(s,1) = tau(s)
    tauNS(s,2) = tau(s)
    if (tau(s) > 0.0_pReal) then
      tauNS(s,3) = math_tensordot(Mp, +prm%nonSchmid_pos(1:3,1:3,s))
      tauNS(s,4) = math_tensordot(Mp, -prm%nonSchmid_neg(1:3,1:3,s))
    else
      tauNS(s,3) = math_tensordot(Mp, +prm%nonSchmid_neg(1:3,1:3,s))
      tauNS(s,4) = math_tensordot(Mp, -prm%nonSchmid_pos(1:3,1:3,s))
    endif
  enddo
  tauNS = tauNS + spread(dst%tau_back(:,of),2,4)
  tau   = tau   + dst%tau_back(:,of)

  ! edges
  call kinetics(v(:,1), dv_dtau(:,1), dv_dtauNS(:,1), &
                tau, tauNS(:,1), dst%tau_pass(:,of),1,Temperature, instance)
  v(:,2)         = v(:,1)
  dv_dtau(:,2)   = dv_dtau(:,1)
  dv_dtauNS(:,2) = dv_dtauNS(:,1)

  !screws
  if (prm%nonSchmidActive) then
    v(:,3:4)         = spread(v(:,1),2,2)
    dv_dtau(:,3:4)   = spread(dv_dtau(:,1),2,2)
    dv_dtauNS(:,3:4) = spread(dv_dtauNS(:,1),2,2)
  else
    do t = 3,4
      call kinetics(v(:,t), dv_dtau(:,t), dv_dtauNS(:,t), &
                    tau, tauNS(:,t), dst%tau_pass(:,of),2,Temperature, instance)
    enddo
  endif

  stt%v(:,of) = pack(v,.true.)

  !*** Bauschinger effect
  forall (s = 1:ns, t = 5:8, rhoSgl(s,t) * v(s,t-4) < 0.0_pReal) &
    rhoSgl(s,t-4) = rhoSgl(s,t-4) + abs(rhoSgl(s,t))

  gdotTotal = sum(rhoSgl(:,1:4) * v, 2) * prm%burgers

  Lp = 0.0_pReal
  dLp_dMp = 0.0_pReal
  do s = 1,ns
    Lp = Lp + gdotTotal(s) * prm%Schmid(1:3,1:3,s)
    forall (i=1:3,j=1:3,k=1:3,l=1:3) &
      dLp_dMp(i,j,k,l) = dLp_dMp(i,j,k,l) &
          + prm%Schmid(i,j,s) * prm%Schmid(k,l,s) &
          * sum(rhoSgl(s,1:4) * dv_dtau(s,1:4)) * prm%burgers(s) &
          + prm%Schmid(i,j,s) &
          * ( prm%nonSchmid_pos(k,l,s) * rhoSgl(s,3) * dv_dtauNS(s,3) &
            - prm%nonSchmid_neg(k,l,s) * rhoSgl(s,4) * dv_dtauNS(s,4))  * prm%burgers(s)
  enddo

  end associate

end subroutine plastic_nonlocal_LpAndItsTangent


!--------------------------------------------------------------------------------------------------
!> @brief (instantaneous) incremental change of microstructure
!--------------------------------------------------------------------------------------------------
module subroutine plastic_nonlocal_deltaState(Mp,instance,of,ip,el)

  real(pReal), dimension(3,3), intent(in) :: &
    Mp                                                                                              !< MandelStress
  integer, intent(in) :: &
    instance, &                                                                                     ! current instance of this plasticity
    of, &                                                                                           !< offset
    ip, &
    el

  integer :: &
    ph, &                                                                                           !< phase
    ns, &                                                                                           ! short notation for the total number of active slip systems
    c, &                                                                                            ! character of dislocation
    t, &                                                                                            ! type of dislocation
    s                                                                                               ! index of my current slip system
  real(pReal), dimension(param(instance)%sum_N_sl,10) :: &
    deltaRhoRemobilization, &                                                                       ! density increment by remobilization
    deltaRhoDipole2SingleStress                                                                     ! density increment by dipole dissociation (by stress change)
  real(pReal), dimension(param(instance)%sum_N_sl,10) :: &
    rho                                                                                             ! current  dislocation densities
  real(pReal), dimension(param(instance)%sum_N_sl,4) :: &
    v                                                                                               ! dislocation glide velocity
  real(pReal), dimension(param(instance)%sum_N_sl) :: &
    tau                                                                                             ! current resolved shear stress
  real(pReal), dimension(param(instance)%sum_N_sl,2) :: &
    rhoDip, &                                                                                       ! current dipole dislocation densities (screw and edge dipoles)
    dUpper, &                                                                                       ! current maximum stable dipole distance for edges and screws
    dUpperOld, &                                                                                    ! old maximum stable dipole distance for edges and screws
    deltaDUpper                                                                                     ! change in maximum stable dipole distance for edges and screws

   ph = material_phaseAt(1,el)

   associate(prm => param(instance),dst => microstructure(instance),del => deltaState(instance))
   ns = prm%sum_N_sl

  !*** shortcut to state variables
  forall (s = 1:ns, t = 1:4) v(s,t) = plasticState(ph)%state(iV(s,t,instance),of)
  forall (s = 1:ns, c = 1:2) dUpperOld(s,c) = plasticState(ph)%state(iD(s,c,instance),of)

  rho =  getRho(instance,of,ip,el)
  rhoDip = rho(:,dip)

  !****************************************************************************
  !*** dislocation remobilization (bauschinger effect)
  where(rho(:,imm) * v < 0.0_pReal)
    deltaRhoRemobilization(:,mob) = abs(rho(:,imm))
    deltaRhoRemobilization(:,imm) =   - rho(:,imm)
    rho(:,mob) = rho(:,mob) + abs(rho(:,imm))
    rho(:,imm) = 0.0_pReal
  elsewhere
    deltaRhoRemobilization(:,mob) = 0.0_pReal
    deltaRhoRemobilization(:,imm) = 0.0_pReal
  endwhere
  deltaRhoRemobilization(:,dip) = 0.0_pReal

  !****************************************************************************
  !*** calculate dipole formation and dissociation by stress change

  !*** calculate limits for stable dipole height
  do s = 1,prm%sum_N_sl
    tau(s) = math_tensordot(Mp, prm%Schmid(1:3,1:3,s)) +dst%tau_back(s,of)
    if (abs(tau(s)) < 1.0e-15_pReal) tau(s) = 1.0e-15_pReal
  enddo

  dUpper(:,1) = prm%mu * prm%burgers/(8.0_pReal * PI * (1.0_pReal - prm%nu) * abs(tau))
  dUpper(:,2) = prm%mu * prm%burgers/(4.0_pReal * PI * abs(tau))

  where(dNeq0(sqrt(sum(abs(rho(:,edg)),2)))) &
    dUpper(:,1) = min(1.0_pReal/sqrt(sum(abs(rho(:,edg)),2)),dUpper(:,1))
  where(dNeq0(sqrt(sum(abs(rho(:,scr)),2)))) &
    dUpper(:,2) = min(1.0_pReal/sqrt(sum(abs(rho(:,scr)),2)),dUpper(:,2))

  dUpper = max(dUpper,prm%minDipoleHeight)
  deltaDUpper = dUpper - dUpperOld


  !*** dissociation by stress increase
  deltaRhoDipole2SingleStress = 0.0_pReal
  forall (c=1:2, s=1:ns, deltaDUpper(s,c) < 0.0_pReal .and. &
                                          dNeq0(dUpperOld(s,c) - prm%minDipoleHeight(s,c))) &
    deltaRhoDipole2SingleStress(s,8+c) = rhoDip(s,c) * deltaDUpper(s,c) &
                                       / (dUpperOld(s,c) - prm%minDipoleHeight(s,c))

  forall (t=1:4) deltaRhoDipole2SingleStress(:,t) = -0.5_pReal * deltaRhoDipole2SingleStress(:,(t-1)/2+9)
  forall (s = 1:ns, c = 1:2) plasticState(ph)%state(iD(s,c,instance),of) = dUpper(s,c)

  plasticState(ph)%deltaState(:,of) = 0.0_pReal
  del%rho(:,of) = reshape(deltaRhoRemobilization + deltaRhoDipole2SingleStress, [10*ns])

# 936 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_nonlocal.f90"

  end associate

end subroutine plastic_nonlocal_deltaState


!---------------------------------------------------------------------------------------------------
!> @brief calculates the rate of change of microstructure
!---------------------------------------------------------------------------------------------------
module subroutine plastic_nonlocal_dotState(Mp, F, Fp, Temperature,timestep, &
                                            instance,of,ip,el)

  real(pReal), dimension(3,3), intent(in) :: &
    Mp                                                                                              !< MandelStress
  real(pReal), dimension(3,3,homogenization_maxNgrains,discretization_nIP,discretization_nElem), intent(in) :: &
    F, &                                                                                            !< elastic deformation gradient
    Fp                                                                                              !< plastic deformation gradient
  real(pReal), intent(in) :: &
    Temperature, &                                                                                  !< temperature
    timestep                                                                                        !< substepped crystallite time increment
  integer, intent(in) :: &
    instance, &
    of, &
    ip, &                                                                                           !< current integration point
    el                                                                                              !< current element number

  integer ::  &
    ph, &
    neighbor_instance, &                                                                            !< instance of my neighbor's plasticity
    ns, &                                                                                           !< short notation for the total number of active slip systems
    c, &                                                                                            !< character of dislocation
    n, &                                                                                            !< index of my current neighbor
    neighbor_el, &                                                                                  !< element number of my neighbor
    neighbor_ip, &                                                                                  !< integration point of my neighbor
    neighbor_n, &                                                                                   !< neighbor index pointing to me when looking from my neighbor
    opposite_neighbor, &                                                                            !< index of my opposite neighbor
    opposite_ip, &                                                                                  !< ip of my opposite neighbor
    opposite_el, &                                                                                  !< element index of my opposite neighbor
    opposite_n, &                                                                                   !< neighbor index pointing to me when looking from my opposite neighbor
    t, &                                                                                            !< type of dislocation
    no,&                                                                                            !< neighbor offset shortcut
    np,&                                                                                            !< neighbor phase shortcut
    topp, &                                                                                         !< type of dislocation with opposite sign to t
    s                                                                                               !< index of my current slip system
  real(pReal), dimension(param(instance)%sum_N_sl,10) :: &
    rho, &
    rho0, &                                                                                         !< dislocation density at beginning of time step
    rhoDot, &                                                                                       !< density evolution
    rhoDotMultiplication, &                                                                         !< density evolution by multiplication
    rhoDotFlux, &                                                                                   !< density evolution by flux
    rhoDotSingle2DipoleGlide, &                                                                     !< density evolution by dipole formation (by glide)
    rhoDotAthermalAnnihilation, &                                                                   !< density evolution by athermal annihilation
    rhoDotThermalAnnihilation                                                                       !< density evolution by thermal annihilation
  real(pReal), dimension(param(instance)%sum_N_sl,8) :: &
    rhoSgl, &                                                                                       !< current single dislocation densities (positive/negative screw and edge without dipoles)
    neighbor_rhoSgl0, &                                                                             !< current single dislocation densities of neighboring ip (positive/negative screw and edge without dipoles)
    my_rhoSgl0                                                                                      !< single dislocation densities of central ip (positive/negative screw and edge without dipoles)
  real(pReal), dimension(param(instance)%sum_N_sl,4) :: &
    v, &                                                                                            !< current dislocation glide velocity
    v0, &
    neighbor_v0, &                                                                                  !< dislocation glide velocity of enighboring ip
    gdot                                                                                            !< shear rates
  real(pReal), dimension(param(instance)%sum_N_sl) :: &
    tau, &                                                                                          !< current resolved shear stress
    vClimb                                                                                          !< climb velocity of edge dipoles
  real(pReal), dimension(param(instance)%sum_N_sl,2) :: &
    rhoDip, &                                                                                       !< current dipole dislocation densities (screw and edge dipoles)
    dLower, &                                                                                       !< minimum stable dipole distance for edges and screws
    dUpper                                                                                          !< current maximum stable dipole distance for edges and screws
  real(pReal), dimension(3,param(instance)%sum_N_sl,4) :: &
    m                                                                                               !< direction of dislocation motion
  real(pReal), dimension(3,3) :: &
    my_F, &                                                                                         !< my total deformation gradient
    neighbor_F, &                                                                                   !< total deformation gradient of my neighbor
    my_Fe, &                                                                                        !< my elastic deformation gradient
    neighbor_Fe, &                                                                                  !< elastic deformation gradient of my neighbor
    Favg                                                                                            !< average total deformation gradient of me and my neighbor
  real(pReal), dimension(3) :: &
    normal_neighbor2me, &                                                                           !< interface normal pointing from my neighbor to me in neighbor's lattice configuration
    normal_neighbor2me_defConf, &                                                                   !< interface normal pointing from my neighbor to me in shared deformed configuration
    normal_me2neighbor, &                                                                           !< interface normal pointing from me to my neighbor in my lattice configuration
    normal_me2neighbor_defConf                                                                      !< interface normal pointing from me to my neighbor in shared deformed configuration
  real(pReal) :: &
    area, &                                                                                         !< area of the current interface
    transmissivity, &                                                                               !< overall transmissivity of dislocation flux to neighboring material point
    lineLength, &                                                                                   !< dislocation line length leaving the current interface
    selfDiffusion                                                                                   !< self diffusion

  ph = material_phaseAt(1,el)
  if (timestep <= 0.0_pReal) then
    plasticState(ph)%dotState = 0.0_pReal
    return
  endif

  associate(prm => param(instance), &
            dst => microstructure(instance), &
            dot => dotState(instance), &
            stt => state(instance))
  ns = prm%sum_N_sl

  tau = 0.0_pReal
  gdot = 0.0_pReal

  rho  = getRho(instance,of,ip,el)
  rhoSgl = rho(:,sgl)
  rhoDip = rho(:,dip)
  rho0 = getRho0(instance,of,ip,el)
  my_rhoSgl0 = rho0(:,sgl)

  forall (s = 1:ns, t = 1:4) v(s,t) = plasticState(ph)%state(iV(s,t,instance),of)
  gdot = rhoSgl(:,1:4) * v * spread(prm%burgers,2,4)

# 1056 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_nonlocal.f90"

  !****************************************************************************
  !*** limits for stable dipole height
  do s = 1,ns
    tau(s) = math_tensordot(Mp, prm%Schmid(1:3,1:3,s)) + dst%tau_back(s,of)
    if (abs(tau(s)) < 1.0e-15_pReal) tau(s) = 1.0e-15_pReal
  enddo

  dLower = prm%minDipoleHeight
  dUpper(:,1) = prm%mu * prm%burgers/(8.0_pReal * PI * (1.0_pReal - prm%nu) * abs(tau))
  dUpper(:,2) = prm%mu * prm%burgers/(4.0_pReal * PI * abs(tau))

  where(dNeq0(sqrt(sum(abs(rho(:,edg)),2)))) &
    dUpper(:,1) = min(1.0_pReal/sqrt(sum(abs(rho(:,edg)),2)),dUpper(:,1))
  where(dNeq0(sqrt(sum(abs(rho(:,scr)),2)))) &
    dUpper(:,2) = min(1.0_pReal/sqrt(sum(abs(rho(:,scr)),2)),dUpper(:,2))

  dUpper = max(dUpper,dLower)

  !****************************************************************************
  !*** dislocation multiplication
  rhoDotMultiplication = 0.0_pReal
  isBCC: if (lattice_structure(ph) == LATTICE_bcc_ID) then
    forall (s = 1:ns, sum(abs(v(s,1:4))) > 0.0_pReal)
      rhoDotMultiplication(s,1:2) = sum(abs(gdot(s,3:4))) / prm%burgers(s) &                        ! assuming double-cross-slip of screws to be decisive for multiplication
                                  * sqrt(stt%rho_forest(s,of)) / prm%lambda0(s) ! &                 ! mean free path
                                  ! * 2.0_pReal * sum(abs(v(s,3:4))) / sum(abs(v(s,1:4)))           ! ratio of screw to overall velocity determines edge generation
      rhoDotMultiplication(s,3:4) = sum(abs(gdot(s,3:4))) /prm%burgers(s) &                         ! assuming double-cross-slip of screws to be decisive for multiplication
                                  * sqrt(stt%rho_forest(s,of)) / prm%lambda0(s) ! &                 ! mean free path
                                  ! * 2.0_pReal * sum(abs(v(s,1:2))) / sum(abs(v(s,1:4)))           ! ratio of edge to overall velocity determines screw generation
    endforall

  else isBCC
    rhoDotMultiplication(:,1:4) = spread( &
          (sum(abs(gdot(:,1:2)),2) * prm%fEdgeMultiplication + sum(abs(gdot(:,3:4)),2)) &
        * sqrt(stt%rho_forest(:,of)) / prm%lambda0 / prm%burgers, 2, 4)
  endif isBCC

  forall (s = 1:ns, t = 1:4) v0(s,t) = plasticState(ph)%state0(iV(s,t,instance),of)

  !****************************************************************************
  !*** calculate dislocation fluxes (only for nonlocal plasticity)
  rhoDotFlux = 0.0_pReal
  if (.not. phase_localPlasticity(material_phaseAt(1,el))) then

    !*** check CFL (Courant-Friedrichs-Lewy) condition for flux
    if (any( abs(gdot) > 0.0_pReal &                                                                ! any active slip system ...
            .and. prm%CFLfactor * abs(v0) * timestep &
                > IPvolume(ip,el) / maxval(IParea(:,ip,el)))) then                                  ! ...with velocity above critical value (we use the reference volume and area for simplicity here)
# 1116 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_nonlocal.f90"
      plasticState(ph)%dotState = IEEE_value(1.0_pReal,IEEE_quiet_NaN)                               ! -> return NaN and, hence, enforce cutback
      return
    endif


    !*** be aware of the definition of slip_transverse = slip_direction x slip_normal !!!
    !*** opposite sign to our t vector in the (s,t,n) triplet !!!

    m(1:3,:,1) =  prm%slip_direction
    m(1:3,:,2) = -prm%slip_direction
    m(1:3,:,3) = -prm%slip_transverse
    m(1:3,:,4) =  prm%slip_transverse

    my_F = F(1:3,1:3,1,ip,el)
    my_Fe = matmul(my_F, math_inv33(Fp(1:3,1:3,1,ip,el)))

    neighbors: do n = 1,nIPneighbors

      neighbor_el = IPneighborhood(1,n,ip,el)
      neighbor_ip = IPneighborhood(2,n,ip,el)
      neighbor_n  = IPneighborhood(3,n,ip,el)
      np = material_phaseAt(1,neighbor_el)
      no = material_phasememberAt(1,neighbor_ip,neighbor_el)

      opposite_neighbor = n + mod(n,2) - mod(n+1,2)
      opposite_el = IPneighborhood(1,opposite_neighbor,ip,el)
      opposite_ip = IPneighborhood(2,opposite_neighbor,ip,el)
      opposite_n  = IPneighborhood(3,opposite_neighbor,ip,el)

      if (neighbor_n > 0) then                                                                      ! if neighbor exists, average deformation gradient
        neighbor_instance = phase_plasticityInstance(material_phaseAt(1,neighbor_el))
        neighbor_F = F(1:3,1:3,1,neighbor_ip,neighbor_el)
        neighbor_Fe = matmul(neighbor_F, math_inv33(Fp(1:3,1:3,1,neighbor_ip,neighbor_el)))
        Favg = 0.5_pReal * (my_F + neighbor_F)
      else                                                                                          ! if no neighbor, take my value as average
        Favg = my_F
      endif

      neighbor_v0 = 0.0_pReal        ! needed for check of sign change in flux density below

      !* FLUX FROM MY NEIGHBOR TO ME
      !* This is only considered, if I have a neighbor of nonlocal plasticity
      !* (also nonlocal constitutive law with local properties) that is at least a little bit
      !* compatible.
      !* If it's not at all compatible, no flux is arriving, because everything is dammed in front of
      !* my neighbor's interface.
      !* The entering flux from my neighbor will be distributed on my slip systems according to the
      !* compatibility
      if (neighbor_n > 0) then
      if (phase_plasticity(material_phaseAt(1,neighbor_el)) == PLASTICITY_NONLOCAL_ID .and. &
          any(compatibility(:,:,:,n,ip,el) > 0.0_pReal)) then

        forall (s = 1:ns, t = 1:4)
          neighbor_v0(s,t) =          plasticState(np)%state0(iV   (s,t,neighbor_instance),no)
          neighbor_rhoSgl0(s,t) = max(plasticState(np)%state0(iRhoU(s,t,neighbor_instance),no),0.0_pReal)
        endforall

        where (neighbor_rhoSgl0 * IPvolume(neighbor_ip,neighbor_el) ** 0.667_pReal < prm%significantN &
          .or. neighbor_rhoSgl0 < prm%significantRho) &
          neighbor_rhoSgl0 = 0.0_pReal
        normal_neighbor2me_defConf = math_det33(Favg) * matmul(math_inv33(transpose(Favg)), &
                                     IPareaNormal(1:3,neighbor_n,neighbor_ip,neighbor_el))          ! normal of the interface in (average) deformed configuration (pointing neighbor => me)
        normal_neighbor2me = matmul(transpose(neighbor_Fe), normal_neighbor2me_defConf) &
                           / math_det33(neighbor_Fe)                                                ! interface normal in the lattice configuration of my neighbor
        area = IParea(neighbor_n,neighbor_ip,neighbor_el) * norm2(normal_neighbor2me)
        normal_neighbor2me = normal_neighbor2me / norm2(normal_neighbor2me)                         ! normalize the surface normal to unit length
        do s = 1,ns
          do t = 1,4
            c = (t + 1) / 2
            topp = t + mod(t,2) - mod(t+1,2)
            if (neighbor_v0(s,t) * math_inner(m(1:3,s,t), normal_neighbor2me) > 0.0_pReal &         ! flux from my neighbor to me == entering flux for me
                .and. v0(s,t) * neighbor_v0(s,t) >= 0.0_pReal ) then                                ! ... only if no sign change in flux density
              lineLength = neighbor_rhoSgl0(s,t) * neighbor_v0(s,t) &
                         * math_inner(m(1:3,s,t), normal_neighbor2me) * area                        ! positive line length that wants to enter through this interface
              where (compatibility(c,:,s,n,ip,el) > 0.0_pReal) &
                rhoDotFlux(:,t) = rhoDotFlux(1:ns,t) &
                                + lineLength/IPvolume(ip,el)*compatibility(c,:,s,n,ip,el)**2.0_pReal    ! transferring to equally signed mobile dislocation type
              where (compatibility(c,:,s,n,ip,el) < 0.0_pReal) &
                rhoDotFlux(:,topp) = rhoDotFlux(:,topp) &
                                   + lineLength/IPvolume(ip,el)*compatibility(c,:,s,n,ip,el)**2.0_pReal ! transferring to opposite signed mobile dislocation type

            endif
          enddo
        enddo
      endif; endif


      !* FLUX FROM ME TO MY NEIGHBOR
      !* This is not considered, if my opposite neighbor has a different constitutive law than nonlocal (still considered for nonlocal law with local properties).
      !* Then, we assume, that the opposite(!) neighbor sends an equal amount of dislocations to me.
      !* So the net flux in the direction of my neighbor is equal to zero:
      !*    leaving flux to neighbor == entering flux from opposite neighbor
      !* In case of reduced transmissivity, part of the leaving flux is stored as dead dislocation density.
      !* That means for an interface of zero transmissivity the leaving flux is fully converted to dead dislocations.
      if (opposite_n > 0) then
      if (phase_plasticity(material_phaseAt(1,opposite_el)) == PLASTICITY_NONLOCAL_ID) then

        normal_me2neighbor_defConf = math_det33(Favg) &
                                   * matmul(math_inv33(transpose(Favg)),IPareaNormal(1:3,n,ip,el))  ! normal of the interface in (average) deformed configuration (pointing me => neighbor)
        normal_me2neighbor = matmul(transpose(my_Fe), normal_me2neighbor_defConf) &
                           / math_det33(my_Fe)                                                      ! interface normal in my lattice configuration
        area = IParea(n,ip,el) * norm2(normal_me2neighbor)
        normal_me2neighbor = normal_me2neighbor / norm2(normal_me2neighbor)                         ! normalize the surface normal to unit length
        do s = 1,ns
          do t = 1,4
            c = (t + 1) / 2
            if (v0(s,t) * math_inner(m(1:3,s,t), normal_me2neighbor) > 0.0_pReal ) then             ! flux from me to my neighbor == leaving flux for me (might also be a pure flux from my mobile density to dead density if interface not at all transmissive)
              if (v0(s,t) * neighbor_v0(s,t) >= 0.0_pReal) then                                     ! no sign change in flux density
                transmissivity = sum(compatibility(c,:,s,n,ip,el)**2.0_pReal)                       ! overall transmissivity from this slip system to my neighbor
              else                                                                                  ! sign change in flux density means sign change in stress which does not allow for dislocations to arive at the neighbor
                transmissivity = 0.0_pReal
              endif
              lineLength = my_rhoSgl0(s,t) * v0(s,t) &
                         * math_inner(m(1:3,s,t), normal_me2neighbor) * area                        ! positive line length of mobiles that wants to leave through this interface
              rhoDotFlux(s,t) = rhoDotFlux(s,t) - lineLength / IPvolume(ip,el)                      ! subtract dislocation flux from current type
              rhoDotFlux(s,t+4) = rhoDotFlux(s,t+4) &
                                + lineLength / IPvolume(ip,el) * (1.0_pReal - transmissivity) &
                                * sign(1.0_pReal, v0(s,t))                                          ! dislocation flux that is not able to leave through interface (because of low transmissivity) will remain as immobile single density at the material point
            endif
          enddo
        enddo
      endif; endif

    enddo neighbors
  endif



  !****************************************************************************
  !*** calculate dipole formation and annihilation

  !*** formation by glide
  do c = 1,2
    rhoDotSingle2DipoleGlide(:,2*c-1) = -2.0_pReal * dUpper(:,c) / prm%burgers &
                                                   * (      rhoSgl(:,2*c-1)  * abs(gdot(:,2*c)) &   ! negative mobile --> positive mobile
                                                      +     rhoSgl(:,2*c)    * abs(gdot(:,2*c-1)) & ! positive mobile --> negative mobile
                                                      + abs(rhoSgl(:,2*c+4)) * abs(gdot(:,2*c-1)))  ! positive mobile --> negative immobile

    rhoDotSingle2DipoleGlide(:,2*c) = -2.0_pReal * dUpper(:,c) / prm%burgers &
                                                 * (      rhoSgl(:,2*c-1)  * abs(gdot(:,2*c)) &     ! negative mobile --> positive mobile
                                                    +     rhoSgl(:,2*c)    * abs(gdot(:,2*c-1)) &   ! positive mobile --> negative mobile
                                                    + abs(rhoSgl(:,2*c+3)) * abs(gdot(:,2*c)))      ! negative mobile --> positive immobile

    rhoDotSingle2DipoleGlide(:,2*c+3) = -2.0_pReal * dUpper(:,c) / prm%burgers &
                                                   * rhoSgl(:,2*c+3) * abs(gdot(:,2*c))             ! negative mobile --> positive immobile

    rhoDotSingle2DipoleGlide(:,2*c+4) = -2.0_pReal * dUpper(:,c) / prm%burgers &
                                                   * rhoSgl(:,2*c+4) * abs(gdot(:,2*c-1))           ! positive mobile --> negative immobile

    rhoDotSingle2DipoleGlide(:,c+8) = abs(rhoDotSingle2DipoleGlide(:,2*c+3)) &
                                    + abs(rhoDotSingle2DipoleGlide(:,2*c+4)) &
                                    - rhoDotSingle2DipoleGlide(:,2*c-1) &
                                    - rhoDotSingle2DipoleGlide(:,2*c)
  enddo


  !*** athermal annihilation
  rhoDotAthermalAnnihilation = 0.0_pReal
  forall (c=1:2) &
    rhoDotAthermalAnnihilation(:,c+8) = -2.0_pReal * dLower(:,c) / prm%burgers &
       * (  2.0_pReal * (rhoSgl(:,2*c-1) * abs(gdot(:,2*c)) + rhoSgl(:,2*c) * abs(gdot(:,2*c-1))) &             ! was single hitting single
          + 2.0_pReal * (abs(rhoSgl(:,2*c+3)) * abs(gdot(:,2*c)) + abs(rhoSgl(:,2*c+4)) * abs(gdot(:,2*c-1))) & ! was single hitting immobile single or was immobile single hit by single
          + rhoDip(:,c) * (abs(gdot(:,2*c-1)) + abs(gdot(:,2*c))))                                              ! single knocks dipole constituent

  ! annihilated screw dipoles leave edge jogs behind on the colinear system
  if (lattice_structure(ph) == LATTICE_fcc_ID) &
    forall (s = 1:ns, prm%colinearSystem(s) > 0) &
      rhoDotAthermalAnnihilation(prm%colinearSystem(s),1:2) = - rhoDotAthermalAnnihilation(s,10) &
        * 0.25_pReal * sqrt(stt%rho_forest(s,of)) * (dUpper(s,2) + dLower(s,2)) * prm%edgeJogFactor


  !*** thermally activated annihilation of edge dipoles by climb
  rhoDotThermalAnnihilation = 0.0_pReal
  selfDiffusion = prm%Dsd0 * exp(-prm%selfDiffusionEnergy / (kB * Temperature))
  vClimb = prm%atomicVolume * selfDiffusion * prm%mu &
         / ( kB * Temperature  * PI * (1.0_pReal-prm%nu) * (dUpper(:,1) + dLower(:,1)))
  forall (s = 1:ns, dUpper(s,1) > dLower(s,1)) &
    rhoDotThermalAnnihilation(s,9) = max(- 4.0_pReal * rhoDip(s,1) * vClimb(s) / (dUpper(s,1) - dLower(s,1)), &
                                         - rhoDip(s,1) / timestep - rhoDotAthermalAnnihilation(s,9) &
                                                                  - rhoDotSingle2DipoleGlide(s,9))    ! make sure that we do not annihilate more dipoles than we have

  rhoDot = rhoDotFlux &
         + rhoDotMultiplication &
         + rhoDotSingle2DipoleGlide &
         + rhoDotAthermalAnnihilation &
         + rhoDotThermalAnnihilation

# 1325 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_nonlocal.f90"


  if (    any(rho(:,mob) + rhoDot(:,1:4)  * timestep < -prm%atol_rho) &
     .or. any(rho(:,dip) + rhoDot(:,9:10) * timestep < -prm%atol_rho)) then






    plasticState(ph)%dotState = IEEE_value(1.0_pReal,IEEE_quiet_NaN)
  else
    dot%rho(:,of) = pack(rhoDot,.true.)
    dot%gamma(:,of) = sum(gdot,2)
  endif

  end associate

end subroutine plastic_nonlocal_dotState


!--------------------------------------------------------------------------------------------------
!> @brief Compatibility update
!> @detail Compatibility is defined as normalized product of signed cosine of the angle between the slip
! plane normals and signed cosine of the angle between the slip directions. Only the largest values
! that sum up to a total of 1 are considered, all others are set to zero.
!--------------------------------------------------------------------------------------------------
module subroutine plastic_nonlocal_updateCompatibility(orientation,instance,i,e)

  type(rotation), dimension(1,discretization_nIP,discretization_nElem), intent(in) :: &
    orientation                                                                                     ! crystal orientation
  integer, intent(in) :: &
    instance, &
    i, &
    e

  integer :: &
    n, &                                                                                            ! neighbor index
    neighbor_e, &                                                                                   ! element index of my neighbor
    neighbor_i, &                                                                                   ! integration point index of my neighbor
    ph, &
    neighbor_phase, &
    ns, &                                                                                           ! number of active slip systems
    s1, &                                                                                           ! slip system index (me)
    s2                                                                                              ! slip system index (my neighbor)
  real(pReal), dimension(2,param(instance)%sum_N_sl,param(instance)%sum_N_sl,nIPneighbors) :: &
    my_compatibility                                                                                ! my_compatibility for current element and ip
  real(pReal) :: &
    my_compatibilitySum, &
    thresholdValue, &
    nThresholdValues
  logical, dimension(param(instance)%sum_N_sl) :: &
    belowThreshold
  type(rotation) :: mis

  ph = material_phaseAt(1,e)

  associate(prm => param(instance))
  ns = prm%sum_N_sl

  !*** start out fully compatible
  my_compatibility = 0.0_pReal
  forall(s1 = 1:ns) my_compatibility(:,s1,s1,:) = 1.0_pReal

  neighbors: do n = 1,nIPneighbors
    neighbor_e = IPneighborhood(1,n,i,e)
    neighbor_i = IPneighborhood(2,n,i,e)

    neighbor_phase = material_phaseAt(1,neighbor_e)

    if (neighbor_e <= 0 .or. neighbor_i <= 0) then
      !* FREE SURFACE
      !* Set surface transmissivity to the value specified in the material.config
      forall(s1 = 1:ns) my_compatibility(:,s1,s1,n) = sqrt(prm%surfaceTransmissivity)
    elseif (neighbor_phase /= ph) then
      !* PHASE BOUNDARY
      !* If we encounter a different nonlocal phase at the neighbor,
      !* we consider this to be a real "physical" phase boundary, so completely incompatible.
      !* If one of the two phases has a local plasticity law,
      !* we do not consider this to be a phase boundary, so completely compatible.
      if (.not. phase_localPlasticity(neighbor_phase) .and. .not. phase_localPlasticity(ph)) &
        forall(s1 = 1:ns) my_compatibility(:,s1,s1,n) = 0.0_pReal
    elseif (prm%grainboundaryTransmissivity >= 0.0_pReal) then
      !* GRAIN BOUNDARY !
      !* fixed transmissivity for adjacent ips with different texture (only if explicitly given in material.config)
      if (material_texture(1,i,e) /= material_texture(1,neighbor_i,neighbor_e) .and. &
          (.not. phase_localPlasticity(neighbor_phase))) &
        forall(s1 = 1:ns) my_compatibility(:,s1,s1,n) = sqrt(prm%grainboundaryTransmissivity)
    else
      !* GRAIN BOUNDARY ?
      !* Compatibility defined by relative orientation of slip systems:
      !* The my_compatibility value is defined as the product of the slip normal projection and the slip direction projection.
      !* Its sign is always positive for screws, for edges it has the same sign as the slip normal projection.
      !* Since the sum for each slip system can easily exceed one (which would result in a transmissivity larger than one),
      !* only values above or equal to a certain threshold value are considered. This threshold value is chosen, such that
      !* the number of compatible slip systems is minimized with the sum of the original compatibility values exceeding one.
      !* Finally the smallest compatibility value is decreased until the sum is exactly equal to one.
      !* All values below the threshold are set to zero.
      mis = orientation(1,i,e)%misorientation(orientation(1,neighbor_i,neighbor_e))
      mySlipSystems: do s1 = 1,ns
        neighborSlipSystems: do s2 = 1,ns
          my_compatibility(1,s2,s1,n) =     math_inner(prm%slip_normal(1:3,s1), &
                                                       mis%rotate(prm%slip_normal(1:3,s2))) &
                                      * abs(math_inner(prm%slip_direction(1:3,s1), &
                                                       mis%rotate(prm%slip_direction(1:3,s2))))
          my_compatibility(2,s2,s1,n) = abs(math_inner(prm%slip_normal(1:3,s1), &
                                                       mis%rotate(prm%slip_normal(1:3,s2)))) &
                                      * abs(math_inner(prm%slip_direction(1:3,s1), &
                                                       mis%rotate(prm%slip_direction(1:3,s2))))
        enddo neighborSlipSystems

        my_compatibilitySum = 0.0_pReal
        belowThreshold = .true.
        do while (my_compatibilitySum < 1.0_pReal .and. any(belowThreshold))
          thresholdValue = maxval(my_compatibility(2,:,s1,n), belowThreshold)                       ! screws always positive
          nThresholdValues = real(count(my_compatibility(2,:,s1,n) >= thresholdValue),pReal)
          where (my_compatibility(2,:,s1,n) >= thresholdValue) belowThreshold = .false.
          if (my_compatibilitySum + thresholdValue * nThresholdValues > 1.0_pReal) &
            where (abs(my_compatibility(:,:,s1,n)) >= thresholdValue) &
              my_compatibility(:,:,s1,n) = sign((1.0_pReal - my_compatibilitySum)/nThresholdValues,&
                                                 my_compatibility(:,:,s1,n))
          my_compatibilitySum = my_compatibilitySum + nThresholdValues * thresholdValue
        enddo

        where(belowThreshold) my_compatibility(1,:,s1,n) = 0.0_pReal
        where(belowThreshold) my_compatibility(2,:,s1,n) = 0.0_pReal

      enddo mySlipSystems
    endif

  enddo neighbors

  compatibility(:,:,:,:,i,e) = my_compatibility

  end associate

end subroutine plastic_nonlocal_updateCompatibility


!--------------------------------------------------------------------------------------------------
!> @brief writes results to HDF5 output file
!--------------------------------------------------------------------------------------------------
module subroutine plastic_nonlocal_results(instance,group)

  integer,         intent(in) :: instance
  character(len=*),intent(in) :: group

  integer :: o

  associate(prm => param(instance),dst => microstructure(instance),stt=>state(instance))
  outputsLoop: do o = 1,size(prm%output)
    select case(trim(prm%output(o)))
      case('rho_sgl_mob_edg_pos')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_sgl_mob_edg_pos, 'rho_sgl_mob_edg_pos', &
                                                     'positive mobile edge density','1/m²')
      case('rho_sgl_imm_edg_pos')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_sgl_imm_edg_pos, 'rho_sgl_imm_edg_pos',&
                                                     'positive immobile edge density','1/m²')
      case('rho_sgl_mob_edg_neg')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_sgl_mob_edg_neg, 'rho_sgl_mob_edg_neg',&
                                                     'negative mobile edge density','1/m²')
      case('rho_sgl_imm_edg_neg')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_sgl_imm_edg_neg, 'rho_sgl_imm_edg_neg',&
                                                     'negative immobile edge density','1/m²')
      case('rho_dip_edg')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_dip_edg, 'rho_dip_edg',&
                                                     'edge dipole density','1/m²')
      case('rho_sgl_mob_scr_pos')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_sgl_mob_scr_pos, 'rho_sgl_mob_scr_pos',&
                                                     'positive mobile screw density','1/m²')
      case('rho_sgl_imm_scr_pos')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_sgl_imm_scr_pos, 'rho_sgl_imm_scr_pos',&
                                                     'positive immobile screw density','1/m²')
      case('rho_sgl_mob_scr_neg')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_sgl_mob_scr_neg, 'rho_sgl_mob_scr_neg',&
                                                     'negative mobile screw density','1/m²')
      case('rho_sgl_imm_scr_neg')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_sgl_imm_scr_neg, 'rho_sgl_imm_scr_neg',&
                                                     'negative immobile screw density','1/m²')
      case('rho_dip_scr')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_dip_scr, 'rho_dip_scr',&
                                                     'screw dipole density','1/m²')
      case('rho_forest')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_forest, 'rho_forest',&
                                                     'forest density','1/m²')
      case('v_edg_pos')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%v_edg_pos, 'v_edg_pos',&
                                                     'positive edge velocity','m/s')
      case('v_edg_neg')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%v_edg_neg, 'v_edg_neg',&
                                                     'negative edge velocity','m/s')
      case('v_scr_pos')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%v_scr_pos, 'v_scr_pos',&
                                                     'positive srew velocity','m/s')
      case('v_scr_neg')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%v_scr_neg, 'v_scr_neg',&
                                                     'negative screw velocity','m/s')
      case('gamma')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%gamma,'gamma',&
                                                     'plastic shear','1')
      case('tau_pass')
        if(prm%sum_N_sl>0) call results_writeDataset(group,dst%tau_pass,'tau_pass',&
                                                     'passing stress for slip','Pa')
    end select
  enddo outputsLoop
  end associate

end subroutine plastic_nonlocal_results


!--------------------------------------------------------------------------------------------------
!> @brief populates the initial dislocation density
!--------------------------------------------------------------------------------------------------
subroutine stateInit(ini,phase,NipcMyPhase)

  type(tInitialParameters) :: &
    ini
  integer,intent(in) :: &
    phase, &
    NipcMyPhase
  integer :: &
    e, &
    i, &
    f, &
    from, &
    upto, &
    s, &
    instance, &
    phasemember
  real(pReal), dimension(2) :: &
    noise, &
    rnd
  real(pReal) :: &
    meanDensity, &
    totalVolume, &
    densityBinning, &
    minimumIpVolume
  real(pReal), dimension(NipcMyPhase) :: &
    volume

  instance = phase_plasticityInstance(phase)
  associate(stt => state(instance))

  if (ini%rhoSglRandom > 0.0_pReal) then ! randomly distribute dislocation segments on random slip system and of random type in the volume
    do e = 1,discretization_nElem
      do i = 1,discretization_nIP
        if (material_phaseAt(1,e) == phase) volume(material_phasememberAt(1,i,e)) = IPvolume(i,e)
      enddo
    enddo
    totalVolume     = sum(volume)
    minimumIPVolume = minval(volume)
    densityBinning  = ini%rhoSglRandomBinning / minimumIpVolume ** (2.0_pReal / 3.0_pReal)

    ! fill random material points with dislocation segments until the desired overall density is reached
    meanDensity = 0.0_pReal
    do while(meanDensity < ini%rhoSglRandom)
      call random_number(rnd)
      phasemember = nint(rnd(1)*real(NipcMyPhase,pReal) + 0.5_pReal)
      s           = nint(rnd(2)*real(sum(ini%N_sl),pReal)*4.0_pReal + 0.5_pReal)
      meanDensity = meanDensity + densityBinning * volume(phasemember) / totalVolume
      stt%rhoSglMobile(s,phasemember) = densityBinning
    enddo
  else                                ! homogeneous distribution with noise
    do e = 1, NipcMyPhase
      do f = 1,size(ini%N_sl,1)
        from = 1 + sum(ini%N_sl(1:f-1))
        upto = sum(ini%N_sl(1:f))
        do s = from,upto
          noise = [math_sampleGaussVar(0.0_pReal, ini%rhoSglScatter), &
                   math_sampleGaussVar(0.0_pReal, ini%rhoSglScatter)]
          stt%rho_sgl_mob_edg_pos(s,e) = ini%rhoSglEdgePos0(f)  + noise(1)
          stt%rho_sgl_mob_edg_neg(s,e) = ini%rhoSglEdgeNeg0(f)  + noise(1)
          stt%rho_sgl_mob_scr_pos(s,e) = ini%rhoSglScrewPos0(f) + noise(2)
          stt%rho_sgl_mob_scr_neg(s,e) = ini%rhoSglScrewNeg0(f) + noise(2)
        enddo
        stt%rho_dip_edg(from:upto,e)   = ini%rhoDipEdge0(f)
        stt%rho_dip_scr(from:upto,e)   = ini%rhoDipScrew0(f)
      enddo
    enddo
  endif

  end associate

end subroutine stateInit


!--------------------------------------------------------------------------------------------------
!> @brief calculates kinetics
!--------------------------------------------------------------------------------------------------
subroutine kinetics(v, dv_dtau, dv_dtauNS, tau, tauNS, tauThreshold, c, Temperature, instance)

  integer, intent(in) :: &
    c, &                                                                                            !< dislocation character (1:edge, 2:screw)
    instance
  real(pReal), intent(in) :: &
    Temperature                                                                                     !< temperature
  real(pReal), dimension(param(instance)%sum_N_sl), intent(in) :: &
    tau, &                                                                                          !< resolved external shear stress (without non Schmid effects)
    tauNS, &                                                                                        !< resolved external shear stress (including non Schmid effects)
    tauThreshold                                                                                    !< threshold shear stress
  real(pReal), dimension(param(instance)%sum_N_sl), intent(out) ::  &
    v, &                                                                                            !< velocity
    dv_dtau, &                                                                                      !< velocity derivative with respect to resolved shear stress (without non Schmid contributions)
    dv_dtauNS                                                                                       !< velocity derivative with respect to resolved shear stress (including non Schmid contributions)

  integer :: &
    ns, &                                                                                           !< short notation for the total number of active slip systems
    s                                                                                               !< index of my current slip system
  real(pReal) :: &
    tauRel_P, &
    tauRel_S, &
    tauEff, &                                                                                       !< effective shear stress
    tPeierls, &                                                                                     !< waiting time in front of a peierls barriers
    tSolidSolution, &                                                                               !< waiting time in front of a solid solution obstacle
    vViscous, &                                                                                     !< viscous glide velocity
    dtPeierls_dtau, &                                                                               !< derivative with respect to resolved shear stress
    dtSolidSolution_dtau, &                                                                         !< derivative with respect to resolved shear stress
    meanfreepath_S, &                                                                               !< mean free travel distance for dislocations between two solid solution obstacles
    meanfreepath_P, &                                                                               !< mean free travel distance for dislocations between two Peierls barriers
    jumpWidth_P, &                                                                                  !< depth of activated area
    jumpWidth_S, &                                                                                  !< depth of activated area
    activationLength_P, &                                                                           !< length of activated dislocation line
    activationLength_S, &                                                                           !< length of activated dislocation line
    activationVolume_P, &                                                                           !< volume that needs to be activated to overcome barrier
    activationVolume_S, &                                                                           !< volume that needs to be activated to overcome barrier
    activationEnergy_P, &                                                                           !< energy that is needed to overcome barrier
    activationEnergy_S, &                                                                           !< energy that is needed to overcome barrier
    criticalStress_P, &                                                                             !< maximum obstacle strength
    criticalStress_S, &                                                                             !< maximum obstacle strength
    mobility                                                                                        !< dislocation mobility

  associate(prm => param(instance))
  ns = prm%sum_N_sl
  v = 0.0_pReal
  dv_dtau = 0.0_pReal
  dv_dtauNS = 0.0_pReal

  do s = 1,ns
    if (abs(tau(s)) > tauThreshold(s)) then

      !* Peierls contribution
      !* Effective stress includes non Schmid constributions
      !* The derivative only gives absolute values; the correct sign is taken care of in the formula for the derivative of the velocity
      tauEff = max(0.0_pReal, abs(tauNS(s)) - tauThreshold(s))                                      ! ensure that the effective stress is positive
      meanfreepath_P = prm%burgers(s)
      jumpWidth_P = prm%burgers(s)
      activationLength_P = prm%doublekinkwidth *prm%burgers(s)
      activationVolume_P = activationLength_P * jumpWidth_P * prm%burgers(s)
      criticalStress_P = prm%peierlsStress(s,c)
      activationEnergy_P = criticalStress_P * activationVolume_P
      tauRel_P = min(1.0_pReal, tauEff / criticalStress_P)                                          ! ensure that the activation probability cannot become greater than one
      tPeierls = 1.0_pReal / prm%fattack &
               * exp(activationEnergy_P / (kB * Temperature) &
                     * (1.0_pReal - tauRel_P**prm%p)**prm%q)
      if (tauEff < criticalStress_P) then
        dtPeierls_dtau = tPeierls * prm%p * prm%q * activationVolume_P / (kB * Temperature) &
                       * (1.0_pReal - tauRel_P**prm%p)**(prm%q-1.0_pReal) * tauRel_P**(prm%p-1.0_pReal)
      else
        dtPeierls_dtau = 0.0_pReal
      endif

      !* Contribution from solid solution strengthening
      !* The derivative only gives absolute values; the correct sign is taken care of in the formula for the derivative of the velocity
      tauEff = abs(tau(s)) - tauThreshold(s)
      meanfreepath_S = prm%burgers(s) / sqrt(prm%solidSolutionConcentration)
      jumpWidth_S = prm%solidSolutionSize * prm%burgers(s)
      activationLength_S = prm%burgers(s) / sqrt(prm%solidSolutionConcentration)
      activationVolume_S = activationLength_S * jumpWidth_S * prm%burgers(s)
      activationEnergy_S = prm%solidSolutionEnergy
      criticalStress_S = activationEnergy_S / activationVolume_S
      tauRel_S = min(1.0_pReal, tauEff / criticalStress_S)                                          ! ensure that the activation probability cannot become greater than one
      tSolidSolution = 1.0_pReal /  prm%fattack &
                     * exp(activationEnergy_S / (kB * Temperature)* (1.0_pReal - tauRel_S**prm%p)**prm%q)
      if (tauEff < criticalStress_S) then
        dtSolidSolution_dtau = tSolidSolution * prm%p * prm%q * activationVolume_S / (kB * Temperature) &
                             * (1.0_pReal - tauRel_S**prm%p)**(prm%q-1.0_pReal)* tauRel_S**(prm%p-1.0_pReal)
      else
        dtSolidSolution_dtau = 0.0_pReal
      endif

      !* viscous glide velocity
      tauEff = abs(tau(s)) - tauThreshold(s)
      mobility = prm%burgers(s) / prm%viscosity
      vViscous = mobility * tauEff

      !* Mean velocity results from waiting time at peierls barriers and solid solution obstacles with respective meanfreepath of
      !* free flight at glide velocity in between.
      !* adopt sign from resolved stress
      v(s) = sign(1.0_pReal,tau(s)) &
           / (tPeierls / meanfreepath_P + tSolidSolution / meanfreepath_S + 1.0_pReal / vViscous)
      dv_dtau(s)   = v(s)**2.0_pReal * (dtSolidSolution_dtau / meanfreepath_S + mobility /vViscous**2.0_pReal)
      dv_dtauNS(s) = v(s)**2.0_pReal * dtPeierls_dtau / meanfreepath_P
    endif
  enddo

  end associate

end subroutine kinetics


!--------------------------------------------------------------------------------------------------
!> @brief returns copy of current dislocation densities from state
!> @details raw values is rectified
!--------------------------------------------------------------------------------------------------
function getRho(instance,of,ip,el)

  integer, intent(in) :: instance, of,ip,el
  real(pReal), dimension(param(instance)%sum_N_sl,10) :: getRho

  associate(prm => param(instance))

  getRho = reshape(state(instance)%rho(:,of),[prm%sum_N_sl,10])

  ! ensure positive densities (not for imm, they have a sign)
  getRho(:,mob) = max(getRho(:,mob),0.0_pReal)
  getRho(:,dip) = max(getRho(:,dip),0.0_pReal)

  where(abs(getRho) < max(prm%significantN/IPvolume(ip,el)**(2.0_pReal/3.0_pReal),prm%significantRho)) &
    getRho = 0.0_pReal

  end associate

end function getRho


!--------------------------------------------------------------------------------------------------
!> @brief returns copy of current dislocation densities from state
!> @details raw values is rectified
!--------------------------------------------------------------------------------------------------
function getRho0(instance,of,ip,el)

  integer, intent(in) :: instance, of,ip,el
  real(pReal), dimension(param(instance)%sum_N_sl,10) :: getRho0

  associate(prm => param(instance))

  getRho0 = reshape(state0(instance)%rho(:,of),[prm%sum_N_sl,10])

  ! ensure positive densities (not for imm, they have a sign)
  getRho0(:,mob) = max(getRho0(:,mob),0.0_pReal)
  getRho0(:,dip) = max(getRho0(:,dip),0.0_pReal)

  where(abs(getRho0) < max(prm%significantN/IPvolume(ip,el)**(2.0_pReal/3.0_pReal),prm%significantRho)) &
    getRho0 = 0.0_pReal

  end associate

end function getRho0

end submodule plastic_nonlocal
# 44 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2

# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/crystallite.f90" 1
!--------------------------------------------------------------------------------------------------
!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH
!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH
!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH
!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH
!> @author Christoph Kords, Max-Planck-Institut für Eisenforschung GmbH
!> @author Chen Zhang, Michigan State University
!> @brief crystallite state integration functions and reporting of results
!--------------------------------------------------------------------------------------------------

module crystallite
  use prec
  use IO
  use HDF5_utilities
  use DAMASK_interface
  use config
  use debug
  use numerics
  use rotations
  use math
  use FEsolving
  use material
  use constitutive
  use discretization
  use lattice
  use results

  implicit none
  private

  real(pReal),               dimension(:,:,:),        allocatable, public :: &
    crystallite_dt                                                                                  !< requested time increment of each grain
  real(pReal),               dimension(:,:,:),        allocatable :: &
    crystallite_subdt, &                                                                            !< substepped time increment of each grain
    crystallite_subFrac, &                                                                          !< already calculated fraction of increment
    crystallite_subStep                                                                             !< size of next integration step
  type(rotation),            dimension(:,:,:),        allocatable :: &
    crystallite_orientation                                                                         !< current orientation
  real(pReal),               dimension(:,:,:,:,:),    allocatable, public, protected :: &
    crystallite_Fe, &                                                                               !< current "elastic" def grad (end of converged time step)
    crystallite_P, &                                                                                !< 1st Piola-Kirchhoff stress per grain
    crystallite_S0, &                                                                               !< 2nd Piola-Kirchhoff stress vector at start of FE inc
    crystallite_Fp0, &                                                                              !< plastic def grad at start of FE inc
    crystallite_Fi0, &                                                                              !< intermediate def grad at start of FE inc
    crystallite_F0, &                                                                               !< def grad at start of FE inc
    crystallite_Lp0, &                                                                              !< plastic velocitiy grad at start of FE inc
    crystallite_Li0                                                                                 !< intermediate velocitiy grad at start of FE inc
  real(pReal),               dimension(:,:,:,:,:),    allocatable, public :: &
    crystallite_S, &                                                                                !< current 2nd Piola-Kirchhoff stress vector (end of converged time step)
    crystallite_partionedS0, &                                                                      !< 2nd Piola-Kirchhoff stress vector at start of homog inc
    crystallite_Fp, &                                                                               !< current plastic def grad (end of converged time step)
    crystallite_partionedFp0,&                                                                      !< plastic def grad at start of homog inc
    crystallite_Fi, &                                                                               !< current intermediate def grad (end of converged time step)
    crystallite_partionedFi0,&                                                                      !< intermediate def grad at start of homog inc
    crystallite_partionedF,  &                                                                      !< def grad to be reached at end of homog inc
    crystallite_partionedF0, &                                                                      !< def grad at start of homog inc
    crystallite_Lp, &                                                                               !< current plastic velocitiy grad (end of converged time step)
    crystallite_partionedLp0, &                                                                     !< plastic velocity grad at start of homog inc
    crystallite_Li, &                                                                               !< current intermediate velocitiy grad (end of converged time step)
    crystallite_partionedLi0                                                                        !< intermediate velocity grad at start of homog inc
  real(pReal),                dimension(:,:,:,:,:),    allocatable :: &
    crystallite_subFp0,&                                                                            !< plastic def grad at start of crystallite inc
    crystallite_subFi0,&                                                                            !< intermediate def grad at start of crystallite inc
    crystallite_subF,  &                                                                            !< def grad to be reached at end of crystallite inc
    crystallite_subF0, &                                                                            !< def grad at start of crystallite inc
    crystallite_subLp0,&                                                                            !< plastic velocity grad at start of crystallite inc
    crystallite_subLi0                                                                              !< intermediate velocity grad at start of crystallite inc
  real(pReal),                dimension(:,:,:,:,:,:,:), allocatable, public, protected :: &
    crystallite_dPdF                                                                                !< current individual dPdF per grain (end of converged time step)
  logical,                    dimension(:,:,:),         allocatable, public :: &
    crystallite_requested                                                                           !< used by upper level (homogenization) to request crystallite calculation
  logical,                    dimension(:,:,:),         allocatable :: &
    crystallite_converged, &                                                                        !< convergence flag
    crystallite_todo, &                                                                             !< flag to indicate need for further computation
    crystallite_localPlasticity                                                                     !< indicates this grain to have purely local constitutive law

  type :: tOutput                                                                                   !< new requested output (per phase)
    character(len=pStringLen), allocatable, dimension(:) :: &
      label
  end type tOutput
  type(tOutput), allocatable, dimension(:) :: output_constituent

  type :: tNumerics
    integer :: &
      iJacoLpresiduum, &                                                                            !< frequency of Jacobian update of residuum in Lp
      nState, &                                                                                     !< state loop limit
      nStress                                                                                       !< stress loop limit
    real(pReal) :: &
      subStepMinCryst, &                                                                            !< minimum (relative) size of sub-step allowed during cutback
      subStepSizeCryst, &                                                                           !< size of first substep when cutback
      subStepSizeLp, &                                                                              !< size of first substep when cutback in Lp calculation
      subStepSizeLi, &                                                                              !< size of first substep when cutback in Li calculation
      stepIncreaseCryst, &                                                                          !< increase of next substep size when previous substep converged
      rtol_crystalliteState, &                                                                      !< relative tolerance in state loop
      rtol_crystalliteStress, &                                                                     !< relative tolerance in stress loop
      atol_crystalliteStress                                                                        !< absolute tolerance in stress loop
  end type tNumerics

  type(tNumerics) :: num                                                                            ! numerics parameters. Better name?

  procedure(), pointer :: integrateState

  public :: &
    crystallite_init, &
    crystallite_stress, &
    crystallite_stressTangent, &
    crystallite_orientations, &
    crystallite_push33ToRef, &
    crystallite_results, &
    crystallite_restartWrite, &
    crystallite_restartRead, &
    crystallite_forward

contains


!--------------------------------------------------------------------------------------------------
!> @brief allocates and initialize per grain variables
!--------------------------------------------------------------------------------------------------
subroutine crystallite_init

  logical, dimension(discretization_nIP,discretization_nElem) :: devNull
  integer :: &
    c, &                                                                                            !< counter in integration point component loop
    i, &                                                                                            !< counter in integration point loop
    e, &                                                                                            !< counter in element loop
    cMax, &                                                                                         !< maximum number of  integration point components
    iMax, &                                                                                         !< maximum number of integration points
    eMax, &                                                                                         !< maximum number of elements
    myNcomponents                                                                                   !< number of components at current IP

  write(6,'(/,a)')   ' <<<+-  crystallite init  -+>>>'

  cMax = homogenization_maxNgrains
  iMax = discretization_nIP
  eMax = discretization_nElem

  allocate(crystallite_partionedF(3,3,cMax,iMax,eMax),source=0.0_pReal)

  allocate(crystallite_S0, &
           crystallite_F0, crystallite_Fi0,crystallite_Fp0, &
                           crystallite_Li0,crystallite_Lp0, &
           crystallite_partionedS0, &
           crystallite_partionedF0,crystallite_partionedFp0,crystallite_partionedFi0, &
                                   crystallite_partionedLp0,crystallite_partionedLi0, &
           crystallite_S,crystallite_P, &
           crystallite_Fe,crystallite_Fi,crystallite_Fp, &
                          crystallite_Li,crystallite_Lp, &
           crystallite_subF,crystallite_subF0, &
           crystallite_subFp0,crystallite_subFi0, &
           crystallite_subLi0,crystallite_subLp0, &
           source = crystallite_partionedF)

  allocate(crystallite_dPdF(3,3,3,3,cMax,iMax,eMax),source=0.0_pReal)

  allocate(crystallite_dt(cMax,iMax,eMax),source=0.0_pReal)
  allocate(crystallite_subdt,crystallite_subFrac,crystallite_subStep, &
           source = crystallite_dt)

  allocate(crystallite_orientation(cMax,iMax,eMax))

  allocate(crystallite_localPlasticity(cMax,iMax,eMax),       source=.true.)
  allocate(crystallite_requested(cMax,iMax,eMax),             source=.false.)
  allocate(crystallite_todo(cMax,iMax,eMax),                  source=.false.)
  allocate(crystallite_converged(cMax,iMax,eMax),             source=.true.)

  num%subStepMinCryst        = config_numerics%getFloat('substepmincryst',       defaultVal=1.0e-3_pReal)
  num%subStepSizeCryst       = config_numerics%getFloat('substepsizecryst',      defaultVal=0.25_pReal)
  num%stepIncreaseCryst      = config_numerics%getFloat('stepincreasecryst',     defaultVal=1.5_pReal)

  num%subStepSizeLp          = config_numerics%getFloat('substepsizelp',         defaultVal=0.5_pReal)
  num%subStepSizeLi          = config_numerics%getFloat('substepsizeli',         defaultVal=0.5_pReal)

  num%rtol_crystalliteState  = config_numerics%getFloat('rtol_crystallitestate', defaultVal=1.0e-6_pReal)
  num%rtol_crystalliteStress = config_numerics%getFloat('rtol_crystallitestress',defaultVal=1.0e-6_pReal)
  num%atol_crystalliteStress = config_numerics%getFloat('atol_crystallitestress',defaultVal=1.0e-8_pReal)

  num%iJacoLpresiduum        = config_numerics%getInt  ('ijacolpresiduum',       defaultVal=1)

  num%nState                 = config_numerics%getInt  ('nstate',                defaultVal=20)
  num%nStress                = config_numerics%getInt  ('nstress',               defaultVal=40)

  if(num%subStepMinCryst   <= 0.0_pReal)      call IO_error(301,ext_msg='subStepMinCryst')
  if(num%subStepSizeCryst  <= 0.0_pReal)      call IO_error(301,ext_msg='subStepSizeCryst')
  if(num%stepIncreaseCryst <= 0.0_pReal)      call IO_error(301,ext_msg='stepIncreaseCryst')

  if(num%subStepSizeLp <= 0.0_pReal)          call IO_error(301,ext_msg='subStepSizeLp')
  if(num%subStepSizeLi <= 0.0_pReal)          call IO_error(301,ext_msg='subStepSizeLi')

  if(num%rtol_crystalliteState  <= 0.0_pReal) call IO_error(301,ext_msg='rtol_crystalliteState')
  if(num%rtol_crystalliteStress <= 0.0_pReal) call IO_error(301,ext_msg='rtol_crystalliteStress')
  if(num%atol_crystalliteStress <= 0.0_pReal) call IO_error(301,ext_msg='atol_crystalliteStress')

  if(num%iJacoLpresiduum < 1)                 call IO_error(301,ext_msg='iJacoLpresiduum')

  if(num%nState < 1)                          call IO_error(301,ext_msg='nState')
  if(num%nStress< 1)                          call IO_error(301,ext_msg='nStress')

  select case(numerics_integrator)
    case(1)
      integrateState => integrateStateFPI
    case(2)
      integrateState => integrateStateEuler
    case(3)
      integrateState => integrateStateAdaptiveEuler
    case(4)
      integrateState => integrateStateRK4
    case(5)
      integrateState => integrateStateRKCK45
  end select

  allocate(output_constituent(size(config_phase)))
  do c = 1, size(config_phase)

    allocate(output_constituent(c)%label(1))
    output_constituent(c)%label(1)= 'GfortranBug86277'
    output_constituent(c)%label  = config_phase(c)%getStrings('(output)',defaultVal=output_constituent(c)%label )
    if (output_constituent(c)%label (1) == 'GfortranBug86277') output_constituent(c)%label  = [character(len=pStringLen)::]



  enddo

  call config_deallocate('material.config/phase')

!--------------------------------------------------------------------------------------------------
! initialize
 !$OMP PARALLEL DO PRIVATE(myNcomponents,i,c)
  do e = FEsolving_execElem(1),FEsolving_execElem(2)
    myNcomponents = homogenization_Ngrains(material_homogenizationAt(e))
    do i = FEsolving_execIP(1), FEsolving_execIP(2); do c = 1, myNcomponents
      crystallite_Fp0(1:3,1:3,c,i,e) = material_orientation0(c,i,e)%asMatrix()                      ! plastic def gradient reflects init orientation
      crystallite_Fp0(1:3,1:3,c,i,e) = crystallite_Fp0(1:3,1:3,c,i,e) &
                                     / math_det33(crystallite_Fp0(1:3,1:3,c,i,e))**(1.0_pReal/3.0_pReal)
      crystallite_Fi0(1:3,1:3,c,i,e) = constitutive_initialFi(c,i,e)
      crystallite_F0(1:3,1:3,c,i,e)  = math_I3
      crystallite_localPlasticity(c,i,e) = phase_localPlasticity(material_phaseAt(c,e))
      crystallite_Fe(1:3,1:3,c,i,e)  = math_inv33(matmul(crystallite_Fi0(1:3,1:3,c,i,e), &
                                                         crystallite_Fp0(1:3,1:3,c,i,e)))           ! assuming that euler angles are given in internal strain free configuration
      crystallite_Fp(1:3,1:3,c,i,e)  = crystallite_Fp0(1:3,1:3,c,i,e)
      crystallite_Fi(1:3,1:3,c,i,e)  = crystallite_Fi0(1:3,1:3,c,i,e)
      crystallite_requested(c,i,e) = .true.
    enddo; enddo
  enddo
  !$OMP END PARALLEL DO

  if(any(.not. crystallite_localPlasticity) .and. .not. usePingPong) call IO_error(601)             ! exit if nonlocal but no ping-pong ToDo: Why not check earlier? or in nonlocal?

  crystallite_partionedFp0 = crystallite_Fp0
  crystallite_partionedFi0 = crystallite_Fi0
  crystallite_partionedF0  = crystallite_F0
  crystallite_partionedF   = crystallite_F0

  call crystallite_orientations()

  !$OMP PARALLEL DO
  do e = FEsolving_execElem(1),FEsolving_execElem(2)
    do i = FEsolving_execIP(1),FEsolving_execIP(2)
      do c = 1,homogenization_Ngrains(material_homogenizationAt(e))
        call constitutive_dependentState(crystallite_partionedF0(1:3,1:3,c,i,e), &
                                         crystallite_partionedFp0(1:3,1:3,c,i,e), &
                                         c,i,e)                                                     ! update dependent state variables to be consistent with basic states
     enddo
    enddo
  enddo
  !$OMP END PARALLEL DO

  devNull = crystallite_stress()
  call crystallite_stressTangent

# 283 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/crystallite.f90"

end subroutine crystallite_init


!--------------------------------------------------------------------------------------------------
!> @brief calculate stress (P)
!--------------------------------------------------------------------------------------------------
function crystallite_stress(dummyArgumentToPreventInternalCompilerErrorWithGCC)

  logical, dimension(discretization_nIP,discretization_nElem) :: crystallite_stress
  real(pReal), intent(in), optional :: &
    dummyArgumentToPreventInternalCompilerErrorWithGCC
  real(pReal) :: &
    formerSubStep
  integer :: &
    NiterationCrystallite, &                                                                        ! number of iterations in crystallite loop
    c, &                                                                                            !< counter in integration point component loop
    i, &                                                                                            !< counter in integration point loop
    e, &                                                                                            !< counter in element loop
    startIP, endIP, &
    s

# 325 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/crystallite.f90"

!--------------------------------------------------------------------------------------------------
! initialize to starting condition
  crystallite_subStep = 0.0_pReal
  !$OMP PARALLEL DO
  elementLooping1: do e = FEsolving_execElem(1),FEsolving_execElem(2)
    do i = FEsolving_execIP(1),FEsolving_execIP(2); do c = 1,homogenization_Ngrains(material_homogenizationAt(e))
      homogenizationRequestsCalculation: if (crystallite_requested(c,i,e)) then
        plasticState    (material_phaseAt(c,e))%subState0(      :,material_phaseMemberAt(c,i,e)) = &
        plasticState    (material_phaseAt(c,e))%partionedState0(:,material_phaseMemberAt(c,i,e))

        do s = 1, phase_Nsources(material_phaseAt(c,e))
          sourceState(material_phaseAt(c,e))%p(s)%subState0(      :,material_phaseMemberAt(c,i,e)) = &
          sourceState(material_phaseAt(c,e))%p(s)%partionedState0(:,material_phaseMemberAt(c,i,e))
        enddo
        crystallite_subFp0(1:3,1:3,c,i,e) = crystallite_partionedFp0(1:3,1:3,c,i,e)
        crystallite_subLp0(1:3,1:3,c,i,e) = crystallite_partionedLp0(1:3,1:3,c,i,e)
        crystallite_subFi0(1:3,1:3,c,i,e) = crystallite_partionedFi0(1:3,1:3,c,i,e)
        crystallite_subLi0(1:3,1:3,c,i,e) = crystallite_partionedLi0(1:3,1:3,c,i,e)
        crystallite_subF0(1:3,1:3,c,i,e)  = crystallite_partionedF0(1:3,1:3,c,i,e)
        crystallite_subFrac(c,i,e) = 0.0_pReal
        crystallite_subStep(c,i,e) = 1.0_pReal/num%subStepSizeCryst
        crystallite_todo(c,i,e) = .true.
        crystallite_converged(c,i,e) = .false.                                                      ! pretend failed step of 1/subStepSizeCryst
      endif homogenizationRequestsCalculation
    enddo; enddo
  enddo elementLooping1
  !$OMP END PARALLEL DO

  singleRun: if (FEsolving_execELem(1) == FEsolving_execElem(2) .and. &
                 FEsolving_execIP  (1) == FEsolving_execIP  (2)) then
    startIP = FEsolving_execIP(1)
    endIP   = startIP
  else singleRun
    startIP = 1
    endIP   = discretization_nIP
  endif singleRun

  NiterationCrystallite = 0
  cutbackLooping: do while (any(crystallite_todo(:,startIP:endIP,FEsolving_execELem(1):FEsolving_execElem(2))))
    NiterationCrystallite = NiterationCrystallite + 1





    !$OMP PARALLEL DO PRIVATE(formerSubStep)
    elementLooping3: do e = FEsolving_execElem(1),FEsolving_execElem(2)
      do i = FEsolving_execIP(1),FEsolving_execIP(2)
        do c = 1,homogenization_Ngrains(material_homogenizationAt(e))
!--------------------------------------------------------------------------------------------------
!  wind forward
          if (crystallite_converged(c,i,e)) then
            formerSubStep = crystallite_subStep(c,i,e)
            crystallite_subFrac(c,i,e) = crystallite_subFrac(c,i,e) + crystallite_subStep(c,i,e)
            crystallite_subStep(c,i,e) = min(1.0_pReal - crystallite_subFrac(c,i,e), &
                                             num%stepIncreaseCryst * crystallite_subStep(c,i,e))

            crystallite_todo(c,i,e) = crystallite_subStep(c,i,e) > 0.0_pReal                        ! still time left to integrate on?
            if (crystallite_todo(c,i,e)) then
              crystallite_subF0 (1:3,1:3,c,i,e) = crystallite_subF(1:3,1:3,c,i,e)
              crystallite_subLp0(1:3,1:3,c,i,e) = crystallite_Lp  (1:3,1:3,c,i,e)
              crystallite_subLi0(1:3,1:3,c,i,e) = crystallite_Li  (1:3,1:3,c,i,e)
              crystallite_subFp0(1:3,1:3,c,i,e) = crystallite_Fp  (1:3,1:3,c,i,e)
              crystallite_subFi0(1:3,1:3,c,i,e) = crystallite_Fi  (1:3,1:3,c,i,e)
              !if abbrevation, make c and p private in omp
              plasticState(    material_phaseAt(c,e))%subState0(:,material_phaseMemberAt(c,i,e)) &
                = plasticState(material_phaseAt(c,e))%state(    :,material_phaseMemberAt(c,i,e))
              do s = 1, phase_Nsources(material_phaseAt(c,e))
                sourceState(    material_phaseAt(c,e))%p(s)%subState0(:,material_phaseMemberAt(c,i,e)) &
                  = sourceState(material_phaseAt(c,e))%p(s)%state(    :,material_phaseMemberAt(c,i,e))
              enddo
            endif

!--------------------------------------------------------------------------------------------------
!  cut back (reduced time and restore)
          else
            crystallite_subStep(c,i,e)       = num%subStepSizeCryst * crystallite_subStep(c,i,e)
            crystallite_Fp   (1:3,1:3,c,i,e) =            crystallite_subFp0(1:3,1:3,c,i,e)
            crystallite_Fi   (1:3,1:3,c,i,e) =            crystallite_subFi0(1:3,1:3,c,i,e)
            crystallite_S    (1:3,1:3,c,i,e) =            crystallite_S0    (1:3,1:3,c,i,e)
            if (crystallite_subStep(c,i,e) < 1.0_pReal) then                                        ! actual (not initial) cutback
              crystallite_Lp (1:3,1:3,c,i,e) =            crystallite_subLp0(1:3,1:3,c,i,e)
              crystallite_Li (1:3,1:3,c,i,e) =            crystallite_subLi0(1:3,1:3,c,i,e)
            endif
            plasticState    (material_phaseAt(c,e))%state(    :,material_phaseMemberAt(c,i,e)) &
              = plasticState(material_phaseAt(c,e))%subState0(:,material_phaseMemberAt(c,i,e))
            do s = 1, phase_Nsources(material_phaseAt(c,e))
              sourceState(    material_phaseAt(c,e))%p(s)%state(    :,material_phaseMemberAt(c,i,e)) &
                = sourceState(material_phaseAt(c,e))%p(s)%subState0(:,material_phaseMemberAt(c,i,e))
            enddo

                                                                                                    ! cant restore dotState here, since not yet calculated in first cutback after initialization
            crystallite_todo(c,i,e) = crystallite_subStep(c,i,e) > num%subStepMinCryst              ! still on track or already done (beyond repair)
          endif

!--------------------------------------------------------------------------------------------------
!  prepare for integration
          if (crystallite_todo(c,i,e)) then
            crystallite_subF(1:3,1:3,c,i,e) = crystallite_subF0(1:3,1:3,c,i,e) &
                                            + crystallite_subStep(c,i,e) *( crystallite_partionedF (1:3,1:3,c,i,e) &
                                                                           -crystallite_partionedF0(1:3,1:3,c,i,e))
            crystallite_Fe(1:3,1:3,c,i,e) = matmul(matmul(crystallite_subF(1:3,1:3,c,i,e), &
                                                          math_inv33(crystallite_Fp(1:3,1:3,c,i,e))), &
                                                   math_inv33(crystallite_Fi(1:3,1:3,c,i,e)))
            crystallite_subdt(c,i,e) = crystallite_subStep(c,i,e) * crystallite_dt(c,i,e)
            crystallite_converged(c,i,e) = .false.
          endif

        enddo
      enddo
    enddo elementLooping3
    !$OMP END PARALLEL DO

!--------------------------------------------------------------------------------------------------
!  integrate --- requires fully defined state array (basic + dependent state)
    if (any(crystallite_todo)) call integrateState                                                  ! TODO: unroll into proper elementloop to avoid N^2 for single point evaluation
    where(.not. crystallite_converged .and. crystallite_subStep > num%subStepMinCryst) &            ! do not try non-converged but fully cutbacked any further
      crystallite_todo = .true.                                                                     ! TODO: again unroll this into proper elementloop to avoid N^2 for single point evaluation


  enddo cutbackLooping

! return whether converged or not
  crystallite_stress = .false.
  elementLooping5: do e = FEsolving_execElem(1),FEsolving_execElem(2)
    do i = FEsolving_execIP(1),FEsolving_execIP(2)
      crystallite_stress(i,e) = all(crystallite_converged(:,i,e))
    enddo
  enddo elementLooping5

end function crystallite_stress


!--------------------------------------------------------------------------------------------------
!> @brief calculate tangent (dPdF)
!--------------------------------------------------------------------------------------------------
subroutine crystallite_stressTangent

  integer :: &
    c, &                                                                                            !< counter in integration point component loop
    i, &                                                                                            !< counter in integration point loop
    e, &                                                                                            !< counter in element loop
    o, &
    p

  real(pReal), dimension(3,3)     ::   devNull, &
                                       invSubFp0,invSubFi0,invFp,invFi, &
                                       temp_33_1, temp_33_2, temp_33_3, temp_33_4
  real(pReal), dimension(3,3,3,3) ::   dSdFe, &
                                       dSdF, &
                                       dSdFi, &
                                       dLidS, &                                                     ! tangent in lattice configuration
                                       dLidFi, &
                                       dLpdS, &
                                       dLpdFi, &
                                       dFidS, &
                                       dFpinvdF, &
                                       rhs_3333, &
                                       lhs_3333, &
                                       temp_3333
  real(pReal), dimension(9,9)::        temp_99
  logical :: error

  !$OMP PARALLEL DO PRIVATE(dSdF,dSdFe,dSdFi,dLpdS,dLpdFi,dFpinvdF,dLidS,dLidFi,dFidS,o,p, &
  !$OMP                     invSubFp0,invSubFi0,invFp,invFi, &
  !$OMP                     rhs_3333,lhs_3333,temp_99,temp_33_1,temp_33_2,temp_33_3,temp_33_4,temp_3333,error)
  elementLooping: do e = FEsolving_execElem(1),FEsolving_execElem(2)
    do i = FEsolving_execIP(1),FEsolving_execIP(2)
      do c = 1,homogenization_Ngrains(material_homogenizationAt(e))

        call constitutive_SandItsTangents(devNull,dSdFe,dSdFi, &
                                         crystallite_Fe(1:3,1:3,c,i,e), &
                                         crystallite_Fi(1:3,1:3,c,i,e),c,i,e)
        call constitutive_LiAndItsTangents(devNull,dLidS,dLidFi, &
                                           crystallite_S (1:3,1:3,c,i,e), &
                                           crystallite_Fi(1:3,1:3,c,i,e), &
                                           c,i,e)

        invFp = math_inv33(crystallite_Fp(1:3,1:3,c,i,e))
        invFi = math_inv33(crystallite_Fi(1:3,1:3,c,i,e))
        invSubFp0 = math_inv33(crystallite_subFp0(1:3,1:3,c,i,e))
        invSubFi0 = math_inv33(crystallite_subFi0(1:3,1:3,c,i,e))

        if (sum(abs(dLidS)) < tol_math_check) then
          dFidS = 0.0_pReal
        else
          lhs_3333 = 0.0_pReal; rhs_3333 = 0.0_pReal
          do o=1,3; do p=1,3
            lhs_3333(1:3,1:3,o,p) = lhs_3333(1:3,1:3,o,p) &
                                  + crystallite_subdt(c,i,e)*matmul(invSubFi0,dLidFi(1:3,1:3,o,p))
            lhs_3333(1:3,o,1:3,p) = lhs_3333(1:3,o,1:3,p) &
                                  + invFi*invFi(p,o)
            rhs_3333(1:3,1:3,o,p) = rhs_3333(1:3,1:3,o,p) &
                                  - crystallite_subdt(c,i,e)*matmul(invSubFi0,dLidS(1:3,1:3,o,p))
          enddo; enddo
          call math_invert(temp_99,error,math_3333to99(lhs_3333))
          if (error) then
            call IO_warning(warning_ID=600,el=e,ip=i,g=c, &
                            ext_msg='inversion error in analytic tangent calculation')
            dFidS = 0.0_pReal
          else
            dFidS = math_mul3333xx3333(math_99to3333(temp_99),rhs_3333)
          endif
          dLidS = math_mul3333xx3333(dLidFi,dFidS) + dLidS
        endif

        call constitutive_LpAndItsTangents(devNull,dLpdS,dLpdFi, &
                                           crystallite_S (1:3,1:3,c,i,e), &
                                           crystallite_Fi(1:3,1:3,c,i,e),c,i,e)                     ! call constitutive law to calculate Lp tangent in lattice configuration
        dLpdS = math_mul3333xx3333(dLpdFi,dFidS) + dLpdS

!--------------------------------------------------------------------------------------------------
! calculate dSdF
        temp_33_1 = transpose(matmul(invFp,invFi))
        temp_33_2 = matmul(crystallite_subF(1:3,1:3,c,i,e),invSubFp0)
        temp_33_3 = matmul(matmul(crystallite_subF(1:3,1:3,c,i,e),invFp), invSubFi0)

        do o=1,3; do p=1,3
          rhs_3333(p,o,1:3,1:3)  = matmul(dSdFe(p,o,1:3,1:3),temp_33_1)
          temp_3333(1:3,1:3,p,o) = matmul(matmul(temp_33_2,dLpdS(1:3,1:3,p,o)), invFi) &
                                 + matmul(temp_33_3,dLidS(1:3,1:3,p,o))
        enddo; enddo
        lhs_3333 = crystallite_subdt(c,i,e)*math_mul3333xx3333(dSdFe,temp_3333) &
                 + math_mul3333xx3333(dSdFi,dFidS)

        call math_invert(temp_99,error,math_identity2nd(9)+math_3333to99(lhs_3333))
        if (error) then
          call IO_warning(warning_ID=600,el=e,ip=i,g=c, &
                          ext_msg='inversion error in analytic tangent calculation')
          dSdF = rhs_3333
        else
          dSdF = math_mul3333xx3333(math_99to3333(temp_99),rhs_3333)
        endif

!--------------------------------------------------------------------------------------------------
! calculate dFpinvdF
        temp_3333 = math_mul3333xx3333(dLpdS,dSdF)
        do o=1,3; do p=1,3
          dFpinvdF(1:3,1:3,p,o) = -crystallite_subdt(c,i,e) &
                                * matmul(invSubFp0, matmul(temp_3333(1:3,1:3,p,o),invFi))
        enddo; enddo

!--------------------------------------------------------------------------------------------------
! assemble dPdF
        temp_33_1 = matmul(crystallite_S(1:3,1:3,c,i,e),transpose(invFp))
        temp_33_2 = matmul(invFp,temp_33_1)
        temp_33_3 = matmul(crystallite_subF(1:3,1:3,c,i,e),invFp)
        temp_33_4 = matmul(temp_33_3,crystallite_S(1:3,1:3,c,i,e))

        crystallite_dPdF(1:3,1:3,1:3,1:3,c,i,e) = 0.0_pReal
        do p=1,3
          crystallite_dPdF(p,1:3,p,1:3,c,i,e) = transpose(temp_33_2)
        enddo
        do o=1,3; do p=1,3
          crystallite_dPdF(1:3,1:3,p,o,c,i,e) = crystallite_dPdF(1:3,1:3,p,o,c,i,e) &
                                              + matmul(matmul(crystallite_subF(1:3,1:3,c,i,e), &
                                                       dFpinvdF(1:3,1:3,p,o)),temp_33_1) &
                                              + matmul(matmul(temp_33_3,dSdF(1:3,1:3,p,o)), &
                                                       transpose(invFp)) &
                                              + matmul(temp_33_4,transpose(dFpinvdF(1:3,1:3,p,o)))
        enddo; enddo

    enddo; enddo
  enddo elementLooping
  !$OMP END PARALLEL DO

end subroutine crystallite_stressTangent


!--------------------------------------------------------------------------------------------------
!> @brief calculates orientations
!--------------------------------------------------------------------------------------------------
subroutine crystallite_orientations

  integer &
    c, &                                                                                            !< counter in integration point component loop
    i, &                                                                                            !< counter in integration point loop
    e                                                                                               !< counter in element loop

  !$OMP PARALLEL DO
  do e = FEsolving_execElem(1),FEsolving_execElem(2)
    do i = FEsolving_execIP(1),FEsolving_execIP(2)
      do c = 1,homogenization_Ngrains(material_homogenizationAt(e))
        call crystallite_orientation(c,i,e)%fromMatrix(transpose(math_rotationalPart(crystallite_Fe(1:3,1:3,c,i,e))))
  enddo; enddo; enddo
  !$OMP END PARALLEL DO

  nonlocalPresent: if (any(plasticState%nonLocal)) then
    !$OMP PARALLEL DO
    do e = FEsolving_execElem(1),FEsolving_execElem(2)
      do i = FEsolving_execIP(1),FEsolving_execIP(2)
        if (plasticState(material_phaseAt(1,e))%nonLocal) &
          call plastic_nonlocal_updateCompatibility(crystallite_orientation, &
                                                    phase_plasticityInstance(material_phaseAt(i,e)),i,e)
    enddo; enddo
    !$OMP END PARALLEL DO
  endif nonlocalPresent

end subroutine crystallite_orientations


!--------------------------------------------------------------------------------------------------
!> @brief Map 2nd order tensor to reference config
!--------------------------------------------------------------------------------------------------
function crystallite_push33ToRef(ipc,ip,el, tensor33)

  real(pReal), dimension(3,3) :: crystallite_push33ToRef
  real(pReal), dimension(3,3), intent(in) :: tensor33
  real(pReal), dimension(3,3)             :: T
  integer, intent(in):: &
    el, &
    ip, &
    ipc

  T = matmul(material_orientation0(ipc,ip,el)%asMatrix(), &                                         ! ToDo: initial orientation correct?
             transpose(math_inv33(crystallite_subF(1:3,1:3,ipc,ip,el))))
  crystallite_push33ToRef = matmul(transpose(T),matmul(tensor33,T))

end function crystallite_push33ToRef


!--------------------------------------------------------------------------------------------------
!> @brief writes crystallite results to HDF5 output file
!--------------------------------------------------------------------------------------------------
subroutine crystallite_results

  integer :: p,o
  real(pReal),    allocatable, dimension(:,:,:) :: selected_tensors
  type(rotation), allocatable, dimension(:)     :: selected_rotations
  character(len=pStringLen)                     :: group,structureLabel

  do p=1,size(config_name_phase)
    group = trim('current/constituent')//'/'//trim(config_name_phase(p))//'/generic'

    call results_closeGroup(results_addGroup(group))

    do o = 1, size(output_constituent(p)%label)
      select case (output_constituent(p)%label(o))
        case('f')
          selected_tensors = select_tensors(crystallite_partionedF,p)
          call results_writeDataset(group,selected_tensors,'F',&
                                   'deformation gradient','1')
        case('fe')
          selected_tensors = select_tensors(crystallite_Fe,p)
          call results_writeDataset(group,selected_tensors,'Fe',&
                                   'elastic deformation gradient','1')
        case('fp')
          selected_tensors = select_tensors(crystallite_Fp,p)
          call results_writeDataset(group,selected_tensors,'Fp',&
                                   'plastic deformation gradient','1')
        case('fi')
          selected_tensors = select_tensors(crystallite_Fi,p)
          call results_writeDataset(group,selected_tensors,'Fi',&
                                   'inelastic deformation gradient','1')
        case('lp')
          selected_tensors = select_tensors(crystallite_Lp,p)
          call results_writeDataset(group,selected_tensors,'Lp',&
                                   'plastic velocity gradient','1/s')
        case('li')
          selected_tensors = select_tensors(crystallite_Li,p)
          call results_writeDataset(group,selected_tensors,'Li',&
                                   'inelastic velocity gradient','1/s')
        case('p')
          selected_tensors = select_tensors(crystallite_P,p)
          call results_writeDataset(group,selected_tensors,'P',&
                                   'First Piola-Kirchoff stress','Pa')
        case('s')
          selected_tensors = select_tensors(crystallite_S,p)
          call results_writeDataset(group,selected_tensors,'S',&
                                   'Second Piola-Kirchoff stress','Pa')
        case('orientation')
          select case(lattice_structure(p))
            case(lattice_ISO_ID)
              structureLabel = 'iso'
            case(lattice_FCC_ID)
              structureLabel = 'fcc'
            case(lattice_BCC_ID)
              structureLabel = 'bcc'
            case(lattice_BCT_ID)
              structureLabel = 'bct'
            case(lattice_HEX_ID)
              structureLabel = 'hex'
            case(lattice_ORT_ID)
              structureLabel = 'ort'
          end select
          selected_rotations = select_rotations(crystallite_orientation,p)
          call results_writeDataset(group,selected_rotations,'orientation',&
                                   'crystal orientation as quaternion',structureLabel)
      end select
    enddo
  enddo

  contains

  !------------------------------------------------------------------------------------------------
  !> @brief select tensors for output
  !------------------------------------------------------------------------------------------------
  function select_tensors(dataset,instance)

    integer, intent(in) :: instance
    real(pReal), dimension(:,:,:,:,:), intent(in) :: dataset
    real(pReal), allocatable, dimension(:,:,:) :: select_tensors
    integer :: e,i,c,j

    allocate(select_tensors(3,3,count(material_phaseAt==instance)*discretization_nIP))

    j=0
    do e = 1, size(material_phaseAt,2)
      do i = 1, discretization_nIP
        do c = 1, size(material_phaseAt,1)                                                          !ToDo: this needs to be changed for varying Ngrains
          if (material_phaseAt(c,e) == instance) then
            j = j + 1
            select_tensors(1:3,1:3,j) = dataset(1:3,1:3,c,i,e)
          endif
        enddo
      enddo
    enddo

  end function select_tensors


!--------------------------------------------------------------------------------------------------
!> @brief select rotations for output
!--------------------------------------------------------------------------------------------------
  function select_rotations(dataset,instance)

    integer, intent(in) :: instance
    type(rotation), dimension(:,:,:), intent(in) :: dataset
    type(rotation), allocatable, dimension(:) :: select_rotations
    integer :: e,i,c,j

    allocate(select_rotations(count(material_phaseAt==instance)*homogenization_maxNgrains*discretization_nIP))

    j=0
    do e = 1, size(material_phaseAt,2)
      do i = 1, discretization_nIP
        do c = 1, size(material_phaseAt,1)                                                          !ToDo: this needs to be changed for varying Ngrains
           if (material_phaseAt(c,e) == instance) then
             j = j + 1
             select_rotations(j) = dataset(c,i,e)
           endif
        enddo
      enddo
   enddo

 end function select_rotations

end subroutine crystallite_results


!--------------------------------------------------------------------------------------------------
!> @brief calculation of stress (P) with time integration based on a residuum in Lp and
!> intermediate acceleration of the Newton-Raphson correction
!--------------------------------------------------------------------------------------------------
logical function integrateStress(ipc,ip,el,timeFraction)

  integer, intent(in)::         el, &                                                               ! element index
                                      ip, &                                                         ! integration point index
                                      ipc                                                           ! grain index
  real(pReal), optional, intent(in) :: timeFraction                                                 ! fraction of timestep

  real(pReal), dimension(3,3)::       F, &                                                          ! deformation gradient at end of timestep
                                      Fp_new, &                                                     ! plastic deformation gradient at end of timestep
                                      invFp_new, &                                                  ! inverse of Fp_new
                                      invFp_current, &                                              ! inverse of Fp_current
                                      Lpguess, &                                                    ! current guess for plastic velocity gradient
                                      Lpguess_old, &                                                ! known last good guess for plastic velocity gradient
                                      Lp_constitutive, &                                            ! plastic velocity gradient resulting from constitutive law
                                      residuumLp, &                                                 ! current residuum of plastic velocity gradient
                                      residuumLp_old, &                                             ! last residuum of plastic velocity gradient
                                      deltaLp, &                                                    ! direction of next guess
                                      Fi_new, &                                                     ! gradient of intermediate deformation stages
                                      invFi_new, &
                                      invFi_current, &                                              ! inverse of Fi_current
                                      Liguess, &                                                    ! current guess for intermediate velocity gradient
                                      Liguess_old, &                                                ! known last good guess for intermediate velocity gradient
                                      Li_constitutive, &                                            ! intermediate velocity gradient resulting from constitutive law
                                      residuumLi, &                                                 ! current residuum of intermediate velocity gradient
                                      residuumLi_old, &                                             ! last residuum of intermediate velocity gradient
                                      deltaLi, &                                                    ! direction of next guess
                                      Fe, &                                                         ! elastic deformation gradient
                                      Fe_new, &
                                      S, &                                                          ! 2nd Piola-Kirchhoff Stress in plastic (lattice) configuration
                                      A, &
                                      B, &
                                      temp_33
  real(pReal), dimension(9) ::        temp_9                                                        ! needed for matrix inversion by LAPACK
  integer,     dimension(9) ::        devNull_9                                                     ! needed for matrix inversion by LAPACK
  real(pReal), dimension(9,9) ::      dRLp_dLp, &                                                   ! partial derivative of residuum (Jacobian for Newton-Raphson scheme)
                                      dRLi_dLi                                                      ! partial derivative of residuumI (Jacobian for Newton-Raphson scheme)
  real(pReal), dimension(3,3,3,3)::   dS_dFe, &                                                     ! partial derivative of 2nd Piola-Kirchhoff stress
                                      dS_dFi, &
                                      dFe_dLp, &                                                    ! partial derivative of elastic deformation gradient
                                      dFe_dLi, &
                                      dFi_dLi, &
                                      dLp_dFi, &
                                      dLi_dFi, &
                                      dLp_dS, &
                                      dLi_dS
  real(pReal)                         steplengthLp, &
                                      steplengthLi, &
                                      dt, &                                                         ! time increment
                                      atol_Lp, &
                                      atol_Li, &
                                      devNull
  integer                             NiterationStressLp, &                                         ! number of stress integrations
                                      NiterationStressLi, &                                         ! number of inner stress integrations
                                      ierr, &                                                       ! error indicator for LAPACK
                                      o, &
                                      p, &
                                      jacoCounterLp, &
                                      jacoCounterLi                                                 ! counters to check for Jacobian update
  logical :: error
  external :: &
    dgesv

  integrateStress = .false.

  if (present(timeFraction)) then
    dt = crystallite_subdt(ipc,ip,el) * timeFraction
    F  = crystallite_subF0(1:3,1:3,ipc,ip,el) &
       + (crystallite_subF(1:3,1:3,ipc,ip,el) - crystallite_subF0(1:3,1:3,ipc,ip,el)) * timeFraction
  else
    dt = crystallite_subdt(ipc,ip,el)
    F  = crystallite_subF(1:3,1:3,ipc,ip,el)
  endif

  Lpguess = crystallite_Lp(1:3,1:3,ipc,ip,el)                                                       ! take as first guess
  Liguess = crystallite_Li(1:3,1:3,ipc,ip,el)                                                       ! take as first guess

  call math_invert33(invFp_current,devNull,error,crystallite_subFp0(1:3,1:3,ipc,ip,el))
  if (error) return ! error
  call math_invert33(invFi_current,devNull,error,crystallite_subFi0(1:3,1:3,ipc,ip,el))
  if (error) return ! error

  A = matmul(F,invFp_current)                                                                       ! intermediate tensor needed later to calculate dFe_dLp

  jacoCounterLi  = 0
  steplengthLi   = 1.0_pReal
  residuumLi_old = 0.0_pReal
  Liguess_old    = Liguess

  NiterationStressLi = 0
  LiLoop: do
    NiterationStressLi = NiterationStressLi + 1
    if (NiterationStressLi>num%nStress) return ! error

    invFi_new = matmul(invFi_current,math_I3 - dt*Liguess)
    Fi_new    = math_inv33(invFi_new)

    jacoCounterLp  = 0
    steplengthLp   = 1.0_pReal
    residuumLp_old = 0.0_pReal
    Lpguess_old    = Lpguess

    NiterationStressLp = 0
    LpLoop: do
      NiterationStressLp = NiterationStressLp + 1
      if (NiterationStressLp>num%nStress) return ! error

      B  = math_I3 - dt*Lpguess
      Fe = matmul(matmul(A,B), invFi_new)
      call constitutive_SandItsTangents(S, dS_dFe, dS_dFi, &
                                        Fe, Fi_new, ipc, ip, el)

      call constitutive_LpAndItsTangents(Lp_constitutive, dLp_dS, dLp_dFi, &
                                         S, Fi_new, ipc, ip, el)

      !* update current residuum and check for convergence of loop
      atol_Lp = max(num%rtol_crystalliteStress * max(norm2(Lpguess),norm2(Lp_constitutive)), &      ! absolute tolerance from largest acceptable relative error
                    num%atol_crystalliteStress)                                                     ! minimum lower cutoff
      residuumLp = Lpguess - Lp_constitutive

      if (any(IEEE_is_NaN(residuumLp))) then
        return ! error
      elseif (norm2(residuumLp) < atol_Lp) then                                                     ! converged if below absolute tolerance
        exit LpLoop
      elseif (NiterationStressLp == 1 .or. norm2(residuumLp) < norm2(residuumLp_old)) then          ! not converged, but improved norm of residuum (always proceed in first iteration)...
        residuumLp_old = residuumLp                                                                 ! ...remember old values and...
        Lpguess_old    = Lpguess
        steplengthLp   = 1.0_pReal                                                                  ! ...proceed with normal step length (calculate new search direction)
      else                                                                                          ! not converged and residuum not improved...
        steplengthLp = num%subStepSizeLp * steplengthLp                                             ! ...try with smaller step length in same direction
        Lpguess      = Lpguess_old &
                     + deltaLp * stepLengthLp
        cycle LpLoop
      endif

     !* calculate Jacobian for correction term
      if (mod(jacoCounterLp, num%iJacoLpresiduum) == 0) then
        jacoCounterLp = jacoCounterLp + 1

        do o=1,3; do p=1,3
          dFe_dLp(o,1:3,p,1:3) = A(o,p)*transpose(invFi_new)                                        ! dFe_dLp(i,j,k,l) = -dt * A(i,k) invFi(l,j)
        enddo; enddo
        dFe_dLp  = - dt * dFe_dLp
        dRLp_dLp = math_identity2nd(9) &
                 - math_3333to99(math_mul3333xx3333(math_mul3333xx3333(dLp_dS,dS_dFe),dFe_dLp))
        temp_9 = math_33to9(residuumLp)
        call dgesv(9,1,dRLp_dLp,9,devNull_9,temp_9,9,ierr)                                          ! solve dRLp/dLp * delta Lp = -res for delta Lp
        if (ierr /= 0) return ! error
        deltaLp = - math_9to33(temp_9)
      endif

      Lpguess = Lpguess &
              + deltaLp * steplengthLp
    enddo LpLoop

    call constitutive_LiAndItsTangents(Li_constitutive, dLi_dS, dLi_dFi, &
                                       S, Fi_new, ipc, ip, el)

    !* update current residuum and check for convergence of loop
    atol_Li = max(num%rtol_crystalliteStress * max(norm2(Liguess),norm2(Li_constitutive)), &        ! absolute tolerance from largest acceptable relative error
                  num%atol_crystalliteStress)                                                       ! minimum lower cutoff
    residuumLi = Liguess - Li_constitutive
    if (any(IEEE_is_NaN(residuumLi))) then
      return ! error
    elseif (norm2(residuumLi) < atol_Li) then                                                       ! converged if below absolute tolerance
      exit LiLoop
    elseif (NiterationStressLi == 1 .or. norm2(residuumLi) < norm2(residuumLi_old)) then            ! not converged, but improved norm of residuum (always proceed in first iteration)...
      residuumLi_old = residuumLi                                                                   ! ...remember old values and...
      Liguess_old    = Liguess
      steplengthLi   = 1.0_pReal                                                                    ! ...proceed with normal step length (calculate new search direction)
    else                                                                                            ! not converged and residuum not improved...
      steplengthLi = num%subStepSizeLi �s] for each twin system
      dot_n_0_tr, &                                                                                 !< trans nucleation rate [1/m�s] for each trans system
      t_tw, &                                                                                       !< twin thickness [m] for each twin system
      CLambdaSlip, &                                                                                !< Adj. parameter for distance between 2 forest dislocations for each slip system
      t_tr, &                                                                                       !< martensite lamellar thickness [m] for each trans system and instance
      p, &                                                                                          !< p-exponent in glide velocity
      q, &                                                                                          !< q-exponent in glide velocity
      r, &                                                                                          !< r-exponent in twin nucleation rate
      s, &                                                                                          !< s-exponent in trans nucleation rate
      gamma_char, &                                                                                 !< characteristic shear for twins
      B                                                                                             !< drag coefficient
    real(pReal),               allocatable, dimension(:,:) :: &
      h_sl_sl, &                                                                                    !<
      h_sl_tw, &                                                                                    !<
      h_tw_tw, &                                                                                    !<
      h_sl_tr, &                                                                                    !<
      h_tr_tr, &                                                                                    !<
      n0_sl, &                                                                                      !< slip system normal
      forestProjection, &
      C66
    real(pReal),               allocatable, dimension(:,:,:) :: &
      P_sl, &
      P_tw, &
      P_tr, &
      C66_tw, &
      C66_tr
    integer :: &
      sum_N_sl, &                                                                                   !< total number of active slip system
      sum_N_tw, &                                                                                   !< total number of active twin system
      sum_N_tr                                                                                      !< total number of active transformation system
    integer,                   allocatable, dimension(:,:) :: &
      fcc_twinNucleationSlipPair                                                                    ! ToDo: Better name? Is also use for trans
    character(len=pStringLen), allocatable, dimension(:) :: &
      output
    logical :: &
      ExtendedDislocations, &                                                                       !< consider split into partials for climb calculation
      fccTwinTransNucleation, &                                                                     !< twinning and transformation models are for fcc
      dipoleFormation                                                                               !< flag indicating consideration of dipole formation
  end type                                                                                          !< container type for internal constitutive parameters

  type :: tDislotwinState
    real(pReal),                  dimension(:,:),   pointer :: &
      rho_mob, &
      rho_dip, &
      gamma_sl, &
      f_tw, &
      f_tr
  end type tDislotwinState

  type :: tDislotwinMicrostructure
    real(pReal),                  dimension(:,:),   allocatable :: &
      Lambda_sl, &                                                                                  !< mean free path between 2 obstacles seen by a moving dislocation
      Lambda_tw, &                                                                                  !< mean free path between 2 obstacles seen by a growing twin
      Lambda_tr, &                                                                                  !< mean free path between 2 obstacles seen by a growing martensite
      tau_pass, &
      tau_hat_tw, &
      tau_hat_tr, &
      V_tw, &                                                                                       !< volume of a new twin
      V_tr, &                                                                                       !< volume of a new martensite disc
      tau_r_tw, &                                                                                   !< stress to bring partials close together (twin)
      tau_r_tr                                                                                      !< stress to bring partials close together (trans)
  end type tDislotwinMicrostructure

!--------------------------------------------------------------------------------------------------
! containers for parameters and state
  type(tParameters),              allocatable, dimension(:) :: param
  type(tDislotwinState),          allocatable, dimension(:) :: &
    dotState, &
    state
  type(tDislotwinMicrostructure), allocatable, dimension(:) :: dependentState

contains


!--------------------------------------------------------------------------------------------------
!> @brief Perform module initialization.
!> @details reads in material parameters, allocates arrays, and does sanity checks
!--------------------------------------------------------------------------------------------------
module subroutine plastic_dislotwin_init

  integer :: &
    Ninstance, &
    p, i, &
    NipcMyPhase, &
    sizeState, sizeDotState, &
    startIndex, endIndex
  integer,     dimension(:), allocatable :: &
    N_sl, N_tw, N_tr
  real(pReal), allocatable, dimension(:) :: &
    rho_mob_0, &                                                                                    !< initial unipolar dislocation density per slip system
    rho_dip_0                                                                                       !< initial dipole dislocation density per slip system
  character(len=pStringLen) :: &
    extmsg = ''

  write(6,'(/,a)') ' <<<+-  constitutive_'//PLASTICITY_DISLOTWIN_LABEL//' init  -+>>>'; flush(6)

  write(6,'(/,a)') ' Ma and Roters, Acta Materialia 52(12):3603–3612, 2004'
  write(6,'(a)')   ' https://doi.org/10.1016/j.actamat.2004.04.012'

  write(6,'(/,a)') ' Roters et al., Computational Materials Science 39:91–95, 2007'
  write(6,'(a)')   ' https://doi.org/10.1016/j.commatsci.2006.04.014'

  write(6,'(/,a)') ' Wong et al., Acta Materialia 118:140–151, 2016'
  write(6,'(a,/)') ' https://doi.org/10.1016/j.actamat.2016.07.032'

  Ninstance = count(phase_plasticity == PLASTICITY_DISLOTWIN_ID)

  if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0) &
    write(6,'(a16,1x,i5,/)') '# instances:',Ninstance

  allocate(param(Ninstance))
  allocate(state(Ninstance))
  allocate(dotState(Ninstance))
  allocate(dependentState(Ninstance))

  do p = 1, size(phase_plasticity)
    if (phase_plasticity(p) /= PLASTICITY_DISLOTWIN_ID) cycle
    associate(prm => param(phase_plasticityInstance(p)), &
              dot => dotState(phase_plasticityInstance(p)), &
              stt => state(phase_plasticityInstance(p)), &
              dst => dependentState(phase_plasticityInstance(p)), &
              config   => config_phase(p))

    prm%output = config%getStrings('(output)', defaultVal=emptyStringArray)

    ! This data is read in already in lattice
    prm%mu  = lattice_mu(p)
    prm%nu  = lattice_nu(p)
    prm%C66 = lattice_C66(1:6,1:6,p)

!--------------------------------------------------------------------------------------------------
! slip related parameters
    N_sl         = config%getInts('nslip',defaultVal=emptyIntArray)
    prm%sum_N_sl = sum(abs(N_sl))
    slipActive: if (prm%sum_N_sl > 0) then
      prm%P_sl    = lattice_SchmidMatrix_slip(N_sl,config%getString('lattice_structure'),&
                                              config%getFloat('c/a',defaultVal=0.0_pReal))
      prm%h_sl_sl = lattice_interaction_SlipBySlip(N_sl,config%getFloats('interaction_slipslip'), &
                                                   config%getString('lattice_structure'))
      prm%forestProjection = lattice_forestProjection_edge(N_sl,config%getString('lattice_structure'),&
                                                           config%getFloat('c/a',defaultVal=0.0_pReal))
      prm%forestProjection = transpose(prm%forestProjection)

      prm%n0_sl            = lattice_slip_normal(N_sl,config%getString('lattice_structure'),&
                                                 config%getFloat('c/a',defaultVal=0.0_pReal))
      prm%fccTwinTransNucleation = merge(.true., .false., lattice_structure(p) == lattice_FCC_ID) &
                                 .and. (N_sl(1) == 12)
      if(prm%fccTwinTransNucleation) prm%fcc_twinNucleationSlipPair = lattice_FCC_TWINNUCLEATIONSLIPPAIR

      rho_mob_0                = config%getFloats('rhoedge0',   requiredSize=size(N_sl))
      rho_dip_0                = config%getFloats('rhoedgedip0',requiredSize=size(N_sl))
      prm%v0                   = config%getFloats('v0',         requiredSize=size(N_sl))
      prm%b_sl                 = config%getFloats('slipburgers',requiredSize=size(N_sl))
      prm%Delta_F              = config%getFloats('qedge',      requiredSize=size(N_sl))
      prm%CLambdaSlip          = config%getFloats('clambdaslip',requiredSize=size(N_sl))
      prm%p                    = config%getFloats('p_slip',     requiredSize=size(N_sl))
      prm%q                    = config%getFloats('q_slip',     requiredSize=size(N_sl))
      prm%B                    = config%getFloats('b',          requiredSize=size(N_sl), &
                                                  defaultVal=[(0.0_pReal, i=1,size(N_sl))])

      prm%tau_0                = config%getFloat('solidsolutionstrength')
      prm%CEdgeDipMinDistance  = config%getFloat('cedgedipmindistance')
      prm%D0                   = config%getFloat('d0')
      prm%Qsd                  = config%getFloat('qsd')
      prm%ExtendedDislocations = config%keyExists('/extend_dislocations/')
      if (prm%ExtendedDislocations) then
        prm%SFE_0K             = config%getFloat('sfe_0k')
        prm%dSFE_dT            = config%getFloat('dsfe_dt')
      endif

      prm%dipoleformation = .not. config%keyExists('/nodipoleformation/')

      ! multiplication factor according to crystal structure (nearest neighbors bcc vs fcc/hex)
      ! details: Argon & Moffat, Acta Metallurgica, Vol. 29, pg 293 to 299, 1981
      prm%omega = config%getFloat('omega',  defaultVal = 1000.0_pReal) &
                * merge(12.0_pReal,8.0_pReal,any(lattice_structure(p) == [lattice_FCC_ID,lattice_HEX_ID]))

      ! expand: family => system
      rho_mob_0        = math_expand(rho_mob_0,       N_sl)
      rho_dip_0        = math_expand(rho_dip_0,       N_sl)
      prm%v0           = math_expand(prm%v0,          N_sl)
      prm%b_sl         = math_expand(prm%b_sl,        N_sl)
      prm%Delta_F      = math_expand(prm%Delta_F,     N_sl)
      prm%CLambdaSlip  = math_expand(prm%CLambdaSlip, N_sl)
      prm%p            = math_expand(prm%p,           N_sl)
      prm%q            = math_expand(prm%q,           N_sl)
      prm%B            = math_expand(prm%B,           N_sl)

      ! sanity checks
      if (    prm%D0           <= 0.0_pReal)          extmsg = trim(extmsg)//' D0'
      if (    prm%Qsd          <= 0.0_pReal)          extmsg = trim(extmsg)//' Qsd'
      if (any(rho_mob_0        <  0.0_pReal))         extmsg = trim(extmsg)//' rho_mob_0'
      if (any(rho_dip_0        <  0.0_pReal))         extmsg = trim(extmsg)//' rho_dip_0'
      if (any(prm%v0           <  0.0_pReal))         extmsg = trim(extmsg)//' v0'
      if (any(prm%b_sl         <= 0.0_pReal))         extmsg = trim(extmsg)//' b_sl'
      if (any(prm%Delta_F      <= 0.0_pReal))         extmsg = trim(extmsg)//' Delta_F'
      if (any(prm%CLambdaSlip  <= 0.0_pReal))         extmsg = trim(extmsg)//' CLambdaSlip'
      if (any(prm%B            <  0.0_pReal))         extmsg = trim(extmsg)//' B'
      if (any(prm%p<=0.0_pReal .or. prm%p>1.0_pReal)) extmsg = trim(extmsg)//' p'
      if (any(prm%q< 1.0_pReal .or. prm%q>2.0_pReal)) extmsg = trim(extmsg)//' q'
    else slipActive
      rho_mob_0 = emptyRealArray; rho_dip_0 = emptyRealArray
      allocate(prm%b_sl,prm%Delta_F,prm%v0,prm%CLambdaSlip,prm%p,prm%q,prm%B,source=emptyRealArray)
      allocate(prm%forestProjection(0,0),prm%h_sl_sl(0,0))
    endif slipActive

!--------------------------------------------------------------------------------------------------
! twin related parameters
    N_tw         = config%getInts('ntwin', defaultVal=emptyIntArray)
    prm%sum_N_tw = sum(abs(N_tw))
    twinActive: if (prm%sum_N_tw > 0) then
      prm%P_tw  = lattice_SchmidMatrix_twin(N_tw,config%getString('lattice_structure'),&
                                                   config%getFloat('c/a',defaultVal=0.0_pReal))
      prm%h_tw_tw   = lattice_interaction_TwinByTwin(N_tw,&
                                                     config%getFloats('interaction_twintwin'), &
                                                     config%getString('lattice_structure'))

      prm%b_tw      = config%getFloats('twinburgers',  requiredSize=size(N_tw))
      prm%t_tw      = config%getFloats('twinsize',     requiredSize=size(N_tw))
      prm%r         = config%getFloats('r_twin',       requiredSize=size(N_tw))

      prm%xc_twin   = config%getFloat('xc_twin')
      prm%L_tw      = config%getFloat('l0_twin')
      prm%i_tw      = config%getFloat('cmfptwin')

      prm%gamma_char= lattice_characteristicShear_Twin(N_tw,config%getString('lattice_structure'),&
                                                       config%getFloat('c/a',defaultVal=0.0_pReal))

      prm%C66_tw    = lattice_C66_twin(N_tw,prm%C66,config%getString('lattice_structure'),&
                                       config%getFloat('c/a',defaultVal=0.0_pReal))

      if (.not. prm%fccTwinTransNucleation) then
        prm%dot_N_0_tw = config%getFloats('ndot0_twin')
        prm%dot_N_0_tw = math_expand(prm%dot_N_0_tw,N_tw)
      endif

      ! expand: family => system
      prm%b_tw = math_expand(prm%b_tw,N_tw)
      prm%t_tw = math_expand(prm%t_tw,N_tw)
      prm%r    = math_expand(prm%r,N_tw)

      ! sanity checks
      if (    prm%xc_twin       < 0.0_pReal)  extmsg = trim(extmsg)//' xc_twin'
      if (    prm%L_tw          < 0.0_pReal)  extmsg = trim(extmsg)//' L_tw'
      if (    prm%i_tw          < 0.0_pReal)  extmsg = trim(extmsg)//' i_tw'
      if (any(prm%b_tw          < 0.0_pReal)) extmsg = trim(extmsg)//' b_tw'
      if (any(prm%t_tw          < 0.0_pReal)) extmsg = trim(extmsg)//' t_tw'
      if (any(prm%r             < 0.0_pReal)) extmsg = trim(extmsg)//' r'
      if (.not. prm%fccTwinTransNucleation) then
        if (any(prm%dot_N_0_tw  < 0.0_pReal)) extmsg = trim(extmsg)//' dot_N_0_tw'
      endif
    else twinActive
      allocate(prm%gamma_char,prm%b_tw,prm%dot_N_0_tw,prm%t_tw,prm%r,source=emptyRealArray)
      allocate(prm%h_tw_tw(0,0))
    endif twinActive

!--------------------------------------------------------------------------------------------------
! transformation related parameters
    N_tr         = config%getInts('ntrans', defaultVal=emptyIntArray)
    prm%sum_N_tr = sum(abs(N_tr))
    transActive: if (prm%sum_N_tr > 0) then
      prm%b_tr = config%getFloats('transburgers')
      prm%b_tr = math_expand(prm%b_tr,N_tr)

      prm%h             = config%getFloat('transstackheight', defaultVal=0.0_pReal) ! ToDo: How to handle that???
      prm%i_tr          = config%getFloat('cmfptrans',        defaultVal=0.0_pReal) ! ToDo: How to handle that???
      prm%gamma_fcc_hex = config%getFloat('deltag')
      prm%xc_trans      = config%getFloat('xc_trans',         defaultVal=0.0_pReal) ! ToDo: How to handle that???
      prm%L_tr          = config%getFloat('l0_trans')

      prm%h_tr_tr = lattice_interaction_TransByTrans(N_tr,config%getFloats('interaction_transtrans'), &
                                                     config%getString('lattice_structure'))

      prm%C66_tr  = lattice_C66_trans(N_tr,prm%C66,config%getString('trans_lattice_structure'), &
                                      0.0_pReal, &
                                      config%getFloat('a_bcc', defaultVal=0.0_pReal), &
                                      config%getFloat('a_fcc', defaultVal=0.0_pReal))

      prm%P_tr    = lattice_SchmidMatrix_trans(N_tr,config%getString('trans_lattice_structure'), &
                                               0.0_pReal, &
                                               config%getFloat('a_bcc', defaultVal=0.0_pReal), &
                                               config%getFloat('a_fcc', defaultVal=0.0_pReal))

      if (lattice_structure(p) /= lattice_FCC_ID) then
        prm%dot_N_0_tr = config%getFloats('ndot0_trans')
        prm%dot_N_0_tr = math_expand(prm%dot_N_0_tr,N_tr)
      endif
      prm%t_tr = config%getFloats('lamellarsize')
      prm%t_tr = math_expand(prm%t_tr,N_tr)
      prm%s    = config%getFloats('s_trans',defaultVal=[0.0_pReal])
      prm%s    = math_expand(prm%s,N_tr)

      ! sanity checks
      if (    prm%xc_trans      < 0.0_pReal)  extmsg = trim(extmsg)//' xc_trans'
      if (    prm%L_tr          < 0.0_pReal)  extmsg = trim(extmsg)//' L_tr'
      if (    prm%i_tr          < 0.0_pReal)  extmsg = trim(extmsg)//' i_tr'
      if (any(prm%t_tr          < 0.0_pReal)) extmsg = trim(extmsg)//' t_tr'
      if (any(prm%s             < 0.0_pReal)) extmsg = trim(extmsg)//' s'
      if (lattice_structure(p) /= lattice_FCC_ID) then
        if (any(prm%dot_N_0_tr  < 0.0_pReal)) extmsg = trim(extmsg)//' dot_N_0_tr'
      endif
    else transActive
      allocate(prm%s,prm%b_tr,prm%t_tr,prm%dot_N_0_tr,source=emptyRealArray)
      allocate(prm%h_tr_tr(0,0))
    endif transActive

!--------------------------------------------------------------------------------------------------
! shearband related parameters
    prm%sbVelocity = config%getFloat('shearbandvelocity',defaultVal=0.0_pReal)
    if (prm%sbVelocity > 0.0_pReal) then
      prm%sbResistance = config%getFloat('shearbandresistance')
      prm%E_sb         = config%getFloat('qedgepersbsystem')
      prm%p_sb         = config%getFloat('p_shearband')
      prm%q_sb         = config%getFloat('q_shearband')

      ! sanity checks
      if (prm%sbResistance  <  0.0_pReal) extmsg = trim(extmsg)//' shearbandresistance'
      if (prm%E_sb          <  0.0_pReal) extmsg = trim(extmsg)//' qedgepersbsystem'
      if (prm%p_sb          <= 0.0_pReal) extmsg = trim(extmsg)//' p_shearband'
      if (prm%q_sb          <= 0.0_pReal) extmsg = trim(extmsg)//' q_shearband'
    endif

!--------------------------------------------------------------------------------------------------
! parameters required for several mechanisms and their interactions
    if(prm%sum_N_sl + prm%sum_N_tw + prm%sum_N_tw > 0) &
      prm%D = config%getFloat('grainsize')

    twinOrSlipActive: if (prm%sum_N_tw + prm%sum_N_tr > 0) then
      prm%SFE_0K  = config%getFloat('sfe_0k')
      prm%dSFE_dT = config%getFloat('dsfe_dt')
      prm%V_cs    = config%getFloat('vcrossslip')
    endif twinOrSlipActive

    slipAndTwinActive: if (prm%sum_N_sl * prm%sum_N_tw > 0) then
      prm%h_sl_tw = lattice_interaction_SlipByTwin(N_sl,N_tw,&
                                                   config%getFloats('interaction_sliptwin'), &
                                                   config%getString('lattice_structure'))
      if (prm%fccTwinTransNucleation .and. size(N_tw) /= 1) extmsg = trim(extmsg)//' interaction_sliptwin'
    endif slipAndTwinActive

    slipAndTransActive: if (prm%sum_N_sl * prm%sum_N_tr > 0) then
      prm%h_sl_tr = lattice_interaction_SlipByTrans(N_sl,N_tr,&
                                                    config%getFloats('interaction_sliptrans'), &
                                            config%getString('lattice_structure'))
      if (prm%fccTwinTransNucleation .and. size(N_tr) /= 1) extmsg = trim(extmsg)//' interaction_sliptrans'
    endif slipAndTransActive

!--------------------------------------------------------------------------------------------------
! allocate state arrays
    NipcMyPhase  = count(material_phaseAt == p) * discretization_nIP
    sizeDotState = size(['rho_mob ','rho_dip ','gamma_sl']) * prm%sum_N_sl &
                 + size(['f_tw'])                           * prm%sum_N_tw &
                 + size(['f_tr'])                           * prm%sum_N_tr
    sizeState = sizeDotState

    call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,0)

!--------------------------------------------------------------------------------------------------
! locally defined state aliases and initialization of state0 and atol
    startIndex = 1
    endIndex   = prm%sum_N_sl
    stt%rho_mob=>plasticState(p)%state(startIndex:endIndex,:)
    stt%rho_mob= spread(rho_mob_0,2,NipcMyPhase)
    dot%rho_mob=>plasticState(p)%dotState(startIndex:endIndex,:)
    plasticState(p)%atol(startIndex:endIndex) = config%getFloat('atol_rho',defaultVal=1.0_pReal)
    if (any(plasticState(p)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_rho'

    startIndex = endIndex + 1
    endIndex   = endIndex + prm%sum_N_sl
    stt%rho_dip=>plasticState(p)%state(startIndex:endIndex,:)
    stt%rho_dip= spread(rho_dip_0,2,NipcMyPhase)
    dot%rho_dip=>plasticState(p)%dotState(startIndex:endIndex,:)
    plasticState(p)%atol(startIndex:endIndex) = config%getFloat('atol_rho',defaultVal=1.0_pReal)

    startIndex = endIndex + 1
    endIndex   = endIndex + prm%sum_N_sl
    stt%gamma_sl=>plasticState(p)%state(startIndex:endIndex,:)
    dot%gamma_sl=>plasticState(p)%dotState(startIndex:endIndex,:)
    plasticState(p)%atol(startIndex:endIndex) = 1.0e-2_pReal
    ! global alias
    plasticState(p)%slipRate        => plasticState(p)%dotState(startIndex:endIndex,:)

    startIndex = endIndex + 1
    endIndex   = endIndex + prm%sum_N_tw
    stt%f_tw=>plasticState(p)%state(startIndex:endIndex,:)
    dot%f_tw=>plasticState(p)%dotState(startIndex:endIndex,:)
    plasticState(p)%atol(startIndex:endIndex) = config%getFloat('f_twin',defaultVal=1.0e-7_pReal)
    if (any(plasticState(p)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' f_twin'

    startIndex = endIndex + 1
    endIndex   = endIndex + prm%sum_N_tr
    stt%f_tr=>plasticState(p)%state(startIndex:endIndex,:)
    dot%f_tr=>plasticState(p)%dotState(startIndex:endIndex,:)
    plasticState(p)%atol(startIndex:endIndex) = config%getFloat('f_trans',defaultVal=1.0e-6_pReal)
    if (any(plasticState(p)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' f_trans'

    allocate(dst%Lambda_sl             (prm%sum_N_sl,NipcMyPhase),source=0.0_pReal)
    allocate(dst%tau_pass              (prm%sum_N_sl,NipcMyPhase),source=0.0_pReal)

    allocate(dst%Lambda_tw             (prm%sum_N_tw,NipcMyPhase),source=0.0_pReal)
    allocate(dst%tau_hat_tw            (prm%sum_N_tw,NipcMyPhase),source=0.0_pReal)
    allocate(dst%tau_r_tw              (prm%sum_N_tw,NipcMyPhase),source=0.0_pReal)
    allocate(dst%V_tw                  (prm%sum_N_tw,NipcMyPhase),source=0.0_pReal)

    allocate(dst%Lambda_tr             (prm%sum_N_tr,NipcMyPhase),source=0.0_pReal)
    allocate(dst%tau_hat_tr            (prm%sum_N_tr,NipcMyPhase),source=0.0_pReal)
    allocate(dst%tau_r_tr              (prm%sum_N_tr,NipcMyPhase),source=0.0_pReal)
    allocate(dst%V_tr                  (prm%sum_N_tr,NipcMyPhase),source=0.0_pReal)

    plasticState(p)%state0 = plasticState(p)%state                                                  ! ToDo: this could be done centrally

    end associate

!--------------------------------------------------------------------------------------------------
!  exit if any parameter is out of range
    if (extmsg /= '') call IO_error(211,ext_msg=trim(extmsg)//'('//PLASTICITY_DISLOTWIN_LABEL//')')

  enddo

end subroutine plastic_dislotwin_init


!--------------------------------------------------------------------------------------------------
!> @brief Return the homogenized elasticity matrix.
!--------------------------------------------------------------------------------------------------
module function plastic_dislotwin_homogenizedC(ipc,ip,el) result(homogenizedC)

  real(pReal), dimension(6,6) :: &
    homogenizedC
  integer,     intent(in) :: &
    ipc, &                                                                                          !< component-ID of integration point
    ip, &                                                                                           !< integration point
    el                                                                                              !< element

  integer :: i, &
             of
  real(pReal) :: f_unrotated

  of = material_phasememberAt(ipc,ip,el)
  associate(prm => param(phase_plasticityInstance(material_phaseAt(ipc,el))),&
            stt => state(phase_plasticityInstance(material_phaseAT(ipc,el))))

  f_unrotated = 1.0_pReal &
              - sum(stt%f_tw(1:prm%sum_N_tw,of)) &
              - sum(stt%f_tr(1:prm%sum_N_tr,of))

  homogenizedC = f_unrotated * prm%C66
  do i=1,prm%sum_N_tw
    homogenizedC = homogenizedC &
                 + stt%f_tw(i,of)*prm%C66_tw(1:6,1:6,i)
  enddo
  do i=1,prm%sum_N_tr
    homogenizedC = homogenizedC &
                 + stt%f_tr(i,of)*prm%C66_tr(1:6,1:6,i)
  enddo

  end associate

end function plastic_dislotwin_homogenizedC


!--------------------------------------------------------------------------------------------------
!> @brief Calculate plastic velocity gradient and its tangent.
!--------------------------------------------------------------------------------------------------
module subroutine plastic_dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,T,instance,of)

  real(pReal), dimension(3,3),     intent(out) :: Lp
  real(pReal), dimension(3,3,3,3), intent(out) :: dLp_dMp
  real(pReal), dimension(3,3),     intent(in)  :: Mp
  integer,                         intent(in)  :: instance,of
  real(pReal),                     intent(in)  :: T

  integer :: i,k,l,m,n
  real(pReal) :: &
     f_unrotated,StressRatio_p,&
     BoltzmannRatio, &
     ddot_gamma_dtau, &
     tau
  real(pReal), dimension(param(instance)%sum_N_sl) :: &
    dot_gamma_sl,ddot_gamma_dtau_slip
  real(pReal), dimension(param(instance)%sum_N_tw) :: &
    dot_gamma_twin,ddot_gamma_dtau_twin
  real(pReal), dimension(param(instance)%sum_N_tr) :: &
    dot_gamma_tr,ddot_gamma_dtau_trans
  real(pReal):: dot_gamma_sb
  real(pReal), dimension(3,3) :: eigVectors, P_sb
  real(pReal), dimension(3)   :: eigValues
  real(pReal), dimension(3,6), parameter :: &
    sb_sComposition = &
      reshape(real([&
         1, 0, 1, &
         1, 0,-1, &
         1, 1, 0, &
         1,-1, 0, &
         0, 1, 1, &
         0, 1,-1  &
         ],pReal),[ 3,6]), &
    sb_mComposition = &
      reshape(real([&
         1, 0,-1, &
         1, 0,+1, &
         1,-1, 0, &
         1, 1, 0, &
         0, 1,-1, &
         0, 1, 1  &
         ],pReal),[ 3,6])

  associate(prm => param(instance), stt => state(instance))

  f_unrotated = 1.0_pReal &
              - sum(stt%f_tw(1:prm%sum_N_tw,of)) &
              - sum(stt%f_tr(1:prm%sum_N_tr,of))

  Lp = 0.0_pReal
  dLp_dMp = 0.0_pReal

  call kinetics_slip(Mp,T,instance,of,dot_gamma_sl,ddot_gamma_dtau_slip)
  slipContribution: do i = 1, prm%sum_N_sl
    Lp = Lp + dot_gamma_sl(i)*prm%P_sl(1:3,1:3,i)
    forall (k=1:3,l=1:3,m=1:3,n=1:3) &
      dLp_dMp(k,l,m,n) = dLp_dMp(k,l,m,n) &
                       + ddot_gamma_dtau_slip(i) * prm%P_sl(k,l,i) * prm%P_sl(m,n,i)
  enddo slipContribution

  !ToDo: Why do this before shear banding?
  Lp      = Lp      * f_unrotated
  dLp_dMp = dLp_dMp * f_unrotated

  shearBandingContribution: if(dNeq0(prm%sbVelocity)) then

    BoltzmannRatio = prm%E_sb/(kB*T)
    call math_eigh33(Mp,eigValues,eigVectors)                                                       ! is Mp symmetric by design?

    do i = 1,6
      P_sb = 0.5_pReal * math_outer(matmul(eigVectors,sb_sComposition(1:3,i)),&
                                    matmul(eigVectors,sb_mComposition(1:3,i)))
      tau = math_tensordot(Mp,P_sb)

      significantShearBandStress: if (abs(tau) > tol_math_check) then
        StressRatio_p = (abs(tau)/prm%sbResistance)**prm%p_sb
        dot_gamma_sb = sign(prm%sbVelocity*exp(-BoltzmannRatio*(1-StressRatio_p)**prm%q_sb), tau)
        ddot_gamma_dtau = abs(dot_gamma_sb)*BoltzmannRatio* prm%p_sb*prm%q_sb/ prm%sbResistance &
                   * (abs(tau)/prm%sbResistance)**(prm%p_sb-1.0_pReal) &
                   * (1.0_pReal-StressRatio_p)**(prm%q_sb-1.0_pReal)

        Lp = Lp + dot_gamma_sb * P_sb
        forall (k=1:3,l=1:3,m=1:3,n=1:3) &
          dLp_dMp(k,l,m,n) = dLp_dMp(k,l,m,n) &
                           + ddot_gamma_dtau * P_sb(k,l) * P_sb(m,n)
      endif significantShearBandStress
    enddo

  endif shearBandingContribution

  call kinetics_twin(Mp,T,dot_gamma_sl,instance,of,dot_gamma_twin,ddot_gamma_dtau_twin)
  twinContibution: do i = 1, prm%sum_N_tw
    Lp = Lp + dot_gamma_twin(i)*prm%P_tw(1:3,1:3,i) * f_unrotated
    forall (k=1:3,l=1:3,m=1:3,n=1:3) &
      dLp_dMp(k,l,m,n) = dLp_dMp(k,l,m,n) &
                       + ddot_gamma_dtau_twin(i)* prm%P_tw(k,l,i)*prm%P_tw(m,n,i) * f_unrotated
  enddo twinContibution

  call kinetics_trans(Mp,T,dot_gamma_sl,instance,of,dot_gamma_tr,ddot_gamma_dtau_trans)
  transContibution: do i = 1, prm%sum_N_tr
    Lp = Lp + dot_gamma_tr(i)*prm%P_tr(1:3,1:3,i) * f_unrotated
    forall (k=1:3,l=1:3,m=1:3,n=1:3) &
      dLp_dMp(k,l,m,n) = dLp_dMp(k,l,m,n) &
                       + ddot_gamma_dtau_trans(i)* prm%P_tr(k,l,i)*prm%P_tr(m,n,i) * f_unrotated
  enddo transContibution


  end associate

end subroutine plastic_dislotwin_LpAndItsTangent


!--------------------------------------------------------------------------------------------------
!> @brief Calculate the rate of change of microstructure.
!--------------------------------------------------------------------------------------------------
module subroutine plastic_dislotwin_dotState(Mp,T,instance,of)

  real(pReal), dimension(3,3),  intent(in):: &
    Mp                                                                                              !< Mandel stress
  real(pReal),                  intent(in) :: &
    T                                                                                               !< temperature at integration point
  integer,                      intent(in) :: &
    instance, &
    of

  integer :: i
  real(pReal) :: &
    f_unrotated, &
    rho_dip_distance, &
    v_cl, &                                                                                         !< climb velocity
    Gamma, &                                                                                        !< stacking fault energy
    tau, &
    sigma_cl, &                                                                                     !< climb stress
    b_d                                                                                             !< ratio of burgers vector to stacking fault width
  real(pReal), dimension(param(instance)%sum_N_sl) :: &
    dot_rho_dip_formation, &
    dot_rho_dip_climb, &
    rho_dip_distance_min, &
    dot_gamma_sl
  real(pReal), dimension(param(instance)%sum_N_tw) :: &
    dot_gamma_twin
  real(pReal), dimension(param(instance)%sum_N_tr) :: &
    dot_gamma_tr

  associate(prm => param(instance),    stt => state(instance), &
            dot => dotState(instance), dst => dependentState(instance))

  f_unrotated = 1.0_pReal &
              - sum(stt%f_tw(1:prm%sum_N_tw,of)) &
              - sum(stt%f_tr(1:prm%sum_N_tr,of))

  call kinetics_slip(Mp,T,instance,of,dot_gamma_sl)
  dot%gamma_sl(:,of) = abs(dot_gamma_sl)

  rho_dip_distance_min = prm%CEdgeDipMinDistance*prm%b_sl

  slipState: do i = 1, prm%sum_N_sl
    tau = math_tensordot(Mp,prm%P_sl(1:3,1:3,i))

    significantSlipStress: if (dEq0(tau)) then
      dot_rho_dip_formation(i) = 0.0_pReal
      dot_rho_dip_climb(i) = 0.0_pReal
    else significantSlipStress
      rho_dip_distance = 3.0_pReal*prm%mu*prm%b_sl(i)/(16.0_pReal*PI*abs(tau))
      rho_dip_distance = math_clip(rho_dip_distance, right = dst%Lambda_sl(i,of))
      rho_dip_distance = math_clip(rho_dip_distance, left  = rho_dip_distance_min(i))

      if (prm%dipoleFormation) then
        dot_rho_dip_formation(i) = 2.0_pReal*(rho_dip_distance-rho_dip_distance_min(i))/prm%b_sl(i) &
                                 * stt%rho_mob(i,of)*abs(dot_gamma_sl(i))
      else
        dot_rho_dip_formation(i) = 0.0_pReal
      endif

      if (dEq(rho_dip_distance,rho_dip_distance_min(i))) then
        dot_rho_dip_climb(i) = 0.0_pReal
      else
      !@details: Refer: Argon & Moffat, Acta Metallurgica, Vol. 29, pg 293 to 299, 1981
        sigma_cl = dot_product(prm%n0_sl(1:3,i),matmul(Mp,prm%n0_sl(1:3,i)))
        if (prm%ExtendedDislocations) then
          Gamma = prm%SFE_0K + prm%dSFE_dT * T
          b_d = 24.0_pReal*PI*(1.0_pReal - prm%nu)/(2.0_pReal + prm%nu)* Gamma/(prm%mu*prm%b_sl(i))
        else
          b_d = 1.0_pReal
        endif
        v_cl = 2.0_pReal*prm%omega*b_d**2.0_pReal*exp(-prm%Qsd/(kB*T)) &
             * (exp(abs(sigma_cl)*prm%b_sl(i)**3.0_pReal/(kB*T)) - 1.0_pReal)

        dot_rho_dip_climb(i) = 4.0_pReal*v_cl*stt%rho_dip(i,of) &
                             / (rho_dip_distance-rho_dip_distance_min(i))
      endif
    endif significantSlipStress
  enddo slipState

  dot%rho_mob(:,of) = abs(dot_gamma_sl)/(prm%b_sl*dst%Lambda_sl(:,of)) &
                    - dot_rho_dip_formation &
                    - 2.0_pReal*rho_dip_distance_min/prm%b_sl * stt%rho_mob(:,of)*abs(dot_gamma_sl)

  dot%rho_dip(:,of) = dot_rho_dip_formation &
                    - 2.0_pReal*rho_dip_distance_min/prm%b_sl * stt%rho_dip(:,of)*abs(dot_gamma_sl) &
                    - dot_rho_dip_climb

  call kinetics_twin(Mp,T,dot_gamma_sl,instance,of,dot_gamma_twin)
  dot%f_tw(:,of) = f_unrotated*dot_gamma_twin/prm%gamma_char

  call kinetics_trans(Mp,T,dot_gamma_sl,instance,of,dot_gamma_tr)
  dot%f_tr(:,of) = f_unrotated*dot_gamma_tr

  end associate

end subroutine plastic_dislotwin_dotState


!--------------------------------------------------------------------------------------------------
!> @brief Calculate derived quantities from state.
!--------------------------------------------------------------------------------------------------
module subroutine plastic_dislotwin_dependentState(T,instance,of)

  integer,       intent(in) :: &
    instance, &
    of
  real(pReal),   intent(in) :: &
    T

  real(pReal) :: &
    sumf_twin,Gamma,sumf_trans
  real(pReal), dimension(param(instance)%sum_N_sl) :: &
    inv_lambda_sl_sl, &                                                                             !< 1/mean free distance between 2 forest dislocations seen by a moving dislocation
    inv_lambda_sl_tw, &                                                                             !< 1/mean free distance between 2 twin stacks from different systems seen by a moving dislocation
    inv_lambda_sl_tr                                                                                !< 1/mean free distance between 2 martensite lamellar from different systems seen by a moving dislocation
  real(pReal), dimension(param(instance)%sum_N_tw) :: &
    inv_lambda_tw_tw, &                                                                             !< 1/mean free distance between 2 twin stacks from different systems seen by a growing twin
    f_over_t_tw
   real(pReal), dimension(param(instance)%sum_N_tr) :: &
    inv_lambda_tr_tr, &                                                                             !< 1/mean free distance between 2 martensite stacks from different systems seen by a growing martensite
    f_over_t_tr
  real(pReal), dimension(:), allocatable :: &
    x0


  associate(prm => param(instance),&
            stt => state(instance),&
            dst => dependentState(instance))

  sumf_twin  = sum(stt%f_tw(1:prm%sum_N_tw,of))
  sumf_trans = sum(stt%f_tr(1:prm%sum_N_tr,of))

  Gamma = prm%SFE_0K + prm%dSFE_dT * T

  !* rescaled volume fraction for topology
  f_over_t_tw = stt%f_tw(1:prm%sum_N_tw,of)/prm%t_tw                                                ! this is per system ...
  f_over_t_tr = sumf_trans/prm%t_tr                                                                 ! but this not
                                                                                                    ! ToDo ...Physically correct, but naming could be adjusted

  inv_lambda_sl_sl = sqrt(matmul(prm%forestProjection, &
                                 stt%rho_mob(:,of)+stt%rho_dip(:,of)))/prm%CLambdaSlip

  if (prm%sum_N_tw > 0 .and. prm%sum_N_sl > 0) &
    inv_lambda_sl_tw = matmul(prm%h_sl_tw,f_over_t_tw)/(1.0_pReal-sumf_twin)

  inv_lambda_tw_tw = matmul(prm%h_tw_tw,f_over_t_tw)/(1.0_pReal-sumf_twin)

  if (prm%sum_N_tr > 0 .and. prm%sum_N_sl > 0) &
    inv_lambda_sl_tr = matmul(prm%h_sl_tr,f_over_t_tr)/(1.0_pReal-sumf_trans)

  inv_lambda_tr_tr = matmul(prm%h_tr_tr,f_over_t_tr)/(1.0_pReal-sumf_trans)

  if ((prm%sum_N_tw > 0) .or. (prm%sum_N_tr > 0)) then                                              ! ToDo: better logic needed here
    dst%Lambda_sl(:,of) = prm%D &
                        / (1.0_pReal+prm%D*(inv_lambda_sl_sl + inv_lambda_sl_tw + inv_lambda_sl_tr))
  else
    dst%Lambda_sl(:,of) = prm%D &
                        / (1.0_pReal+prm%D*inv_lambda_sl_sl) !!!!!! correct?
  endif

  dst%Lambda_tw(:,of) = prm%i_tw*prm%D/(1.0_pReal+prm%D*inv_lambda_tw_tw)
  dst%Lambda_tr(:,of) = prm%i_tr*prm%D/(1.0_pReal+prm%D*inv_lambda_tr_tr)

  !* threshold stress for dislocation motion
  dst%tau_pass(:,of) = prm%mu*prm%b_sl* sqrt(matmul(prm%h_sl_sl,stt%rho_mob(:,of)+stt%rho_dip(:,of)))

  !* threshold stress for growing twin/martensite
  if(prm%sum_N_tw == prm%sum_N_sl) &
    dst%tau_hat_tw(:,of) = Gamma/(3.0_pReal*prm%b_tw) &
                         + 3.0_pReal*prm%b_tw*prm%mu/(prm%L_tw*prm%b_sl) ! slip burgers here correct?
  if(prm%sum_N_tr == prm%sum_N_sl) &
    dst%tau_hat_tr(:,of) = Gamma/(3.0_pReal*prm%b_tr) &
                         + 3.0_pReal*prm%b_tr*prm%mu/(prm%L_tr*prm%b_sl) & ! slip burgers here correct?
                         + prm%h*prm%gamma_fcc_hex/ (3.0_pReal*prm%b_tr)

  dst%V_tw(:,of) = (PI/4.0_pReal)*prm%t_tw*dst%Lambda_tw(:,of)**2.0_pReal
  dst%V_tr(:,of) = (PI/4.0_pReal)*prm%t_tr*dst%Lambda_tr(:,of)**2.0_pReal


  x0 = prm%mu*prm%b_tw**2.0_pReal/(Gamma*8.0_pReal*PI)*(2.0_pReal+prm%nu)/(1.0_pReal-prm%nu)        ! ToDo: In the paper, this is the burgers vector for slip and is the same for twin and trans
  dst%tau_r_tw(:,of) = prm%mu*prm%b_tw/(2.0_pReal*PI)*(1.0_pReal/(x0+prm%xc_twin)+cos(pi/3.0_pReal)/x0)

  x0 = prm%mu*prm%b_tr**2.0_pReal/(Gamma*8.0_pReal*PI)*(2.0_pReal+prm%nu)/(1.0_pReal-prm%nu)        ! ToDo: In the paper, this is the burgers vector for slip
  dst%tau_r_tr(:,of) = prm%mu*prm%b_tr/(2.0_pReal*PI)*(1.0_pReal/(x0+prm%xc_trans)+cos(pi/3.0_pReal)/x0)

  end associate

end subroutine plastic_dislotwin_dependentState


!--------------------------------------------------------------------------------------------------
!> @brief Write results to HDF5 output file.
!--------------------------------------------------------------------------------------------------
module subroutine plastic_dislotwin_results(instance,group)

  integer,          intent(in) :: instance
  character(len=*), intent(in) :: group

  integer :: o

 associate(prm => param(instance), stt => state(instance), dst => dependentState(instance))
  outputsLoop: do o = 1,size(prm%output)
    select case(trim(prm%output(o)))

      case('rho_mob')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_mob,'rho_mob',&
                                                     'mobile dislocation density','1/m²')
      case('rho_dip')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_dip,'rho_dip',&
                                                     'dislocation dipole density''1/m²')
      case('gamma_sl')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%gamma_sl,'gamma_sl',&
                                                     'plastic shear','1')
      case('lambda_sl')
        if(prm%sum_N_sl>0) call results_writeDataset(group,dst%Lambda_sl,'Lambda_sl',&
                                                     'mean free path for slip','m')
      case('tau_pass')
        if(prm%sum_N_sl>0) call results_writeDataset(group,dst%tau_pass,'tau_pass',&
                                                     'passing stress for slip','Pa')

      case('f_tw')
        if(prm%sum_N_tw>0) call results_writeDataset(group,stt%f_tw,'f_tw',&
                                                     'twinned volume fraction','m³/m³')
      case('lambda_tw')
        if(prm%sum_N_tw>0) call results_writeDataset(group,dst%Lambda_tw,'Lambda_tw',&
                                                     'mean free path for twinning','m')
      case('tau_hat_tw')
        if(prm%sum_N_tw>0) call results_writeDataset(group,dst%tau_hat_tw,'tau_hat_tw',&
                                                     'threshold stress for twinning','Pa')

      case('f_tr')
        if(prm%sum_N_tr>0) call results_writeDataset(group,stt%f_tr,'f_tr',&
                                                     'martensite volume fraction','m³/m³')

    end select
  enddo outputsLoop
  end associate

end subroutine plastic_dislotwin_results


!--------------------------------------------------------------------------------------------------
!> @brief Calculate shear rates on slip systems, their derivatives with respect to resolved
!         stress, and the resolved stress.
!> @details Derivatives and resolved stress are calculated only optionally.
! NOTE: Against the common convention, the result (i.e. intent(out)) variables are the last to
! have the optional arguments at the end
!--------------------------------------------------------------------------------------------------
pure subroutine kinetics_slip(Mp,T,instance,of, &
                              dot_gamma_sl,ddot_gamma_dtau_slip,tau_slip)

  real(pReal), dimension(3,3),  intent(in) :: &
    Mp                                                                                              !< Mandel stress
  real(pReal),                  intent(in) :: &
    T                                                                                               !< temperature
  integer,                      intent(in) :: &
    instance, &
    of

  real(pReal), dimension(param(instance)%sum_N_sl), intent(out) :: &
    dot_gamma_sl
  real(pReal), dimension(param(instance)%sum_N_sl), optional, intent(out) :: &
    ddot_gamma_dtau_slip, &
    tau_slip
  real(pReal), dimension(param(instance)%sum_N_sl) :: &
    ddot_gamma_dtau

  real(pReal), dimension(param(instance)%sum_N_sl) :: &
    tau, &
    stressRatio, &
    StressRatio_p, &
    BoltzmannRatio, &
    v_wait_inverse, &                                                                               !< inverse of the effective velocity of a dislocation waiting at obstacles (unsigned)
    v_run_inverse, &                                                                                !< inverse of the velocity of a free moving dislocation (unsigned)
    dV_wait_inverse_dTau, &
    dV_run_inverse_dTau, &
    dV_dTau, &
    tau_eff                                                                                         !< effective resolved stress
  integer :: i

  associate(prm => param(instance), stt => state(instance), dst => dependentState(instance))

  do i = 1, prm%sum_N_sl
    tau(i) = math_tensordot(Mp,prm%P_sl(1:3,1:3,i))
  enddo

  tau_eff = abs(tau)-dst%tau_pass(:,of)

  significantStress: where(tau_eff > tol_math_check)
    stressRatio    = tau_eff/prm%tau_0
    StressRatio_p  = stressRatio** prm%p
    BoltzmannRatio = prm%Delta_F/(kB*T)
    v_wait_inverse = prm%v0**(-1.0_pReal) * exp(BoltzmannRatio*(1.0_pReal-StressRatio_p)** prm%q)
    v_run_inverse  = prm%B/(tau_eff*prm%b_sl)

    dot_gamma_sl = sign(stt%rho_mob(:,of)*prm%b_sl/(v_wait_inverse+v_run_inverse),tau)

    dV_wait_inverse_dTau = -1.0_pReal * v_wait_inverse * prm%p * prm%q * BoltzmannRatio &
                         * (stressRatio**(prm%p-1.0_pReal)) &
                         * (1.0_pReal-StressRatio_p)**(prm%q-1.0_pReal) &
                         / prm%tau_0
    dV_run_inverse_dTau  = -1.0_pReal * v_run_inverse/tau_eff
    dV_dTau              = -1.0_pReal * (dV_wait_inverse_dTau+dV_run_inverse_dTau) &
                         / (v_wait_inverse+v_run_inverse)**2.0_pReal
    ddot_gamma_dtau = dV_dTau*stt%rho_mob(:,of)*prm%b_sl
  else where significantStress
    dot_gamma_sl    = 0.0_pReal
    ddot_gamma_dtau = 0.0_pReal
  end where significantStress

  end associate

  if(present(ddot_gamma_dtau_slip)) ddot_gamma_dtau_slip = ddot_gamma_dtau
  if(present(tau_slip))             tau_slip             = tau

end subroutine kinetics_slip


!--------------------------------------------------------------------------------------------------
!> @brief Calculate shear rates on twin systems and their derivatives with respect to resolved
!         stress.
!> @details Derivatives are calculated only optionally.
! NOTE: Against the common convention, the result (i.e. intent(out)) variables are the last to
! have the optional arguments at the end.
!--------------------------------------------------------------------------------------------------
pure subroutine kinetics_twin(Mp,T,dot_gamma_sl,instance,of,&
                              dot_gamma_twin,ddot_gamma_dtau_twin)

  real(pReal), dimension(3,3),  intent(in) :: &
    Mp                                                                                              !< Mandel stress
  real(pReal),                  intent(in) :: &
    T                                                                                               !< temperature
  integer,                      intent(in) :: &
    instance, &
    of
  real(pReal), dimension(param(instance)%sum_N_sl), intent(in) :: &
    dot_gamma_sl

  real(pReal), dimension(param(instance)%sum_N_tw), intent(out) :: &
    dot_gamma_twin
  real(pReal), dimension(param(instance)%sum_N_tw), optional, intent(out) :: &
    ddot_gamma_dtau_twin

  real, dimension(param(instance)%sum_N_tw) :: &
    tau, &
    Ndot0, &
    stressRatio_r, &
    ddot_gamma_dtau

  integer :: i,s1,s2

  associate(prm => param(instance), stt => state(instance), dst => dependentState(instance))

  do i = 1, prm%sum_N_tw
    tau(i) = math_tensordot(Mp,prm%P_tw(1:3,1:3,i))
    isFCC: if (prm%fccTwinTransNucleation) then
      s1=prm%fcc_twinNucleationSlipPair(1,i)
      s2=prm%fcc_twinNucleationSlipPair(2,i)
      if (tau(i) < dst%tau_r_tw(i,of)) then                                                         ! ToDo: correct?
        Ndot0=(abs(dot_gamma_sl(s1))*(stt%rho_mob(s2,of)+stt%rho_dip(s2,of))+&
               abs(dot_gamma_sl(s2))*(stt%rho_mob(s1,of)+stt%rho_dip(s1,of)))/&                     ! ToDo: MD: it would be more consistent to use shearrates from state
                (prm%L_tw*prm%b_sl(i))*&
                (1.0_pReal-exp(-prm%V_cs/(kB*T)*(dst%tau_r_tw(i,of)-tau(i))))                       ! P_ncs
      else
        Ndot0=0.0_pReal
      end if
    else isFCC
      Ndot0=prm%dot_N_0_tw(i)
    endif isFCC
  enddo

  significantStress: where(tau > tol_math_check)
    StressRatio_r   = (dst%tau_hat_tw(:,of)/tau)**prm%r
    dot_gamma_twin  = prm%gamma_char * dst%V_tw(:,of) * Ndot0*exp(-StressRatio_r)
    ddot_gamma_dtau = (dot_gamma_twin*prm%r/tau)*StressRatio_r
  else where significantStress
    dot_gamma_twin  = 0.0_pReal
    ddot_gamma_dtau = 0.0_pReal
  end where significantStress

  end associate

  if(present(ddot_gamma_dtau_twin)) ddot_gamma_dtau_twin = ddot_gamma_dtau

end subroutine kinetics_twin


!--------------------------------------------------------------------------------------------------
!> @brief Calculate shear rates on transformation systems and their derivatives with respect to
!         resolved stress.
!> @details Derivatives are calculated only optionally.
! NOTE: Against the common convention, the result (i.e. intent(out)) variables are the last to
! have the optional arguments at the end.
!--------------------------------------------------------------------------------------------------
pure subroutine kinetics_trans(Mp,T,dot_gamma_sl,instance,of,&
                              dot_gamma_tr,ddot_gamma_dtau_trans)

  real(pReal), dimension(3,3),  intent(in) :: &
    Mp                                                                                              !< Mandel stress
  real(pReal),                  intent(in) :: &
    T                                                                                               !< temperature
  integer,                      intent(in) :: &
    instance, &
    of
  real(pReal), dimension(param(instance)%sum_N_sl), intent(in) :: &
    dot_gamma_sl

  real(pReal), dimension(param(instance)%sum_N_tr), intent(out) :: &
    dot_gamma_tr
  real(pReal), dimension(param(instance)%sum_N_tr), optional, intent(out) :: &
    ddot_gamma_dtau_trans

  real, dimension(param(instance)%sum_N_tr) :: &
    tau, &
    Ndot0, &
    stressRatio_s, &
    ddot_gamma_dtau

  integer :: i,s1,s2
  associate(prm => param(instance), stt => state(instance), dst => dependentState(instance))

  do i = 1, prm%sum_N_tr
    tau(i) = math_tensordot(Mp,prm%P_tr(1:3,1:3,i))
    isFCC: if (prm%fccTwinTransNucleation) then
      s1=prm%fcc_twinNucleationSlipPair(1,i)
      s2=prm%fcc_twinNucleationSlipPair(2,i)
      if (tau(i) < dst%tau_r_tr(i,of)) then                                                         ! ToDo: correct?
        Ndot0=(abs(dot_gamma_sl(s1))*(stt%rho_mob(s2,of)+stt%rho_dip(s2,of))+&
               abs(dot_gamma_sl(s2))*(stt%rho_mob(s1,of)+stt%rho_dip(s1,of)))/&                     ! ToDo: MD: it would be more consistent to use shearrates from state
                (prm%L_tr*prm%b_sl(i))*&
                (1.0_pReal-exp(-prm%V_cs/(kB*T)*(dst%tau_r_tr(i,of)-tau(i))))                       ! P_ncs
      else
        Ndot0=0.0_pReal
      end if
    else isFCC
      Ndot0=prm%dot_N_0_tr(i)
    endif isFCC
  enddo

  significantStress: where(tau > tol_math_check)
    StressRatio_s   = (dst%tau_hat_tr(:,of)/tau)**prm%s
    dot_gamma_tr    = dst%V_tr(:,of) * Ndot0*exp(-StressRatio_s)
    ddot_gamma_dtau = (dot_gamma_tr*prm%s/tau)*StressRatio_s
  else where significantStress
    dot_gamma_tr  = 0.0_pReal
    ddot_gamma_dtau = 0.0_pReal
  end where significantStress

  end associate

  if(present(ddot_gamma_dtau_trans)) ddot_gamma_dtau_trans = ddot_gamma_dtau

end subroutine kinetics_trans

end submodule plastic_dislotwin
# 42 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2

# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_disloUCLA.f90" 1
!--------------------------------------------------------------------------------------------------
!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH
!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH
!> @author David Cereceda, Lawrence Livermore National Laboratory
!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH
!> @brief crystal plasticity model for bcc metals, especially Tungsten
!--------------------------------------------------------------------------------------------------
submodule(constitutive) plastic_disloUCLA

  real(pReal), parameter :: &
    kB = 1.38e-23_pReal                                                                             !< Boltzmann constant in J/Kelvin

  type :: tParameters
    real(pReal) :: &
      D    = 1.0_pReal, &                                                                           !< grain size
      mu   = 1.0_pReal, &                                                                           !< equivalent shear modulus
      D_0  = 1.0_pReal, &                                                                           !< prefactor for self-diffusion coefficient
      Q_cl = 1.0_pReal                                                                              !< activation energy for dislocation climb
    real(pReal),               allocatable, dimension(:) :: &
      b_sl, &                                                                                       !< magnitude of burgers vector [m]
      D_a, &
      i_sl, &                                                                                       !< Adj. parameter for distance between 2 forest dislocations
      atomicVolume, &
      tau_0, &
      !* mobility law parameters
      delta_F, &                                                                                    !< activation energy for glide [J]
      v0, &                                                                                         !< dislocation velocity prefactor [m/s]
      p, &                                                                                          !< p-exponent in glide velocity
      q, &                                                                                          !< q-exponent in glide velocity
      B, &                                                                                          !< friction coefficient
      kink_height, &                                                                                !< height of the kink pair
      w, &                                                                                          !< width of the kink pair
      omega                                                                                         !< attempt frequency for kink pair nucleation
    real(pReal),               allocatable, dimension(:,:) :: &
      h_sl_sl, &                                                                                    !< slip resistance from slip activity
      forestProjection
    real(pReal),               allocatable, dimension(:,:,:) :: &
      P_sl, &
      nonSchmid_pos, &
      nonSchmid_neg
    integer :: &
      sum_N_sl                                                                                      !< total number of active slip system
    character(len=pStringLen), allocatable, dimension(:) :: &
      output
    logical :: &
      dipoleFormation                                                                               !< flag indicating consideration of dipole formation
  end type                                                                                          !< container type for internal constitutive parameters

  type :: tDisloUCLAState
    real(pReal), dimension(:,:), pointer :: &
      rho_mob, &
      rho_dip, &
      gamma_sl
  end type tDisloUCLAState

  type :: tDisloUCLAdependentState
    real(pReal), dimension(:,:), allocatable :: &
      Lambda_sl, &
      threshold_stress
  end type tDisloUCLAdependentState

!--------------------------------------------------------------------------------------------------
! containers for parameters and state
  type(tParameters),              allocatable, dimension(:) :: param
  type(tDisloUCLAState),          allocatable, dimension(:) :: &
    dotState, &
    state
  type(tDisloUCLAdependentState), allocatable, dimension(:) :: dependentState

contains


!--------------------------------------------------------------------------------------------------
!> @brief Perform module initialization.
!> @details reads in material parameters, allocates arrays, and does sanity checks
!--------------------------------------------------------------------------------------------------
module subroutine plastic_disloUCLA_init

  integer :: &
    Ninstance, &
    p, i, &
    NipcMyPhase, &
    sizeState, sizeDotState, &
    startIndex, endIndex
  integer,    dimension(:), allocatable :: &
    N_sl
  real(pReal),dimension(:), allocatable :: &
    rho_mob_0, &                                                                                    !< initial dislocation density
    rho_dip_0, &                                                                                    !< initial dipole density
    a                                                                                               !< non-Schmid coefficients
  character(len=pStringLen) :: &
    extmsg = ''

  write(6,'(/,a)') ' <<<+-  plastic_'//PLASTICITY_DISLOUCLA_LABEL//' init  -+>>>'; flush(6)

  write(6,'(/,a)') ' Cereceda et al., International Journal of Plasticity 78:242–256, 2016'
  write(6,'(a)')   ' https://dx.doi.org/10.1016/j.ijplas.2015.09.002'

  Ninstance = count(phase_plasticity == PLASTICITY_DISLOUCLA_ID)
  if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0) &
    write(6,'(a16,1x,i5,/)') '# instances:',Ninstance

  allocate(param(Ninstance))
  allocate(state(Ninstance))
  allocate(dotState(Ninstance))
  allocate(dependentState(Ninstance))

  do p = 1, size(phase_plasticity)
    if (phase_plasticity(p) /= PLASTICITY_DISLOUCLA_ID) cycle
    associate(prm => param(phase_plasticityInstance(p)), &
              dot => dotState(phase_plasticityInstance(p)), &
              stt => state(phase_plasticityInstance(p)), &
              dst => dependentState(phase_plasticityInstance(p)), &
              config => config_phase(p))

    prm%output = config%getStrings('(output)',defaultVal=emptyStringArray)

    ! This data is read in already in lattice
    prm%mu = lattice_mu(p)

!--------------------------------------------------------------------------------------------------
! slip related parameters
    N_sl         = config%getInts('nslip',defaultVal=emptyIntArray)
    prm%sum_N_sl = sum(abs(N_sl))
    slipActive: if (prm%sum_N_sl > 0) then
      prm%P_sl = lattice_SchmidMatrix_slip(N_sl,config%getString('lattice_structure'),&
                                           config%getFloat('c/a',defaultVal=0.0_pReal))

      if(trim(config%getString('lattice_structure')) == 'bcc') then
        a = config%getFloats('nonschmid_coefficients',defaultVal = emptyRealArray)
        prm%nonSchmid_pos = lattice_nonSchmidMatrix(N_sl,a,+1)
        prm%nonSchmid_neg = lattice_nonSchmidMatrix(N_sl,a,-1)
      else
        prm%nonSchmid_pos = prm%P_sl
        prm%nonSchmid_neg = prm%P_sl
      endif

      prm%h_sl_sl = lattice_interaction_SlipBySlip(N_sl,config%getFloats('interaction_slipslip'), &
                                                   config%getString('lattice_structure'))
      prm%forestProjection = lattice_forestProjection_edge(N_sl,config%getString('lattice_structure'),&
                                                           config%getFloat('c/a',defaultVal=0.0_pReal))
      prm%forestProjection = transpose(prm%forestProjection)

      rho_mob_0       = config%getFloats('rhoedge0',       requiredSize=size(N_sl))
      rho_dip_0       = config%getFloats('rhoedgedip0',    requiredSize=size(N_sl))
      prm%v0          = config%getFloats('v0',             requiredSize=size(N_sl))
      prm%b_sl        = config%getFloats('slipburgers',    requiredSize=size(N_sl))
      prm%delta_F     = config%getFloats('qedge',          requiredSize=size(N_sl))

      prm%i_sl        = config%getFloats('clambdaslip',    requiredSize=size(N_sl))
      prm%tau_0       = config%getFloats('tau_peierls',    requiredSize=size(N_sl))
      prm%p           = config%getFloats('p_slip',         requiredSize=size(N_sl), &
                                         defaultVal=[(1.0_pReal,i=1,size(N_sl))])
      prm%q           = config%getFloats('q_slip',         requiredSize=size(N_sl), &
                                         defaultVal=[(1.0_pReal,i=1,size(N_sl))])
      prm%kink_height = config%getFloats('kink_height',    requiredSize=size(N_sl))
      prm%w           = config%getFloats('kink_width',     requiredSize=size(N_sl))
      prm%omega       = config%getFloats('omega',          requiredSize=size(N_sl))
      prm%B           = config%getFloats('friction_coeff', requiredSize=size(N_sl))

      prm%D               = config%getFloat('grainsize')
      prm%D_0             = config%getFloat('d0')
      prm%Q_cl            = config%getFloat('qsd')
      prm%atomicVolume    = config%getFloat('catomicvolume')       * prm%b_sl**3.0_pReal
      prm%D_a             = config%getFloat('cedgedipmindistance') * prm%b_sl
      prm%dipoleformation = config%getFloat('dipoleformationfactor') > 0.0_pReal                    !should be on by default, ToDo: change to /key/-type key

      ! expand: family => system
      rho_mob_0          = math_expand(rho_mob_0,          N_sl)
      rho_dip_0          = math_expand(rho_dip_0,          N_sl)
      prm%q              = math_expand(prm%q,              N_sl)
      prm%p              = math_expand(prm%p,              N_sl)
      prm%delta_F        = math_expand(prm%delta_F,        N_sl)
      prm%b_sl           = math_expand(prm%b_sl,           N_sl)
      prm%kink_height    = math_expand(prm%kink_height,    N_sl)
      prm%w              = math_expand(prm%w,              N_sl)
      prm%omega          = math_expand(prm%omega,          N_sl)
      prm%tau_0          = math_expand(prm%tau_0,          N_sl)
      prm%v0             = math_expand(prm%v0,             N_sl)
      prm%B              = math_expand(prm%B,              N_sl)
      prm%i_sl           = math_expand(prm%i_sl,           N_sl)
      prm%atomicVolume   = math_expand(prm%atomicVolume,   N_sl)
      prm%D_a            = math_expand(prm%D_a,            N_sl)

      ! sanity checks
      if (    prm%D_0          <= 0.0_pReal)  extmsg = trim(extmsg)//' D_0'
      if (    prm%Q_cl         <= 0.0_pReal)  extmsg = trim(extmsg)//' Q_cl'
      if (any(rho_mob_0        <  0.0_pReal)) extmsg = trim(extmsg)//' rhoedge0'
      if (any(rho_dip_0        <  0.0_pReal)) extmsg = trim(extmsg)//' rhoedgedip0'
      if (any(prm%v0           <  0.0_pReal)) extmsg = trim(extmsg)//' v0'
      if (any(prm%b_sl         <= 0.0_pReal)) extmsg = trim(extmsg)//' b_sl'
      if (any(prm%delta_F      <= 0.0_pReal)) extmsg = trim(extmsg)//' qedge'
      if (any(prm%tau_0        <  0.0_pReal)) extmsg = trim(extmsg)//' tau_0'
      if (any(prm%D_a          <= 0.0_pReal)) extmsg = trim(extmsg)//' cedgedipmindistance or b_sl'
      if (any(prm%atomicVolume <= 0.0_pReal)) extmsg = trim(extmsg)//' catomicvolume or b_sl'

    else slipActive
      rho_mob_0= emptyRealArray; rho_dip_0 = emptyRealArray
      allocate(prm%b_sl,prm%D_a,prm%i_sl,prm%atomicVolume,prm%tau_0, &
               prm%delta_F,prm%v0,prm%p,prm%q,prm%B,prm%kink_height,prm%w,prm%omega, &
               source = emptyRealArray)
      allocate(prm%forestProjection(0,0))
      allocate(prm%h_sl_sl         (0,0))
    endif slipActive

!--------------------------------------------------------------------------------------------------
! allocate state arrays
    NipcMyPhase = count(material_phaseAt == p) * discretization_nIP
    sizeDotState = size(['rho_mob ','rho_dip ','gamma_sl']) * prm%sum_N_sl
    sizeState = sizeDotState

    call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,0)

!--------------------------------------------------------------------------------------------------
! state aliases and initialization
    startIndex = 1
    endIndex   = prm%sum_N_sl
    stt%rho_mob => plasticState(p)%state(startIndex:endIndex,:)
    stt%rho_mob =  spread(rho_mob_0,2,NipcMyPhase)
    dot%rho_mob => plasticState(p)%dotState(startIndex:endIndex,:)
    plasticState(p)%atol(startIndex:endIndex) = config%getFloat('atol_rho',defaultVal=1.0_pReal)
    if (any(plasticState(p)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_rho'

    startIndex = endIndex + 1
    endIndex   = endIndex + prm%sum_N_sl
    stt%rho_dip => plasticState(p)%state(startIndex:endIndex,:)
    stt%rho_dip =  spread(rho_dip_0,2,NipcMyPhase)
    dot%rho_dip => plasticState(p)%dotState(startIndex:endIndex,:)
    plasticState(p)%atol(startIndex:endIndex) = config%getFloat('atol_rho',defaultVal=1.0_pReal)

    startIndex = endIndex + 1
    endIndex   = endIndex + prm%sum_N_sl
    stt%gamma_sl => plasticState(p)%state(startIndex:endIndex,:)
    dot%gamma_sl => plasticState(p)%dotState(startIndex:endIndex,:)
    plasticState(p)%atol(startIndex:endIndex) = 1.0e-2_pReal
    ! global alias
    plasticState(p)%slipRate        => plasticState(p)%dotState(startIndex:endIndex,:)

    allocate(dst%Lambda_sl(prm%sum_N_sl,NipcMyPhase),         source=0.0_pReal)
    allocate(dst%threshold_stress(prm%sum_N_sl,NipcMyPhase),  source=0.0_pReal)

    plasticState(p)%state0 = plasticState(p)%state                                                  ! ToDo: this could be done centrally

    end associate

!--------------------------------------------------------------------------------------------------
!  exit if any parameter is out of range
    if (extmsg /= '') call IO_error(211,ext_msg=trim(extmsg)//'('//PLASTICITY_DISLOUCLA_LABEL//')')

  enddo

end subroutine plastic_disloUCLA_init


!--------------------------------------------------------------------------------------------------
!> @brief Calculate plastic velocity gradient and its tangent.
!--------------------------------------------------------------------------------------------------
pure module subroutine plastic_disloUCLA_LpAndItsTangent(Lp,dLp_dMp, &
                                                         Mp,T,instance,of)
  real(pReal), dimension(3,3),     intent(out) :: &
    Lp                                                                                              !< plastic velocity gradient
  real(pReal), dimension(3,3,3,3), intent(out) :: &
    dLp_dMp                                                                                         !< derivative of Lp with respect to the Mandel stress

  real(pReal), dimension(3,3), intent(in) :: &
    Mp                                                                                              !< Mandel stress
  real(pReal),                 intent(in) :: &
    T                                                                                               !< temperature
  integer,                     intent(in) :: &
    instance, &
    of

  integer :: &
    i,k,l,m,n
  real(pReal), dimension(param(instance)%sum_N_sl) :: &
    dot_gamma_pos,dot_gamma_neg, &
    ddot_gamma_dtau_pos,ddot_gamma_dtau_neg

  Lp = 0.0_pReal
  dLp_dMp = 0.0_pReal

  associate(prm => param(instance))

  call kinetics(Mp,T,instance,of,dot_gamma_pos,dot_gamma_neg,ddot_gamma_dtau_pos,ddot_gamma_dtau_neg)
  do i = 1, prm%sum_N_sl
    Lp = Lp + (dot_gamma_pos(i)+dot_gamma_neg(i))*prm%P_sl(1:3,1:3,i)
    forall (k=1:3,l=1:3,m=1:3,n=1:3) &
      dLp_dMp(k,l,m,n) = dLp_dMp(k,l,m,n) &
                       + ddot_gamma_dtau_pos(i) * prm%P_sl(k,l,i) * prm%nonSchmid_pos(m,n,i) &
                       + ddot_gamma_dtau_neg(i) * prm%P_sl(k,l,i) * prm%nonSchmid_neg(m,n,i)
  enddo

  end associate

end subroutine plastic_disloUCLA_LpAndItsTangent


!--------------------------------------------------------------------------------------------------
!> @brief Calculate the rate of change of microstructure.
!--------------------------------------------------------------------------------------------------
module subroutine plastic_disloUCLA_dotState(Mp,T,instance,of)

  real(pReal), dimension(3,3),  intent(in) :: &
    Mp                                                                                              !< Mandel stress
  real(pReal),                  intent(in) :: &
    T                                                                                               !< temperature
  integer,                      intent(in) :: &
    instance, &
    of

  real(pReal) :: &
    VacancyDiffusion
  real(pReal), dimension(param(instance)%sum_N_sl) :: &
    gdot_pos, gdot_neg,&
    tau_pos,&
    tau_neg, &
    v_cl, &
    dot_rho_dip_formation, &
    dot_rho_dip_climb, &
    dip_distance

  associate(prm => param(instance), stt => state(instance),dot => dotState(instance), dst => dependentState(instance))

  call kinetics(Mp,T,instance,of,&
                gdot_pos,gdot_neg, &
                tau_pos_out = tau_pos,tau_neg_out = tau_neg)

  dot%gamma_sl(:,of) = (gdot_pos+gdot_neg)                                                          ! ToDo: needs to be abs
  VacancyDiffusion = prm%D_0*exp(-prm%Q_cl/(kB*T))

  where(dEq0(tau_pos))                                                                              ! ToDo: use avg of pos and neg
    dot_rho_dip_formation = 0.0_pReal
    dot_rho_dip_climb     = 0.0_pReal
  else where
    dip_distance = math_clip(3.0_pReal*prm%mu*prm%b_sl/(16.0_pReal*PI*abs(tau_pos)), &
                             prm%D_a, &                                                             ! lower limit
                             dst%Lambda_sl(:,of))                                                   ! upper limit
    dot_rho_dip_formation = merge(2.0_pReal*dip_distance* stt%rho_mob(:,of)*abs(dot%gamma_sl(:,of))/prm%b_sl, & ! ToDo: ignore region of spontaneous annihilation
                                  0.0_pReal, &
                                  prm%dipoleformation)
    v_cl = (3.0_pReal*prm%mu*VacancyDiffusion*prm%atomicVolume/(2.0_pReal*pi*kB*T)) &
                  * (1.0_pReal/(dip_distance+prm%D_a))
    dot_rho_dip_climb = (4.0_pReal*v_cl*stt%rho_dip(:,of))/(dip_distance-prm%D_a)                   ! ToDo: Discuss with Franz: Stress dependency?
  end where

  dot%rho_mob(:,of) = abs(dot%gamma_sl(:,of))/(prm%b_sl*dst%Lambda_sl(:,of)) &                      ! multiplication
                    - dot_rho_dip_formation &
                    - (2.0_pReal*prm%D_a)/prm%b_sl*stt%rho_mob(:,of)*abs(dot%gamma_sl(:,of))        ! Spontaneous annihilation of 2 single edge dislocations
  dot%rho_dip(:,of) = dot_rho_dip_formation &
                    - (2.0_pReal*prm%D_a)/prm%b_sl*stt%rho_dip(:,of)*abs(dot%gamma_sl(:,of)) &      ! Spontaneous annihilation of a single edge dislocation with a dipole constituent
                    - dot_rho_dip_climb

  end associate

end subroutine plastic_disloUCLA_dotState


!--------------------------------------------------------------------------------------------------
!> @brief Calculate derived quantities from state.
!--------------------------------------------------------------------------------------------------
module subroutine plastic_disloUCLA_dependentState(instance,of)

  integer,      intent(in) :: &
    instance, &
    of

  real(pReal), dimension(param(instance)%sum_N_sl) :: &
    dislocationSpacing

  associate(prm => param(instance), stt => state(instance),dst => dependentState(instance))

  dislocationSpacing = sqrt(matmul(prm%forestProjection,stt%rho_mob(:,of)+stt%rho_dip(:,of)))
  dst%threshold_stress(:,of) = prm%mu*prm%b_sl &
                             * sqrt(matmul(prm%h_sl_sl,stt%rho_mob(:,of)+stt%rho_dip(:,of)))

  dst%Lambda_sl(:,of) = prm%D/(1.0_pReal+prm%D*dislocationSpacing/prm%i_sl)

  end associate

end subroutine plastic_disloUCLA_dependentState


!--------------------------------------------------------------------------------------------------
!> @brief Write results to HDF5 output file.
!--------------------------------------------------------------------------------------------------
module subroutine plastic_disloUCLA_results(instance,group)

  integer,          intent(in) :: instance
  character(len=*), intent(in) :: group

  integer :: o

  associate(prm => param(instance), stt => state(instance), dst => dependentState(instance))
  outputsLoop: do o = 1,size(prm%output)
    select case(trim(prm%output(o)))
      case('edge_density')                                                                          ! ToDo: should be rho_mob
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_mob,'rho_mob',&
                                                     'mobile dislocation density','1/m²')
      case('dipole_density')                                                                        ! ToDo: should be rho_dip
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_dip,'rho_dip',&
                                                     'dislocation dipole density''1/m²')
      case('shear_rate_slip')                                                                       ! should be gamma
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%gamma_sl,'dot_gamma_sl',&            ! this is not dot!!
                                                     'plastic shear','1')
      case('mfp_slip')                                                                              !ToDo: should be Lambda
        if(prm%sum_N_sl>0) call results_writeDataset(group,dst%Lambda_sl,'Lambda_sl',&
                                                     'mean free path for slip','m')
      case('threshold_stress_slip')                                                                 !ToDo: should be tau_pass
        if(prm%sum_N_sl>0) call results_writeDataset(group,dst%threshold_stress,'tau_pass',&
                                                     'threshold stress for slip','Pa')
    end select
  enddo outputsLoop
  end associate

end subroutine plastic_disloUCLA_results


!--------------------------------------------------------------------------------------------------
!> @brief Calculate shear rates on slip systems, their derivatives with respect to resolved
!         stress, and the resolved stress.
!> @details Derivatives and resolved stress are calculated only optionally.
! NOTE: Against the common convention, the result (i.e. intent(out)) variables are the last to
! have the optional arguments at the end
!--------------------------------------------------------------------------------------------------
pure subroutine kinetics(Mp,T,instance,of, &
                 dot_gamma_pos,dot_gamma_neg,ddot_gamma_dtau_pos,ddot_gamma_dtau_neg,tau_pos_out,tau_neg_out)

  real(pReal), dimension(3,3),  intent(in) :: &
    Mp                                                                                              !< Mandel stress
  real(pReal),                  intent(in) :: &
    T                                                                                               !< temperature
  integer,                      intent(in) :: &
    instance, &
    of

  real(pReal),                  intent(out), dimension(param(instance)%sum_N_sl) :: &
    dot_gamma_pos, &
    dot_gamma_neg
  real(pReal),                  intent(out), optional, dimension(param(instance)%sum_N_sl) :: &
    ddot_gamma_dtau_pos, &
    ddot_gamma_dtau_neg, &
    tau_pos_out, &
    tau_neg_out
  real(pReal), dimension(param(instance)%sum_N_sl) :: &
    StressRatio, &
    StressRatio_p,StressRatio_pminus1, &
    dvel, vel, &
    tau_pos,tau_neg, &
    t_n, t_k, dtk,dtn, &
    needsGoodName                                                                                   ! ToDo: @Karo: any idea?
  integer :: j

  associate(prm => param(instance), stt => state(instance), dst => dependentState(instance))

  do j = 1, prm%sum_N_sl
    tau_pos(j) = math_tensordot(Mp,prm%nonSchmid_pos(1:3,1:3,j))
    tau_neg(j) = math_tensordot(Mp,prm%nonSchmid_neg(1:3,1:3,j))
  enddo


  if (present(tau_pos_out)) tau_pos_out = tau_pos
  if (present(tau_neg_out)) tau_neg_out = tau_neg

  associate(BoltzmannRatio  => prm%delta_F/(kB*T), &
            dot_gamma_0     => stt%rho_mob(:,of)*prm%b_sl*prm%v0, &
            effectiveLength => dst%Lambda_sl(:,of) - prm%w)

  significantPositiveTau: where(abs(tau_pos)-dst%threshold_stress(:,of) > tol_math_check)
    StressRatio = (abs(tau_pos)-dst%threshold_stress(:,of))/prm%tau_0
    StressRatio_p       = StressRatio** prm%p
    StressRatio_pminus1 = StressRatio**(prm%p-1.0_pReal)
    needsGoodName       = exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q)

    t_n = prm%b_sl/(needsGoodName*prm%omega*effectiveLength)
    t_k = effectiveLength * prm%B /(2.0_pReal*prm%b_sl*tau_pos)

    vel = prm%kink_height/(t_n + t_k)

    dot_gamma_pos = dot_gamma_0 * sign(vel,tau_pos) * 0.5_pReal
  else where significantPositiveTau
    dot_gamma_pos = 0.0_pReal
  end where significantPositiveTau

  if (present(ddot_gamma_dtau_pos)) then
    significantPositiveTau2: where(abs(tau_pos)-dst%threshold_stress(:,of) > tol_math_check)
      dtn = -1.0_pReal * t_n * BoltzmannRatio * prm%p * prm%q * (1.0_pReal-StressRatio_p)**(prm%q - 1.0_pReal) &
          * (StressRatio)**(prm%p - 1.0_pReal) / prm%tau_0
      dtk = -1.0_pReal * t_k / tau_pos

      dvel = -1.0_pReal * prm%kink_height * (dtk + dtn) / (t_n + t_k)**2.0_pReal

      ddot_gamma_dtau_pos = dot_gamma_0 * dvel* 0.5_pReal
    else where significantPositiveTau2
      ddot_gamma_dtau_pos = 0.0_pReal
    end where significantPositiveTau2
  endif

  significantNegativeTau: where(abs(tau_neg)-dst%threshold_stress(:,of) > tol_math_check)
    StressRatio = (abs(tau_neg)-dst%threshold_stress(:,of))/prm%tau_0
    StressRatio_p       = StressRatio** prm%p
    StressRatio_pminus1 = StressRatio**(prm%p-1.0_pReal)
    needsGoodName       = exp(-BoltzmannRatio*(1-StressRatio_p) ** prm%q)

    t_n = prm%b_sl/(needsGoodName*prm%omega*effectiveLength)
    t_k = effectiveLength * prm%B /(2.0_pReal*prm%b_sl*tau_pos)

    vel = prm%kink_height/(t_n + t_k)

    dot_gamma_neg = dot_gamma_0 * sign(vel,tau_neg) * 0.5_pReal
  else where significantNegativeTau
    dot_gamma_neg = 0.0_pReal
  end where significantNegativeTau

  if (present(ddot_gamma_dtau_neg)) then
    significantNegativeTau2: where(abs(tau_neg)-dst%threshold_stress(:,of) > tol_math_check)
      dtn = -1.0_pReal * t_n * BoltzmannRatio * prm%p * prm%q * (1.0_pReal-StressRatio_p)**(prm%q - 1.0_pReal) &
          * (StressRatio)**(prm%p - 1.0_pReal) / prm%tau_0
      dtk = -1.0_pReal * t_k / tau_neg

      dvel = -1.0_pReal * prm%kink_height * (dtk + dtn) / (t_n + t_k)**2.0_pReal

      ddot_gamma_dtau_neg = dot_gamma_0 * dvel * 0.5_pReal
    else where significantNegativeTau2
      ddot_gamma_dtau_neg = 0.0_pReal
    end where significantNegativeTau2
  end if

  end associate
  end associate

end subroutine kinetics

end submodule plastic_disloUCLA
# 43 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2

# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_nonlocal.f90" 1
!--------------------------------------------------------------------------------------------------
!> @author Christoph Kords, Max-Planck-Institut für Eisenforschung GmbH
!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH
!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH
!> @brief material subroutine for plasticity including dislocation flux
!--------------------------------------------------------------------------------------------------
submodule(constitutive) plastic_nonlocal
  use geometry_plastic_nonlocal, only: &
    nIPneighbors    => geometry_plastic_nonlocal_nIPneighbors, &
    IPneighborhood  => geometry_plastic_nonlocal_IPneighborhood, &
    IPvolume        => geometry_plastic_nonlocal_IPvolume0, &
    IParea          => geometry_plastic_nonlocal_IParea0, &
    IPareaNormal    => geometry_plastic_nonlocal_IPareaNormal0

  real(pReal), parameter :: &
    kB = 1.38e-23_pReal                                                                             !< Boltzmann constant in J/Kelvin

  ! storage order of dislocation types
  integer, dimension(8), parameter :: &
    sgl = [1,2,3,4,5,6,7,8]                                                                         !< signed (single)
  integer, dimension(5), parameter :: &
    edg = [1,2,5,6,9], &                                                                            !< edge
    scr = [3,4,7,8,10]                                                                              !< screw
  integer, dimension(4), parameter :: &
    mob = [1,2,3,4], &                                                                              !< mobile
    imm = [5,6,7,8]                                                                                 !< immobile (blocked)
  integer, dimension(2), parameter :: &
    dip = [9,10], &                                                                                 !< dipole
    imm_edg = imm(1:2), &                                                                           !< immobile edge
    imm_scr = imm(3:4)                                                                              !< immobile screw
  integer, parameter :: &
    mob_edg_pos = 1, &                                                                              !< mobile edge positive
    mob_edg_neg = 2, &                                                                              !< mobile edge negative
    mob_scr_pos = 3, &                                                                              !< mobile screw positive
    mob_scr_neg = 4                                                                                 !< mobile screw positive

  ! BEGIN DEPRECATED
  integer, dimension(:,:,:), allocatable :: &
    iRhoU, &                                                                                        !< state indices for unblocked density
    iV, &                                                                                           !< state indices for dislcation velocities
    iD                                                                                              !< state indices for stable dipole height
  !END DEPRECATED

  real(pReal), dimension(:,:,:,:,:,:), allocatable :: &
    compatibility                                                                                   !< slip system compatibility between me and my neighbors

  type :: tInitialParameters                                                                        !< container type for internal constitutive parameters
    real(pReal) :: &
      rhoSglScatter, &                                                                              !< standard deviation of scatter in initial dislocation density
      rhoSglRandom, &
      rhoSglRandomBinning
    real(pReal), dimension(:), allocatable :: &
      rhoSglEdgePos0, &                                                                             !< initial edge_pos dislocation density
      rhoSglEdgeNeg0, &                                                                             !< initial edge_neg dislocation density
      rhoSglScrewPos0, &                                                                            !< initial screw_pos dislocation density
      rhoSglScrewNeg0, &                                                                            !< initial screw_neg dislocation density
      rhoDipEdge0, &                                                                                !< initial edge dipole dislocation density
      rhoDipScrew0                                                                                  !< initial screw dipole dislocation density
    integer,     dimension(:) ,allocatable :: &
      N_sl
  end type tInitialParameters

  type :: tParameters                                                                               !< container type for internal constitutive parameters
    real(pReal) :: &
      atomicVolume, &                                                                               !< atomic volume
      Dsd0, &                                                                                       !< prefactor for self-diffusion coefficient
      selfDiffusionEnergy, &                                                                        !< activation enthalpy for diffusion
      atol_rho, &                                                                                   !< absolute tolerance for dislocation density in state integration
      significantRho, &                                                                             !< density considered significant
      significantN, &                                                                               !< number of dislocations considered significant
      doublekinkwidth, &                                                                            !< width of a doubkle kink in multiples of the burgers vector length b
      solidSolutionEnergy, &                                                                        !< activation energy for solid solution in J
      solidSolutionSize, &                                                                          !< solid solution obstacle size in multiples of the burgers vector length
      solidSolutionConcentration, &                                                                 !< concentration of solid solution in atomic parts
      p, &                                                                                          !< parameter for kinetic law (Kocks,Argon,Ashby)
      q, &                                                                                          !< parameter for kinetic law (Kocks,Argon,Ashby)
      viscosity, &                                                                                  !< viscosity for dislocation glide in Pa s
      fattack, &                                                                                    !< attack frequency in Hz
      surfaceTransmissivity, &                                                                      !< transmissivity at free surface
      grainboundaryTransmissivity, &                                                                !< transmissivity at grain boundary (identified by different texture)
      CFLfactor, &                                                                                  !< safety factor for CFL flux condition
      fEdgeMultiplication, &                                                                        !< factor that determines how much edge dislocations contribute to multiplication (0...1)
      linetensionEffect, &
      edgeJogFactor, &
      mu, &
      nu
    real(pReal), dimension(:),      allocatable :: &
      minDipoleHeight_edge, &                                                                       !< minimum stable edge dipole height
      minDipoleHeight_screw, &                                                                      !< minimum stable screw dipole height
      peierlsstress_edge, &
      peierlsstress_screw, &
      lambda0, &                                                                                    !< mean free path prefactor for each
      burgers                                                                                       !< absolute length of burgers vector [m]
    real(pReal), dimension(:,:),   allocatable :: &
      slip_normal, &
      slip_direction, &
      slip_transverse, &
      minDipoleHeight, &                                                                            ! edge and screw
      peierlsstress, &                                                                              ! edge and screw
      interactionSlipSlip ,&                                                                        !< coefficients for slip-slip interaction
      forestProjection_Edge, &                                                                      !< matrix of forest projections of edge dislocations
      forestProjection_Screw                                                                        !< matrix of forest projections of screw dislocations
    real(pReal), dimension(:,:,:), allocatable :: &
      Schmid, &                                                                                     !< Schmid contribution
      nonSchmid_pos, &
      nonSchmid_neg                                                                                 !< combined projection of Schmid and non-Schmid contributions to the resolved shear stress (only for screws)
    integer :: &
      sum_N_sl
    integer,     dimension(:),     allocatable :: &
      colinearSystem                                                                                !< colinear system to the active slip system (only valid for fcc!)
    character(len=pStringLen), dimension(:), allocatable :: &
      output
    logical :: &
      shortRangeStressCorrection, &                                                                 !< use of short range stress correction by excess density gradient term
      nonSchmidActive = .false.
  end type tParameters

  type :: tNonlocalMicrostructure
    real(pReal), allocatable, dimension(:,:) :: &
     tau_pass, &
     tau_Back
  end type tNonlocalMicrostructure

  type :: tNonlocalState
    real(pReal), pointer, dimension(:,:) :: &
      rho, &                                                                                        ! < all dislocations
        rhoSgl, &
          rhoSglMobile, &                       ! iRhoU
            rho_sgl_mob_edg_pos, &
            rho_sgl_mob_edg_neg, &
            rho_sgl_mob_scr_pos, &
            rho_sgl_mob_scr_neg, &
          rhoSglImmobile, &
            rho_sgl_imm_edg_pos, &
            rho_sgl_imm_edg_neg, &
            rho_sgl_imm_scr_pos, &
            rho_sgl_imm_scr_neg, &
        rhoDip, &
          rho_dip_edg, &
          rho_dip_scr, &
        rho_forest, &
      gamma, &
      v, &
          v_edg_pos, &
          v_edg_neg, &
          v_scr_pos, &
          v_scr_neg
  end type tNonlocalState

  type(tNonlocalState), allocatable, dimension(:) :: &
    deltaState, &
    dotState, &
    state, &
    state0

  type(tParameters), dimension(:), allocatable :: param                                             !< containers of constitutive parameters (len Ninstance)

  type(tNonlocalMicrostructure), dimension(:), allocatable :: microstructure

contains

!--------------------------------------------------------------------------------------------------
!> @brief module initialization
!> @details reads in material parameters, allocates arrays, and does sanity checks
!--------------------------------------------------------------------------------------------------
module subroutine plastic_nonlocal_init

  integer :: &
    Ninstance, &
    p, &
    NipcMyPhase, &
    sizeState, sizeDotState, sizeDependentState, sizeDeltaState, &
    s1, s2, &
    s, t, l
  real(pReal), dimension(:), allocatable :: &
    a
  character(len=pStringLen) :: &
    extmsg  = ''
  type(tInitialParameters) :: &
    ini

  write(6,'(/,a)') ' <<<+-  constitutive_'//PLASTICITY_NONLOCAL_LABEL//' init  -+>>>'; flush(6)

  write(6,'(/,a)') ' Reuber et al., Acta Materialia 71:333–348, 2014'
  write(6,'(a)')   ' https://doi.org/10.1016/j.actamat.2014.03.012'

  write(6,'(/,a)') ' Kords, Dissertation RWTH Aachen, 2014'
  write(6,'(a)')   ' http://publications.rwth-aachen.de/record/229993'

  Ninstance = count(phase_plasticity == PLASTICITY_NONLOCAL_ID)
  if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0) &
    write(6,'(a16,1x,i5,/)') '# instances:',Ninstance

  allocate(param(Ninstance))
  allocate(state(Ninstance))
  allocate(state0(Ninstance))
  allocate(dotState(Ninstance))
  allocate(deltaState(Ninstance))
  allocate(microstructure(Ninstance))

  do p=1, size(config_phase)
    if (phase_plasticity(p) /= PLASTICITY_NONLOCAL_ID) cycle

    associate(prm => param(phase_plasticityInstance(p)), &
              dot => dotState(phase_plasticityInstance(p)), &
              stt => state(phase_plasticityInstance(p)), &
              st0 => state0(phase_plasticityInstance(p)), &
              del => deltaState(phase_plasticityInstance(p)), &
              dst => microstructure(phase_plasticityInstance(p)), &
              config => config_phase(p))

    prm%output = config%getStrings('(output)',defaultVal=emptyStringArray)

    prm%atol_rho   = config%getFloat('atol_rho',defaultVal=1.0e4_pReal)

    ! This data is read in already in lattice
    prm%mu = lattice_mu(p)
    prm%nu = lattice_nu(p)

    ini%N_sl     = config%getInts('nslip',defaultVal=emptyIntArray)
    prm%sum_N_sl = sum(abs(ini%N_sl))
    slipActive: if (prm%sum_N_sl > 0) then
      prm%Schmid = lattice_SchmidMatrix_slip(ini%N_sl,config%getString('lattice_structure'),&
                                             config%getFloat('c/a',defaultVal=0.0_pReal))

      if(trim(config%getString('lattice_structure')) == 'bcc') then
        a = config%getFloats('nonschmid_coefficients',defaultVal = emptyRealArray)
        if(size(a) > 0) prm%nonSchmidActive = .true.
        prm%nonSchmid_pos  = lattice_nonSchmidMatrix(ini%N_sl,a,+1)
        prm%nonSchmid_neg  = lattice_nonSchmidMatrix(ini%N_sl,a,-1)
      else
        prm%nonSchmid_pos  = prm%Schmid
        prm%nonSchmid_neg  = prm%Schmid
      endif

      prm%interactionSlipSlip = lattice_interaction_SlipBySlip(ini%N_sl, &
                                                               config%getFloats('interaction_slipslip'), &
                                                               config%getString('lattice_structure'))

      prm%forestProjection_edge  = lattice_forestProjection_edge (ini%N_sl,config%getString('lattice_structure'),&
                                                                  config%getFloat('c/a',defaultVal=0.0_pReal))
      prm%forestProjection_screw = lattice_forestProjection_screw(ini%N_sl,config%getString('lattice_structure'),&
                                                                  config%getFloat('c/a',defaultVal=0.0_pReal))

      prm%slip_direction  = lattice_slip_direction (ini%N_sl,config%getString('lattice_structure'),&
                                                    config%getFloat('c/a',defaultVal=0.0_pReal))
      prm%slip_transverse = lattice_slip_transverse(ini%N_sl,config%getString('lattice_structure'),&
                                                    config%getFloat('c/a',defaultVal=0.0_pReal))
      prm%slip_normal     = lattice_slip_normal    (ini%N_sl,config%getString('lattice_structure'),&
                                                    config%getFloat('c/a',defaultVal=0.0_pReal))

      ! collinear systems (only for octahedral slip systems in fcc)
      allocate(prm%colinearSystem(prm%sum_N_sl), source = -1)
      do s1 = 1, prm%sum_N_sl
        do s2 = 1, prm%sum_N_sl
           if (all(dEq0 (math_cross(prm%slip_direction(1:3,s1),prm%slip_direction(1:3,s2)))) .and. &
               any(dNeq0(math_cross(prm%slip_normal   (1:3,s1),prm%slip_normal   (1:3,s2))))) &
             prm%colinearSystem(s1) = s2
        enddo
      enddo

      ini%rhoSglEdgePos0  = config%getFloats('rhosgledgepos0',   requiredSize=size(ini%N_sl))
      ini%rhoSglEdgeNeg0  = config%getFloats('rhosgledgeneg0',   requiredSize=size(ini%N_sl))
      ini%rhoSglScrewPos0 = config%getFloats('rhosglscrewpos0',  requiredSize=size(ini%N_sl))
      ini%rhoSglScrewNeg0 = config%getFloats('rhosglscrewneg0',  requiredSize=size(ini%N_sl))
      ini%rhoDipEdge0     = config%getFloats('rhodipedge0',      requiredSize=size(ini%N_sl))
      ini%rhoDipScrew0    = config%getFloats('rhodipscrew0',     requiredSize=size(ini%N_sl))

      prm%lambda0         = config%getFloats('lambda0',          requiredSize=size(ini%N_sl))
      prm%burgers         = config%getFloats('burgers',          requiredSize=size(ini%N_sl))

      prm%lambda0 = math_expand(prm%lambda0,ini%N_sl)
      prm%burgers = math_expand(prm%burgers,ini%N_sl)

      prm%minDipoleHeight_edge  = config%getFloats('minimumdipoleheightedge',  requiredSize=size(ini%N_sl))
      prm%minDipoleHeight_screw = config%getFloats('minimumdipoleheightscrew', requiredSize=size(ini%N_sl))
      prm%minDipoleHeight_edge  = math_expand(prm%minDipoleHeight_edge, ini%N_sl)
      prm%minDipoleHeight_screw = math_expand(prm%minDipoleHeight_screw,ini%N_sl)
      allocate(prm%minDipoleHeight(prm%sum_N_sl,2))
      prm%minDipoleHeight(:,1)  = prm%minDipoleHeight_edge
      prm%minDipoleHeight(:,2)  = prm%minDipoleHeight_screw

      prm%peierlsstress_edge    = config%getFloats('peierlsstressedge',        requiredSize=size(ini%N_sl))
      prm%peierlsstress_screw   = config%getFloats('peierlsstressscrew',       requiredSize=size(ini%N_sl))
      prm%peierlsstress_edge    = math_expand(prm%peierlsstress_edge, ini%N_sl)
      prm%peierlsstress_screw   = math_expand(prm%peierlsstress_screw,ini%N_sl)
      allocate(prm%peierlsstress(prm%sum_N_sl,2))
      prm%peierlsstress(:,1)    = prm%peierlsstress_edge
      prm%peierlsstress(:,2)    = prm%peierlsstress_screw

      prm%significantRho              = config%getFloat('significantrho')
      prm%significantN                = config%getFloat('significantn', 0.0_pReal)
      prm%CFLfactor                   = config%getFloat('cflfactor',defaultVal=2.0_pReal)

      prm%atomicVolume                = config%getFloat('atomicvolume')
      prm%Dsd0                        = config%getFloat('selfdiffusionprefactor') !,'dsd0'
      prm%selfDiffusionEnergy         = config%getFloat('selfdiffusionenergy') !,'qsd'
      prm%linetensionEffect           = config%getFloat('linetension')
      prm%edgeJogFactor               = config%getFloat('edgejog')!,'edgejogs'
      prm%doublekinkwidth             = config%getFloat('doublekinkwidth')
      prm%solidSolutionEnergy         = config%getFloat('solidsolutionenergy')
      prm%solidSolutionSize           = config%getFloat('solidsolutionsize')
      prm%solidSolutionConcentration  = config%getFloat('solidsolutionconcentration')

      prm%p                           = config%getFloat('p')
      prm%q                           = config%getFloat('q')
      prm%viscosity                   = config%getFloat('viscosity')
      prm%fattack                     = config%getFloat('attackfrequency')

      ! ToDo: discuss logic
      ini%rhoSglScatter               = config%getFloat('rhosglscatter')
      ini%rhoSglRandom                = config%getFloat('rhosglrandom',0.0_pReal)
      if (config%keyExists('/rhosglrandom/')) &
        ini%rhoSglRandomBinning       = config%getFloat('rhosglrandombinning',0.0_pReal) !ToDo: useful default?
     ! if (rhoSglRandom(instance) < 0.0_pReal) &
     ! if (rhoSglRandomBinning(instance) <= 0.0_pReal) &

      prm%surfaceTransmissivity       = config%getFloat('surfacetransmissivity',defaultVal=1.0_pReal)
      prm%grainboundaryTransmissivity = config%getFloat('grainboundarytransmissivity',defaultVal=-1.0_pReal)
      prm%fEdgeMultiplication         = config%getFloat('edgemultiplication')
      prm%shortRangeStressCorrection  = config%keyExists('/shortrangestresscorrection/')

!--------------------------------------------------------------------------------------------------
!  sanity checks
      if (any(prm%burgers          <  0.0_pReal)) extmsg = trim(extmsg)//' burgers'
      if (any(prm%lambda0          <= 0.0_pReal)) extmsg = trim(extmsg)//' lambda0'

      if (any(ini%rhoSglEdgePos0   <  0.0_pReal)) extmsg = trim(extmsg)//' rhoSglEdgePos0'
      if (any(ini%rhoSglEdgeNeg0   <  0.0_pReal)) extmsg = trim(extmsg)//' rhoSglEdgeNeg0'
      if (any(ini%rhoSglScrewPos0  <  0.0_pReal)) extmsg = trim(extmsg)//' rhoSglScrewPos0'
      if (any(ini%rhoSglScrewNeg0  <  0.0_pReal)) extmsg = trim(extmsg)//' rhoSglScrewNeg0'
      if (any(ini%rhoDipEdge0      <  0.0_pReal)) extmsg = trim(extmsg)//' rhoDipEdge0'
      if (any(ini%rhoDipScrew0     <  0.0_pReal)) extmsg = trim(extmsg)//' rhoDipScrew0'

      if (any(prm%peierlsstress    <  0.0_pReal)) extmsg = trim(extmsg)//' peierlsstress'
      if (any(prm%minDipoleHeight  <  0.0_pReal)) extmsg = trim(extmsg)//' minDipoleHeight'

      if (prm%viscosity           <= 0.0_pReal)   extmsg = trim(extmsg)//' viscosity'
      if (prm%selfDiffusionEnergy <= 0.0_pReal)   extmsg = trim(extmsg)//' selfDiffusionEnergy'
      if (prm%fattack             <= 0.0_pReal)   extmsg = trim(extmsg)//' fattack'
      if (prm%doublekinkwidth     <= 0.0_pReal)   extmsg = trim(extmsg)//' doublekinkwidth'
      if (prm%Dsd0                < 0.0_pReal)    extmsg = trim(extmsg)//' Dsd0'
      if (prm%atomicVolume        <= 0.0_pReal)   extmsg = trim(extmsg)//' atomicVolume'            ! ToDo: in disloUCLA, the atomic volume is given as a factor

      if (prm%significantN         < 0.0_pReal)   extmsg = trim(extmsg)//' significantN'
      if (prm%significantrho       < 0.0_pReal)   extmsg = trim(extmsg)//' significantrho'
      if (prm%atol_rho             < 0.0_pReal)   extmsg = trim(extmsg)//' atol_rho'
      if (prm%CFLfactor            < 0.0_pReal)   extmsg = trim(extmsg)//' CFLfactor'

      if (prm%p <= 0.0_pReal .or. prm%p > 1.0_pReal) extmsg = trim(extmsg)//' p'
      if (prm%q <  1.0_pReal .or. prm%q > 2.0_pReal) extmsg = trim(extmsg)//' q'

      if (prm%linetensionEffect <  0.0_pReal .or. prm%linetensionEffect  > 1.0_pReal) &
                                                  extmsg = trim(extmsg)//' linetensionEffect'
      if (prm%edgeJogFactor     <  0.0_pReal .or. prm%edgeJogFactor      > 1.0_pReal) &
                                                  extmsg = trim(extmsg)//' edgeJogFactor'

      if (prm%solidSolutionEnergy        <= 0.0_pReal) extmsg = trim(extmsg)//' solidSolutionEnergy'
      if (prm%solidSolutionSize          <= 0.0_pReal) extmsg = trim(extmsg)//' solidSolutionSize'
      if (prm%solidSolutionConcentration <= 0.0_pReal) extmsg = trim(extmsg)//' solidSolutionConcentration'

      if (prm%grainboundaryTransmissivity  > 1.0_pReal) extmsg = trim(extmsg)//' grainboundaryTransmissivity'
      if (prm%surfaceTransmissivity  <  0.0_pReal .or. prm%surfaceTransmissivity  > 1.0_pReal) &
                                                        extmsg = trim(extmsg)//' surfaceTransmissivity'

      if (prm%fEdgeMultiplication  <  0.0_pReal .or. prm%fEdgeMultiplication  > 1.0_pReal) &
        extmsg = trim(extmsg)//' fEdgeMultiplication'

    endif slipActive

!--------------------------------------------------------------------------------------------------
! allocate state arrays
    NipcMyPhase  = count(material_phaseAt==p) * discretization_nIP
    sizeDotState = size([   'rhoSglEdgePosMobile   ','rhoSglEdgeNegMobile   ', &
                            'rhoSglScrewPosMobile  ','rhoSglScrewNegMobile  ', &
                            'rhoSglEdgePosImmobile ','rhoSglEdgeNegImmobile ', &
                            'rhoSglScrewPosImmobile','rhoSglScrewNegImmobile', &
                            'rhoDipEdge            ','rhoDipScrew           ', &
                            'gamma                 ' ]) * prm%sum_N_sl                              !< "basic" microstructural state variables that are independent from other state variables
    sizeDependentState = size([ 'rhoForest   ']) * prm%sum_N_sl                                     !< microstructural state variables that depend on other state variables
    sizeState          = sizeDotState + sizeDependentState &
                       + size([ 'velocityEdgePos     ','velocityEdgeNeg     ', &
                                'velocityScrewPos    ','velocityScrewNeg    ', &
                                'maxDipoleHeightEdge ','maxDipoleHeightScrew' ]) * prm%sum_N_sl     !< other dependent state variables that are not updated by microstructure
    sizeDeltaState            = sizeDotState

    call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,sizeDeltaState)

    plasticState(p)%nonlocal = .true.
    plasticState(p)%offsetDeltaState = 0                                                            ! ToDo: state structure does not follow convention

    st0%rho => plasticState(p)%state0                             (0*prm%sum_N_sl+1:10*prm%sum_N_sl,:)
    stt%rho => plasticState(p)%state                              (0*prm%sum_N_sl+1:10*prm%sum_N_sl,:)
    dot%rho => plasticState(p)%dotState                           (0*prm%sum_N_sl+1:10*prm%sum_N_sl,:)
    del%rho => plasticState(p)%deltaState                         (0*prm%sum_N_sl+1:10*prm%sum_N_sl,:)
    plasticState(p)%atol(1:10*prm%sum_N_sl) = prm%atol_rho

      stt%rhoSgl => plasticState(p)%state                         (0*prm%sum_N_sl+1: 8*prm%sum_N_sl,:)
      dot%rhoSgl => plasticState(p)%dotState                      (0*prm%sum_N_sl+1: 8*prm%sum_N_sl,:)
      del%rhoSgl => plasticState(p)%deltaState                    (0*prm%sum_N_sl+1: 8*prm%sum_N_sl,:)

        stt%rhoSglMobile => plasticState(p)%state                 (0*prm%sum_N_sl+1: 4*prm%sum_N_sl,:)
        dot%rhoSglMobile => plasticState(p)%dotState              (0*prm%sum_N_sl+1: 4*prm%sum_N_sl,:)
        del%rhoSglMobile => plasticState(p)%deltaState            (0*prm%sum_N_sl+1: 4*prm%sum_N_sl,:)

            stt%rho_sgl_mob_edg_pos => plasticState(p)%state      (0*prm%sum_N_sl+1: 1*prm%sum_N_sl,:)
            dot%rho_sgl_mob_edg_pos => plasticState(p)%dotState   (0*prm%sum_N_sl+1: 1*prm%sum_N_sl,:)
            del%rho_sgl_mob_edg_pos => plasticState(p)%deltaState (0*prm%sum_N_sl+1: 1*prm%sum_N_sl,:)

            stt%rho_sgl_mob_edg_neg => plasticState(p)%state      (1*prm%sum_N_sl+1: 2*prm%sum_N_sl,:)
            dot%rho_sgl_mob_edg_neg => plasticState(p)%dotState   (1*prm%sum_N_sl+1: 2*prm%sum_N_sl,:)
            del%rho_sgl_mob_edg_neg => plasticState(p)%deltaState (1*prm%sum_N_sl+1: 2*prm%sum_N_sl,:)

            stt%rho_sgl_mob_scr_pos => plasticState(p)%state      (2*prm%sum_N_sl+1: 3*prm%sum_N_sl,:)
            dot%rho_sgl_mob_scr_pos => plasticState(p)%dotState   (2*prm%sum_N_sl+1: 3*prm%sum_N_sl,:)
            del%rho_sgl_mob_scr_pos => plasticState(p)%deltaState (2*prm%sum_N_sl+1: 3*prm%sum_N_sl,:)

            stt%rho_sgl_mob_scr_neg => plasticState(p)%state      (3*prm%sum_N_sl+1: 4*prm%sum_N_sl,:)
            dot%rho_sgl_mob_scr_neg => plasticState(p)%dotState   (3*prm%sum_N_sl+1: 4*prm%sum_N_sl,:)
            del%rho_sgl_mob_scr_neg => plasticState(p)%deltaState (3*prm%sum_N_sl+1: 4*prm%sum_N_sl,:)

        stt%rhoSglImmobile => plasticState(p)%state               (4*prm%sum_N_sl+1: 8*prm%sum_N_sl,:)
        dot%rhoSglImmobile => plasticState(p)%dotState            (4*prm%sum_N_sl+1: 8*prm%sum_N_sl,:)
        del%rhoSglImmobile => plasticState(p)%deltaState          (4*prm%sum_N_sl+1: 8*prm%sum_N_sl,:)

            stt%rho_sgl_imm_edg_pos => plasticState(p)%state      (4*prm%sum_N_sl+1: 5*prm%sum_N_sl,:)
            dot%rho_sgl_imm_edg_pos => plasticState(p)%dotState   (4*prm%sum_N_sl+1: 5*prm%sum_N_sl,:)
            del%rho_sgl_imm_edg_pos => plasticState(p)%deltaState (4*prm%sum_N_sl+1: 5*prm%sum_N_sl,:)

            stt%rho_sgl_imm_edg_neg => plasticState(p)%state      (5*prm%sum_N_sl+1: 6*prm%sum_N_sl,:)
            dot%rho_sgl_imm_edg_neg => plasticState(p)%dotState   (5*prm%sum_N_sl+1: 6*prm%sum_N_sl,:)
            del%rho_sgl_imm_edg_neg => plasticState(p)%deltaState (5*prm%sum_N_sl+1: 6*prm%sum_N_sl,:)

            stt%rho_sgl_imm_scr_pos => plasticState(p)%state      (6*prm%sum_N_sl+1: 7*prm%sum_N_sl,:)
            dot%rho_sgl_imm_scr_pos => plasticState(p)%dotState   (6*prm%sum_N_sl+1: 7*prm%sum_N_sl,:)
            del%rho_sgl_imm_scr_pos => plasticState(p)%deltaState (6*prm%sum_N_sl+1: 7*prm%sum_N_sl,:)

            stt%rho_sgl_imm_scr_neg => plasticState(p)%state      (7*prm%sum_N_sl+1: 8*prm%sum_N_sl,:)
            dot%rho_sgl_imm_scr_neg => plasticState(p)%dotState   (7*prm%sum_N_sl+1: 8*prm%sum_N_sl,:)
            del%rho_sgl_imm_scr_neg => plasticState(p)%deltaState (7*prm%sum_N_sl+1: 8*prm%sum_N_sl,:)

      stt%rhoDip => plasticState(p)%state                         (8*prm%sum_N_sl+1:10*prm%sum_N_sl,:)
      dot%rhoDip => plasticState(p)%dotState                      (8*prm%sum_N_sl+1:10*prm%sum_N_sl,:)
      del%rhoDip => plasticState(p)%deltaState                    (8*prm%sum_N_sl+1:10*prm%sum_N_sl,:)

        stt%rho_dip_edg => plasticState(p)%state                  (8*prm%sum_N_sl+1: 9*prm%sum_N_sl,:)
        dot%rho_dip_edg => plasticState(p)%dotState               (8*prm%sum_N_sl+1: 9*prm%sum_N_sl,:)
        del%rho_dip_edg => plasticState(p)%deltaState             (8*prm%sum_N_sl+1: 9*prm%sum_N_sl,:)

        stt%rho_dip_scr => plasticState(p)%state                  (9*prm%sum_N_sl+1:10*prm%sum_N_sl,:)
        dot%rho_dip_scr => plasticState(p)%dotState               (9*prm%sum_N_sl+1:10*prm%sum_N_sl,:)
        del%rho_dip_scr => plasticState(p)%deltaState             (9*prm%sum_N_sl+1:10*prm%sum_N_sl,:)

    stt%gamma => plasticState(p)%state                      (10*prm%sum_N_sl + 1:11*prm%sum_N_sl,1:NipcMyPhase)
    dot%gamma => plasticState(p)%dotState                   (10*prm%sum_N_sl + 1:11*prm%sum_N_sl,1:NipcMyPhase)
    del%gamma => plasticState(p)%deltaState                 (10*prm%sum_N_sl + 1:11*prm%sum_N_sl,1:NipcMyPhase)
    plasticState(p)%atol(10*prm%sum_N_sl+1:11*prm%sum_N_sl )  = config%getFloat('atol_gamma', defaultVal = 1.0e-2_pReal)
    if(any(plasticState(p)%atol(10*prm%sum_N_sl+1:11*prm%sum_N_sl) < 0.0_pReal)) &
      extmsg = trim(extmsg)//' atol_gamma'
    plasticState(p)%slipRate => plasticState(p)%dotState    (10*prm%sum_N_sl + 1:11*prm%sum_N_sl,1:NipcMyPhase)

    stt%rho_forest => plasticState(p)%state                 (11*prm%sum_N_sl + 1:12*prm%sum_N_sl,1:NipcMyPhase)
    stt%v          => plasticState(p)%state                 (12*prm%sum_N_sl + 1:16*prm%sum_N_sl,1:NipcMyPhase)
        stt%v_edg_pos  => plasticState(p)%state             (12*prm%sum_N_sl + 1:13*prm%sum_N_sl,1:NipcMyPhase)
        stt%v_edg_neg  => plasticState(p)%state             (13*prm%sum_N_sl + 1:14*prm%sum_N_sl,1:NipcMyPhase)
        stt%v_scr_pos  => plasticState(p)%state             (14*prm%sum_N_sl + 1:15*prm%sum_N_sl,1:NipcMyPhase)
        stt%v_scr_neg  => plasticState(p)%state             (15*prm%sum_N_sl + 1:16*prm%sum_N_sl,1:NipcMyPhase)

    allocate(dst%tau_pass(prm%sum_N_sl,NipcMyPhase),source=0.0_pReal)
    allocate(dst%tau_back(prm%sum_N_sl,NipcMyPhase),source=0.0_pReal)
    end associate

    if (NipcMyPhase > 0) call stateInit(ini,p,NipcMyPhase)
    plasticState(p)%state0 = plasticState(p)%state

!--------------------------------------------------------------------------------------------------
!  exit if any parameter is out of range
    if (extmsg /= '') call IO_error(211,ext_msg=trim(extmsg)//'('//PLASTICITY_NONLOCAL_LABEL//')')

  enddo

  allocate(compatibility(2,maxval(param%sum_N_sl),maxval(param%sum_N_sl),nIPneighbors,&
                         discretization_nIP,discretization_nElem), source=0.0_pReal)

! BEGIN DEPRECATED----------------------------------------------------------------------------------
  allocate(iRhoU(maxval(param%sum_N_sl),4,Ninstance), source=0)
  allocate(iV(maxval(param%sum_N_sl),4,Ninstance),    source=0)
  allocate(iD(maxval(param%sum_N_sl),2,Ninstance),    source=0)

  initializeInstances: do p = 1, size(phase_plasticity)
    NipcMyPhase = count(material_phaseAt==p) * discretization_nIP
    myPhase2: if (phase_plasticity(p) == PLASTICITY_NONLOCAL_ID) then
      l = 0
      do t = 1,4
        do s = 1,param(phase_plasticityInstance(p))%sum_N_sl
          l = l + 1
          iRhoU(s,t,phase_plasticityInstance(p)) = l
        enddo
      enddo
      l = l + (4+2+1+1)*param(phase_plasticityInstance(p))%sum_N_sl ! immobile(4), dipole(2), shear, forest
      do t = 1,4
        do s = 1,param(phase_plasticityInstance(p))%sum_N_sl
          l = l + 1
          iV(s,t,phase_plasticityInstance(p)) = l
        enddo
      enddo
      do t = 1,2
        do s = 1,param(phase_plasticityInstance(p))%sum_N_sl
          l = l + 1
          iD(s,t,phase_plasticityInstance(p)) = l
        enddo
      enddo
      if (iD(param(phase_plasticityInstance(p))%sum_N_sl,2,phase_plasticityInstance(p)) /= plasticState(p)%sizeState) &
        call IO_error(0, ext_msg = 'state indices not properly set ('//PLASTICITY_NONLOCAL_LABEL//')')
    endif myPhase2
  enddo initializeInstances

end subroutine plastic_nonlocal_init


!--------------------------------------------------------------------------------------------------
!> @brief calculates quantities characterizing the microstructure
!--------------------------------------------------------------------------------------------------
module subroutine plastic_nonlocal_dependentState(F, Fp, instance, of, ip, el)

  real(pReal), dimension(3,3), intent(in) :: &
    F, &
    Fp
  integer, intent(in) :: &
    instance, &
    of, &
    ip, &
    el

  integer :: &
    no, &                                                                                           !< neighbor offset
    neighbor_el, &                                                                                  ! element number of neighboring material point
    neighbor_ip, &                                                                                  ! integration point of neighboring material point
    neighbor_instance, &                                                                            ! instance of this plasticity of neighboring material point
    c, &                                                                                            ! index of dilsocation character (edge, screw)
    s, &                                                                                            ! slip system index
    dir, &
    n
  real(pReal) :: &
    FVsize, &
    nRealNeighbors                                                                                  ! number of really existing neighbors
  integer, dimension(2) :: &
    neighbors
  real(pReal), dimension(2) :: &
    rhoExcessGradient, &
    rhoExcessGradient_over_rho, &
    rhoTotal
  real(pReal), dimension(3) :: &
    rhoExcessDifferences, &
    normal_latticeConf
  real(pReal), dimension(3,3) :: &
    invFe, &                                                                                        !< inverse of elastic deformation gradient
    invFp, &                                                                                        !< inverse of plastic deformation gradient
    connections, &
    invConnections
  real(pReal), dimension(3,nIPneighbors) :: &
    connection_latticeConf
  real(pReal), dimension(2,param(instance)%sum_N_sl) :: &
    rhoExcess
  real(pReal), dimension(param(instance)%sum_N_sl) :: &
    rho_edg_delta, &
    rho_scr_delta
  real(pReal), dimension(param(instance)%sum_N_sl,10) :: &
    rho, &
    rho0, &
    rho_neighbor0
  real(pReal), dimension(param(instance)%sum_N_sl,param(instance)%sum_N_sl) :: &
    myInteractionMatrix                                                                             ! corrected slip interaction matrix
  real(pReal), dimension(param(instance)%sum_N_sl,nIPneighbors) :: &
    rho_edg_delta_neighbor, &
    rho_scr_delta_neighbor
  real(pReal), dimension(2,maxval(param%sum_N_sl),nIPneighbors) :: &
    neighbor_rhoExcess, &                                                                           ! excess density at neighboring material point
    neighbor_rhoTotal                                                                               ! total density at neighboring material point
  real(pReal), dimension(3,param(instance)%sum_N_sl,2) :: &
    m                                                                                               ! direction of dislocation motion

  associate(prm => param(instance),dst => microstructure(instance), stt => state(instance))

  rho = getRho(instance,of,ip,el)

  stt%rho_forest(:,of) = matmul(prm%forestProjection_Edge, sum(abs(rho(:,edg)),2)) &
                       + matmul(prm%forestProjection_Screw,sum(abs(rho(:,scr)),2))


  ! coefficients are corrected for the line tension effect
  ! (see Kubin,Devincre,Hoc; 2008; Modeling dislocation storage rates and mean free paths in face-centered cubic crystals)
  if (any(lattice_structure(material_phaseAt(1,el)) == [LATTICE_bcc_ID,LATTICE_fcc_ID])) then
    myInteractionMatrix = prm%interactionSlipSlip &
                        * spread((  1.0_pReal - prm%linetensionEffect &
                                   + prm%linetensionEffect &
                                   * log(0.35_pReal * prm%burgers * sqrt(max(stt%rho_forest(:,of),prm%significantRho))) &
                                   / log(0.35_pReal * prm%burgers * 1e6_pReal))** 2.0_pReal,2,prm%sum_N_sl)
  else
    myInteractionMatrix = prm%interactionSlipSlip
  endif

  dst%tau_pass(:,of) = prm%mu * prm%burgers &
                     * sqrt(matmul(myInteractionMatrix,sum(abs(rho),2)))

!*** calculate the dislocation stress of the neighboring excess dislocation densities
!*** zero for material points of local plasticity

  !#################################################################################################
  ! ToDo: MD: this is most likely only correct for F_i = I
  !#################################################################################################

  rho0 = getRho0(instance,of,ip,el)
  if (.not. phase_localPlasticity(material_phaseAt(1,el)) .and. prm%shortRangeStressCorrection) then
    invFp = math_inv33(Fp)
    invFe = matmul(Fp,math_inv33(F))

    rho_edg_delta = rho0(:,mob_edg_pos) - rho0(:,mob_edg_neg)
    rho_scr_delta = rho0(:,mob_scr_pos) - rho0(:,mob_scr_neg)

    rhoExcess(1,:) = rho_edg_delta
    rhoExcess(2,:) = rho_scr_delta

    FVsize = IPvolume(ip,el) ** (1.0_pReal/3.0_pReal)

    !* loop through my neighborhood and get the connection vectors (in lattice frame) and the excess densities

    nRealNeighbors = 0.0_pReal
    neighbor_rhoTotal = 0.0_pReal
    do n = 1,nIPneighbors
      neighbor_el = IPneighborhood(1,n,ip,el)
      neighbor_ip = IPneighborhood(2,n,ip,el)
      no = material_phasememberAt(1,neighbor_ip,neighbor_el)
      if (neighbor_el > 0 .and. neighbor_ip > 0) then
        neighbor_instance = phase_plasticityInstance(material_phaseAt(1,neighbor_el))
        if (neighbor_instance == instance) then

            nRealNeighbors = nRealNeighbors + 1.0_pReal
            rho_neighbor0 = getRho0(instance,no,neighbor_ip,neighbor_el)

            rho_edg_delta_neighbor(:,n) = rho_neighbor0(:,mob_edg_pos) - rho_neighbor0(:,mob_edg_neg)
            rho_scr_delta_neighbor(:,n) = rho_neighbor0(:,mob_scr_pos) - rho_neighbor0(:,mob_scr_neg)

            neighbor_rhoTotal(1,:,n) = sum(abs(rho_neighbor0(:,edg)),2)
            neighbor_rhoTotal(2,:,n) = sum(abs(rho_neighbor0(:,scr)),2)

            connection_latticeConf(1:3,n) = matmul(invFe, discretization_IPcoords(1:3,neighbor_el+neighbor_ip-1) &
                                          - discretization_IPcoords(1:3,el+neighbor_ip-1))
            normal_latticeConf = matmul(transpose(invFp), IPareaNormal(1:3,n,ip,el))
            if (math_inner(normal_latticeConf,connection_latticeConf(1:3,n)) < 0.0_pReal) &         ! neighboring connection points in opposite direction to face normal: must be periodic image
              connection_latticeConf(1:3,n) = normal_latticeConf * IPvolume(ip,el)/IParea(n,ip,el)  ! instead take the surface normal scaled with the diameter of the cell
        else
          ! local neighbor or different lattice structure or different constitution instance -> use central values instead
          connection_latticeConf(1:3,n) = 0.0_pReal
          rho_edg_delta_neighbor(:,n) = rho_edg_delta
          rho_scr_delta_neighbor(:,n) = rho_scr_delta
        endif
      else
        ! free surface -> use central values instead
        connection_latticeConf(1:3,n) = 0.0_pReal
        rho_edg_delta_neighbor(:,n) = rho_edg_delta
        rho_scr_delta_neighbor(:,n) = rho_scr_delta
      endif
    enddo

    neighbor_rhoExcess(1,:,:) = rho_edg_delta_neighbor
    neighbor_rhoExcess(2,:,:) = rho_scr_delta_neighbor

    !* loop through the slip systems and calculate the dislocation gradient by
    !* 1. interpolation of the excess density in the neighorhood
    !* 2. interpolation of the dead dislocation density in the central volume
    m(1:3,:,1) =  prm%slip_direction
    m(1:3,:,2) = -prm%slip_transverse

    do s = 1,prm%sum_N_sl

      ! gradient from interpolation of neighboring excess density ...
      do c = 1,2
        do dir = 1,3
          neighbors(1) = 2 * dir - 1
          neighbors(2) = 2 * dir
          connections(dir,1:3) = connection_latticeConf(1:3,neighbors(1)) &
                               - connection_latticeConf(1:3,neighbors(2))
          rhoExcessDifferences(dir) = neighbor_rhoExcess(c,s,neighbors(1)) &
                                    - neighbor_rhoExcess(c,s,neighbors(2))
        enddo
        invConnections = math_inv33(connections)
        if (all(dEq0(invConnections))) call IO_error(-1,ext_msg='back stress calculation: inversion error')

        rhoExcessGradient(c) = math_inner(m(1:3,s,c), matmul(invConnections,rhoExcessDifferences))
      enddo

        ! ... plus gradient from deads ...
      rhoExcessGradient(1) = rhoExcessGradient(1) + sum(rho(s,imm_edg)) / FVsize
      rhoExcessGradient(2) = rhoExcessGradient(2) + sum(rho(s,imm_scr)) / FVsize

        ! ... normalized with the total density ...
      rhoTotal(1) = (sum(abs(rho(s,edg))) + sum(neighbor_rhoTotal(1,s,:))) / (1.0_pReal + nRealNeighbors)
      rhoTotal(2) = (sum(abs(rho(s,scr))) + sum(neighbor_rhoTotal(2,s,:))) / (1.0_pReal + nRealNeighbors)

      rhoExcessGradient_over_rho = 0.0_pReal
      where(rhoTotal > 0.0_pReal) rhoExcessGradient_over_rho = rhoExcessGradient / rhoTotal

        ! ... gives the local stress correction when multiplied with a factor
      dst%tau_back(s,of) = - prm%mu * prm%burgers(s) / (2.0_pReal * PI) &
                         * (  rhoExcessGradient_over_rho(1) / (1.0_pReal - prm%nu) &
                            + rhoExcessGradient_over_rho(2))
    enddo
  endif

# 721 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_nonlocal.f90"

 end associate

end subroutine plastic_nonlocal_dependentState


!--------------------------------------------------------------------------------------------------
!> @brief calculates plastic velocity gradient and its tangent
!--------------------------------------------------------------------------------------------------
module subroutine plastic_nonlocal_LpAndItsTangent(Lp,dLp_dMp, &
                                                   Mp,Temperature,instance,of,ip,el)
  real(pReal), dimension(3,3), intent(out) :: &
    Lp                                                                                              !< plastic velocity gradient
  real(pReal), dimension(3,3,3,3), intent(out) :: &
    dLp_dMp
  integer, intent(in) :: &
    instance, &
    of, &
    ip, &                                                                                           !< current integration point
    el                                                                                              !< current element number
  real(pReal), intent(in) :: &
    Temperature                                                                                     !< temperature

  real(pReal), dimension(3,3), intent(in) :: &
    Mp
                                                                                                    !< derivative of Lp with respect to Mp
  integer :: &
    ns, &                                                                                           !< short notation for the total number of active slip systems
    i, &
    j, &
    k, &
    l, &
    t, &                                                                                            !< dislocation type
    s                                                                                               !< index of my current slip system
  real(pReal), dimension(param(instance)%sum_N_sl,8) :: &
    rhoSgl                                                                                          !< single dislocation densities (including blocked)
  real(pReal), dimension(param(instance)%sum_N_sl,10) :: &
    rho
  real(pReal), dimension(param(instance)%sum_N_sl,4) :: &
    v, &                                                                                            !< velocity
    tauNS, &                                                                                        !< resolved shear stress including non Schmid and backstress terms
    dv_dtau, &                                                                                      !< velocity derivative with respect to the shear stress
    dv_dtauNS                                                                                       !< velocity derivative with respect to the shear stress
  real(pReal), dimension(param(instance)%sum_N_sl) :: &
    tau, &                                                                                          !< resolved shear stress including backstress terms
    gdotTotal                                                                                       !< shear rate

  associate(prm => param(instance),dst=>microstructure(instance),stt=>state(instance))
  ns = prm%sum_N_sl

  !*** shortcut to state variables
  rho = getRho(instance,of,ip,el)
  rhoSgl = rho(:,sgl)

  do s = 1,ns
    tau(s) = math_tensordot(Mp, prm%Schmid(1:3,1:3,s))
    tauNS(s,1) = tau(s)
    tauNS(s,2) = tau(s)
    if (tau(s) > 0.0_pReal) then
      tauNS(s,3) = math_tensordot(Mp, +prm%nonSchmid_pos(1:3,1:3,s))
      tauNS(s,4) = math_tensordot(Mp, -prm%nonSchmid_neg(1:3,1:3,s))
    else
      tauNS(s,3) = math_tensordot(Mp, +prm%nonSchmid_neg(1:3,1:3,s))
      tauNS(s,4) = math_tensordot(Mp, -prm%nonSchmid_pos(1:3,1:3,s))
    endif
  enddo
  tauNS = tauNS + spread(dst%tau_back(:,of),2,4)
  tau   = tau   + dst%tau_back(:,of)

  ! edges
  call kinetics(v(:,1), dv_dtau(:,1), dv_dtauNS(:,1), &
                tau, tauNS(:,1), dst%tau_pass(:,of),1,Temperature, instance)
  v(:,2)         = v(:,1)
  dv_dtau(:,2)   = dv_dtau(:,1)
  dv_dtauNS(:,2) = dv_dtauNS(:,1)

  !screws
  if (prm%nonSchmidActive) then
    v(:,3:4)         = spread(v(:,1),2,2)
    dv_dtau(:,3:4)   = spread(dv_dtau(:,1),2,2)
    dv_dtauNS(:,3:4) = spread(dv_dtauNS(:,1),2,2)
  else
    do t = 3,4
      call kinetics(v(:,t), dv_dtau(:,t), dv_dtauNS(:,t), &
                    tau, tauNS(:,t), dst%tau_pass(:,of),2,Temperature, instance)
    enddo
  endif

  stt%v(:,of) = pack(v,.true.)

  !*** Bauschinger effect
  forall (s = 1:ns, t = 5:8, rhoSgl(s,t) * v(s,t-4) < 0.0_pReal) &
    rhoSgl(s,t-4) = rhoSgl(s,t-4) + abs(rhoSgl(s,t))

  gdotTotal = sum(rhoSgl(:,1:4) * v, 2) * prm%burgers

  Lp = 0.0_pReal
  dLp_dMp = 0.0_pReal
  do s = 1,ns
    Lp = Lp + gdotTotal(s) * prm%Schmid(1:3,1:3,s)
    forall (i=1:3,j=1:3,k=1:3,l=1:3) &
      dLp_dMp(i,j,k,l) = dLp_dMp(i,j,k,l) &
          + prm%Schmid(i,j,s) * prm%Schmid(k,l,s) &
          * sum(rhoSgl(s,1:4) * dv_dtau(s,1:4)) * prm%burgers(s) &
          + prm%Schmid(i,j,s) &
          * ( prm%nonSchmid_pos(k,l,s) * rhoSgl(s,3) * dv_dtauNS(s,3) &
            - prm%nonSchmid_neg(k,l,s) * rhoSgl(s,4) * dv_dtauNS(s,4))  * prm%burgers(s)
  enddo

  end associate

end subroutine plastic_nonlocal_LpAndItsTangent


!--------------------------------------------------------------------------------------------------
!> @brief (instantaneous) incremental change of microstructure
!--------------------------------------------------------------------------------------------------
module subroutine plastic_nonlocal_deltaState(Mp,instance,of,ip,el)

  real(pReal), dimension(3,3), intent(in) :: &
    Mp                                                                                              !< MandelStress
  integer, intent(in) :: &
    instance, &                                                                                     ! current instance of this plasticity
    of, &                                                                                           !< offset
    ip, &
    el

  integer :: &
    ph, &                                                                                           !< phase
    ns, &                                                                                           ! short notation for the total number of active slip systems
    c, &                                                                                            ! character of dislocation
    t, &                                                                                            ! type of dislocation
    s                                                                                               ! index of my current slip system
  real(pReal), dimension(param(instance)%sum_N_sl,10) :: &
    deltaRhoRemobilization, &                                                                       ! density increment by remobilization
    deltaRhoDipole2SingleStress                                                                     ! density increment by dipole dissociation (by stress change)
  real(pReal), dimension(param(instance)%sum_N_sl,10) :: &
    rho                                                                                             ! current  dislocation densities
  real(pReal), dimension(param(instance)%sum_N_sl,4) :: &
    v                                                                                               ! dislocation glide velocity
  real(pReal), dimension(param(instance)%sum_N_sl) :: &
    tau                                                                                             ! current resolved shear stress
  real(pReal), dimension(param(instance)%sum_N_sl,2) :: &
    rhoDip, &                                                                                       ! current dipole dislocation densities (screw and edge dipoles)
    dUpper, &                                                                                       ! current maximum stable dipole distance for edges and screws
    dUpperOld, &                                                                                    ! old maximum stable dipole distance for edges and screws
    deltaDUpper                                                                                     ! change in maximum stable dipole distance for edges and screws

   ph = material_phaseAt(1,el)

   associate(prm => param(instance),dst => microstructure(instance),del => deltaState(instance))
   ns = prm%sum_N_sl

  !*** shortcut to state variables
  forall (s = 1:ns, t = 1:4) v(s,t) = plasticState(ph)%state(iV(s,t,instance),of)
  forall (s = 1:ns, c = 1:2) dUpperOld(s,c) = plasticState(ph)%state(iD(s,c,instance),of)

  rho =  getRho(instance,of,ip,el)
  rhoDip = rho(:,dip)

  !****************************************************************************
  !*** dislocation remobilization (bauschinger effect)
  where(rho(:,imm) * v < 0.0_pReal)
    deltaRhoRemobilization(:,mob) = abs(rho(:,imm))
    deltaRhoRemobilization(:,imm) =   - rho(:,imm)
    rho(:,mob) = rho(:,mob) + abs(rho(:,imm))
    rho(:,imm) = 0.0_pReal
  elsewhere
    deltaRhoRemobilization(:,mob) = 0.0_pReal
    deltaRhoRemobilization(:,imm) = 0.0_pReal
  endwhere
  deltaRhoRemobilization(:,dip) = 0.0_pReal

  !****************************************************************************
  !*** calculate dipole formation and dissociation by stress change

  !*** calculate limits for stable dipole height
  do s = 1,prm%sum_N_sl
    tau(s) = math_tensordot(Mp, prm%Schmid(1:3,1:3,s)) +dst%tau_back(s,of)
    if (abs(tau(s)) < 1.0e-15_pReal) tau(s) = 1.0e-15_pReal
  enddo

  dUpper(:,1) = prm%mu * prm%burgers/(8.0_pReal * PI * (1.0_pReal - prm%nu) * abs(tau))
  dUpper(:,2) = prm%mu * prm%burgers/(4.0_pReal * PI * abs(tau))

  where(dNeq0(sqrt(sum(abs(rho(:,edg)),2)))) &
    dUpper(:,1) = min(1.0_pReal/sqrt(sum(abs(rho(:,edg)),2)),dUpper(:,1))
  where(dNeq0(sqrt(sum(abs(rho(:,scr)),2)))) &
    dUpper(:,2) = min(1.0_pReal/sqrt(sum(abs(rho(:,scr)),2)),dUpper(:,2))

  dUpper = max(dUpper,prm%minDipoleHeight)
  deltaDUpper = dUpper - dUpperOld


  !*** dissociation by stress increase
  deltaRhoDipole2SingleStress = 0.0_pReal
  forall (c=1:2, s=1:ns, deltaDUpper(s,c) < 0.0_pReal .and. &
                                          dNeq0(dUpperOld(s,c) - prm%minDipoleHeight(s,c))) &
    deltaRhoDipole2SingleStress(s,8+c) = rhoDip(s,c) * deltaDUpper(s,c) &
                                       / (dUpperOld(s,c) - prm%minDipoleHeight(s,c))

  forall (t=1:4) deltaRhoDipole2SingleStress(:,t) = -0.5_pReal * deltaRhoDipole2SingleStress(:,(t-1)/2+9)
  forall (s = 1:ns, c = 1:2) plasticState(ph)%state(iD(s,c,instance),of) = dUpper(s,c)

  plasticState(ph)%deltaState(:,of) = 0.0_pReal
  del%rho(:,of) = reshape(deltaRhoRemobilization + deltaRhoDipole2SingleStress, [10*ns])

# 936 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_nonlocal.f90"

  end associate

end subroutine plastic_nonlocal_deltaState


!---------------------------------------------------------------------------------------------------
!> @brief calculates the rate of change of microstructure
!---------------------------------------------------------------------------------------------------
module subroutine plastic_nonlocal_dotState(Mp, F, Fp, Temperature,timestep, &
                                            instance,of,ip,el)

  real(pReal), dimension(3,3), intent(in) :: &
    Mp                                                                                              !< MandelStress
  real(pReal), dimension(3,3,homogenization_maxNgrains,discretization_nIP,discretization_nElem), intent(in) :: &
    F, &                                                                                            !< elastic deformation gradient
    Fp                                                                                              !< plastic deformation gradient
  real(pReal), intent(in) :: &
    Temperature, &                                                                                  !< temperature
    timestep                                                                                        !< substepped crystallite time increment
  integer, intent(in) :: &
    instance, &
    of, &
    ip, &                                                                                           !< current integration point
    el                                                                                              !< current element number

  integer ::  &
    ph, &
    neighbor_instance, &                                                                            !< instance of my neighbor's plasticity
    ns, &                                                                                           !< short notation for the total number of active slip systems
    c, &                                                                                            !< character of dislocation
    n, &                                                                                            !< index of my current neighbor
    neighbor_el, &                                                                                  !< element number of my neighbor
    neighbor_ip, &                                                                                  !< integration point of my neighbor
    neighbor_n, &                                                                                   !< neighbor index pointing to me when looking from my neighbor
    opposite_neighbor, &                                                                            !< index of my opposite neighbor
    opposite_ip, &                                                                                  !< ip of my opposite neighbor
    opposite_el, &                                                                                  !< element index of my opposite neighbor
    opposite_n, &                                                                                   !< neighbor index pointing to me when looking from my opposite neighbor
    t, &                                                                                            !< type of dislocation
    no,&                                                                                            !< neighbor offset shortcut
    np,&                                                                                            !< neighbor phase shortcut
    topp, &                                                                                         !< type of dislocation with opposite sign to t
    s                                                                                               !< index of my current slip system
  real(pReal), dimension(param(instance)%sum_N_sl,10) :: &
    rho, &
    rho0, &                                                                                         !< dislocation density at beginning of time step
    rhoDot, &                                                                                       !< density evolution
    rhoDotMultiplication, &                                                                         !< density evolution by multiplication
    rhoDotFlux, &                                                                                   !< density evolution by flux
    rhoDotSingle2DipoleGlide, &                                                                     !< density evolution by dipole formation (by glide)
    rhoDotAthermalAnnihilation, &                                                                   !< density evolution by athermal annihilation
    rhoDotThermalAnnihilation                                                                       !< density evolution by thermal annihilation
  real(pReal), dimension(param(instance)%sum_N_sl,8) :: &
    rhoSgl, &                                                                                       !< current single dislocation densities (positive/negative screw and edge without dipoles)
    neighbor_rhoSgl0, &                                                                             !< current single dislocation densities of neighboring ip (positive/negative screw and edge without dipoles)
    my_rhoSgl0                                                                                      !< single dislocation densities of central ip (positive/negative screw and edge without dipoles)
  real(pReal), dimension(param(instance)%sum_N_sl,4) :: &
    v, &                                                                                            !< current dislocation glide velocity
    v0, &
    neighbor_v0, &                                                                                  !< dislocation glide velocity of enighboring ip
    gdot                                                                                            !< shear rates
  real(pReal), dimension(param(instance)%sum_N_sl) :: &
    tau, &                                                                                          !< current resolved shear stress
    vClimb                                                                                          !< climb velocity of edge dipoles
  real(pReal), dimension(param(instance)%sum_N_sl,2) :: &
    rhoDip, &                                                                                       !< current dipole dislocation densities (screw and edge dipoles)
    dLower, &                                                                                       !< minimum stable dipole distance for edges and screws
    dUpper                                                                                          !< current maximum stable dipole distance for edges and screws
  real(pReal), dimension(3,param(instance)%sum_N_sl,4) :: &
    m                                                                                               !< direction of dislocation motion
  real(pReal), dimension(3,3) :: &
    my_F, &                                                                                         !< my total deformation gradient
    neighbor_F, &                                                                                   !< total deformation gradient of my neighbor
    my_Fe, &                                                                                        !< my elastic deformation gradient
    neighbor_Fe, &                                                                                  !< elastic deformation gradient of my neighbor
    Favg                                                                                            !< average total deformation gradient of me and my neighbor
  real(pReal), dimension(3) :: &
    normal_neighbor2me, &                                                                           !< interface normal pointing from my neighbor to me in neighbor's lattice configuration
    normal_neighbor2me_defConf, &                                                                   !< interface normal pointing from my neighbor to me in shared deformed configuration
    normal_me2neighbor, &                                                                           !< interface normal pointing from me to my neighbor in my lattice configuration
    normal_me2neighbor_defConf                                                                      !< interface normal pointing from me to my neighbor in shared deformed configuration
  real(pReal) :: &
    area, &                                                                                         !< area of the current interface
    transmissivity, &                                                                               !< overall transmissivity of dislocation flux to neighboring material point
    lineLength, &                                                                                   !< dislocation line length leaving the current interface
    selfDiffusion                                                                                   !< self diffusion

  ph = material_phaseAt(1,el)
  if (timestep <= 0.0_pReal) then
    plasticState(ph)%dotState = 0.0_pReal
    return
  endif

  associate(prm => param(instance), &
            dst => microstructure(instance), &
            dot => dotState(instance), &
            stt => state(instance))
  ns = prm%sum_N_sl

  tau = 0.0_pReal
  gdot = 0.0_pReal

  rho  = getRho(instance,of,ip,el)
  rhoSgl = rho(:,sgl)
  rhoDip = rho(:,dip)
  rho0 = getRho0(instance,of,ip,el)
  my_rhoSgl0 = rho0(:,sgl)

  forall (s = 1:ns, t = 1:4) v(s,t) = plasticState(ph)%state(iV(s,t,instance),of)
  gdot = rhoSgl(:,1:4) * v * spread(prm%burgers,2,4)

# 1056 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_nonlocal.f90"

  !****************************************************************************
  !*** limits for stable dipole height
  do s = 1,ns
    tau(s) = math_tensordot(Mp, prm%Schmid(1:3,1:3,s)) + dst%tau_back(s,of)
    if (abs(tau(s)) < 1.0e-15_pReal) tau(s) = 1.0e-15_pReal
  enddo

  dLower = prm%minDipoleHeight
  dUpper(:,1) = prm%mu * prm%burgers/(8.0_pReal * PI * (1.0_pReal - prm%nu) * abs(tau))
  dUpper(:,2) = prm%mu * prm%burgers/(4.0_pReal * PI * abs(tau))

  where(dNeq0(sqrt(sum(abs(rho(:,edg)),2)))) &
    dUpper(:,1) = min(1.0_pReal/sqrt(sum(abs(rho(:,edg)),2)),dUpper(:,1))
  where(dNeq0(sqrt(sum(abs(rho(:,scr)),2)))) &
    dUpper(:,2) = min(1.0_pReal/sqrt(sum(abs(rho(:,scr)),2)),dUpper(:,2))

  dUpper = max(dUpper,dLower)

  !****************************************************************************
  !*** dislocation multiplication
  rhoDotMultiplication = 0.0_pReal
  isBCC: if (lattice_structure(ph) == LATTICE_bcc_ID) then
    forall (s = 1:ns, sum(abs(v(s,1:4))) > 0.0_pReal)
      rhoDotMultiplication(s,1:2) = sum(abs(gdot(s,3:4))) / prm%burgers(s) &                        ! assuming double-cross-slip of screws to be decisive for multiplication
                                  * sqrt(stt%rho_forest(s,of)) / prm%lambda0(s) ! &                 ! mean free path
                                  ! * 2.0_pReal * sum(abs(v(s,3:4))) / sum(abs(v(s,1:4)))           ! ratio of screw to overall velocity determines edge generation
      rhoDotMultiplication(s,3:4) = sum(abs(gdot(s,3:4))) /prm%burgers(s) &                         ! assuming double-cross-slip of screws to be decisive for multiplication
                                  * sqrt(stt%rho_forest(s,of)) / prm%lambda0(s) ! &                 ! mean free path
                                  ! * 2.0_pReal * sum(abs(v(s,1:2))) / sum(abs(v(s,1:4)))           ! ratio of edge to overall velocity determines screw generation
    endforall

  else isBCC
    rhoDotMultiplication(:,1:4) = spread( &
          (sum(abs(gdot(:,1:2)),2) * prm%fEdgeMultiplication + sum(abs(gdot(:,3:4)),2)) &
        * sqrt(stt%rho_forest(:,of)) / prm%lambda0 / prm%burgers, 2, 4)
  endif isBCC

  forall (s = 1:ns, t = 1:4) v0(s,t) = plasticState(ph)%state0(iV(s,t,instance),of)

  !****************************************************************************
  !*** calculate dislocation fluxes (only for nonlocal plasticity)
  rhoDotFlux = 0.0_pReal
  if (.not. phase_localPlasticity(material_phaseAt(1,el))) then

    !*** check CFL (Courant-Friedrichs-Lewy) condition for flux
    if (any( abs(gdot) > 0.0_pReal &                                                                ! any active slip system ...
            .and. prm%CFLfactor * abs(v0) * timestep &
                > IPvolume(ip,el) / maxval(IParea(:,ip,el)))) then                                  ! ...with velocity above critical value (we use the reference volume and area for simplicity here)
# 1116 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_nonlocal.f90"
      plasticState(ph)%dotState = IEEE_value(1.0_pReal,IEEE_quiet_NaN)                               ! -> return NaN and, hence, enforce cutback
      return
    endif


    !*** be aware of the definition of slip_transverse = slip_direction x slip_normal !!!
    !*** opposite sign to our t vector in the (s,t,n) triplet !!!

    m(1:3,:,1) =  prm%slip_direction
    m(1:3,:,2) = -prm%slip_direction
    m(1:3,:,3) = -prm%slip_transverse
    m(1:3,:,4) =  prm%slip_transverse

    my_F = F(1:3,1:3,1,ip,el)
    my_Fe = matmul(my_F, math_inv33(Fp(1:3,1:3,1,ip,el)))

    neighbors: do n = 1,nIPneighbors

      neighbor_el = IPneighborhood(1,n,ip,el)
      neighbor_ip = IPneighborhood(2,n,ip,el)
      neighbor_n  = IPneighborhood(3,n,ip,el)
      np = material_phaseAt(1,neighbor_el)
      no = material_phasememberAt(1,neighbor_ip,neighbor_el)

      opposite_neighbor = n + mod(n,2) - mod(n+1,2)
      opposite_el = IPneighborhood(1,opposite_neighbor,ip,el)
      opposite_ip = IPneighborhood(2,opposite_neighbor,ip,el)
      opposite_n  = IPneighborhood(3,opposite_neighbor,ip,el)

      if (neighbor_n > 0) then                                                                      ! if neighbor exists, average deformation gradient
        neighbor_instance = phase_plasticityInstance(material_phaseAt(1,neighbor_el))
        neighbor_F = F(1:3,1:3,1,neighbor_ip,neighbor_el)
        neighbor_Fe = matmul(neighbor_F, math_inv33(Fp(1:3,1:3,1,neighbor_ip,neighbor_el)))
        Favg = 0.5_pReal * (my_F + neighbor_F)
      else                                                                                          ! if no neighbor, take my value as average
        Favg = my_F
      endif

      neighbor_v0 = 0.0_pReal        ! needed for check of sign change in flux density below

      !* FLUX FROM MY NEIGHBOR TO ME
      !* This is only considered, if I have a neighbor of nonlocal plasticity
      !* (also nonlocal constitutive law with local properties) that is at least a little bit
      !* compatible.
      !* If it's not at all compatible, no flux is arriving, because everything is dammed in front of
      !* my neighbor's interface.
      !* The entering flux from my neighbor will be distributed on my slip systems according to the
      !* compatibility
      if (neighbor_n > 0) then
      if (phase_plasticity(material_phaseAt(1,neighbor_el)) == PLASTICITY_NONLOCAL_ID .and. &
          any(compatibility(:,:,:,n,ip,el) > 0.0_pReal)) then

        forall (s = 1:ns, t = 1:4)
          neighbor_v0(s,t) =          plasticState(np)%state0(iV   (s,t,neighbor_instance),no)
          neighbor_rhoSgl0(s,t) = max(plasticState(np)%state0(iRhoU(s,t,neighbor_instance),no),0.0_pReal)
        endforall

        where (neighbor_rhoSgl0 * IPvolume(neighbor_ip,neighbor_el) ** 0.667_pReal < prm%significantN &
          .or. neighbor_rhoSgl0 < prm%significantRho) &
          neighbor_rhoSgl0 = 0.0_pReal
        normal_neighbor2me_defConf = math_det33(Favg) * matmul(math_inv33(transpose(Favg)), &
                                     IPareaNormal(1:3,neighbor_n,neighbor_ip,neighbor_el))          ! normal of the interface in (average) deformed configuration (pointing neighbor => me)
        normal_neighbor2me = matmul(transpose(neighbor_Fe), normal_neighbor2me_defConf) &
                           / math_det33(neighbor_Fe)                                                ! interface normal in the lattice configuration of my neighbor
        area = IParea(neighbor_n,neighbor_ip,neighbor_el) * norm2(normal_neighbor2me)
        normal_neighbor2me = normal_neighbor2me / norm2(normal_neighbor2me)                         ! normalize the surface normal to unit length
        do s = 1,ns
          do t = 1,4
            c = (t + 1) / 2
            topp = t + mod(t,2) - mod(t+1,2)
            if (neighbor_v0(s,t) * math_inner(m(1:3,s,t), normal_neighbor2me) > 0.0_pReal &         ! flux from my neighbor to me == entering flux for me
                .and. v0(s,t) * neighbor_v0(s,t) >= 0.0_pReal ) then                                ! ... only if no sign change in flux density
              lineLength = neighbor_rhoSgl0(s,t) * neighbor_v0(s,t) &
                         * math_inner(m(1:3,s,t), normal_neighbor2me) * area                        ! positive line length that wants to enter through this interface
              where (compatibility(c,:,s,n,ip,el) > 0.0_pReal) &
                rhoDotFlux(:,t) = rhoDotFlux(1:ns,t) &
                                + lineLength/IPvolume(ip,el)*compatibility(c,:,s,n,ip,el)**2.0_pReal    ! transferring to equally signed mobile dislocation type
              where (compatibility(c,:,s,n,ip,el) < 0.0_pReal) &
                rhoDotFlux(:,topp) = rhoDotFlux(:,topp) &
                                   + lineLength/IPvolume(ip,el)*compatibility(c,:,s,n,ip,el)**2.0_pReal ! transferring to opposite signed mobile dislocation type

            endif
          enddo
        enddo
      endif; endif


      !* FLUX FROM ME TO MY NEIGHBOR
      !* This is not considered, if my opposite neighbor has a different constitutive law than nonlocal (still considered for nonlocal law with local properties).
      !* Then, we assume, that the opposite(!) neighbor sends an equal amount of dislocations to me.
      !* So the net flux in the direction of my neighbor is equal to zero:
      !*    leaving flux to neighbor == entering flux from opposite neighbor
      !* In case of reduced transmissivity, part of the leaving flux is stored as dead dislocation density.
      !* That means for an interface of zero transmissivity the leaving flux is fully converted to dead dislocations.
      if (opposite_n > 0) then
      if (phase_plasticity(material_phaseAt(1,opposite_el)) == PLASTICITY_NONLOCAL_ID) then

        normal_me2neighbor_defConf = math_det33(Favg) &
                                   * matmul(math_inv33(transpose(Favg)),IPareaNormal(1:3,n,ip,el))  ! normal of the interface in (average) deformed configuration (pointing me => neighbor)
        normal_me2neighbor = matmul(transpose(my_Fe), normal_me2neighbor_defConf) &
                           / math_det33(my_Fe)                                                      ! interface normal in my lattice configuration
        area = IParea(n,ip,el) * norm2(normal_me2neighbor)
        normal_me2neighbor = normal_me2neighbor / norm2(normal_me2neighbor)                         ! normalize the surface normal to unit length
        do s = 1,ns
          do t = 1,4
            c = (t + 1) / 2
            if (v0(s,t) * math_inner(m(1:3,s,t), normal_me2neighbor) > 0.0_pReal ) then             ! flux from me to my neighbor == leaving flux for me (might also be a pure flux from my mobile density to dead density if interface not at all transmissive)
              if (v0(s,t) * neighbor_v0(s,t) >= 0.0_pReal) then                                     ! no sign change in flux density
                transmissivity = sum(compatibility(c,:,s,n,ip,el)**2.0_pReal)                       ! overall transmissivity from this slip system to my neighbor
              else                                                                                  ! sign change in flux density means sign change in stress which does not allow for dislocations to arive at the neighbor
                transmissivity = 0.0_pReal
              endif
              lineLength = my_rhoSgl0(s,t) * v0(s,t) &
                         * math_inner(m(1:3,s,t), normal_me2neighbor) * area                        ! positive line length of mobiles that wants to leave through this interface
              rhoDotFlux(s,t) = rhoDotFlux(s,t) - lineLength / IPvolume(ip,el)                      ! subtract dislocation flux from current type
              rhoDotFlux(s,t+4) = rhoDotFlux(s,t+4) &
                                + lineLength / IPvolume(ip,el) * (1.0_pReal - transmissivity) &
                                * sign(1.0_pReal, v0(s,t))                                          ! dislocation flux that is not able to leave through interface (because of low transmissivity) will remain as immobile single density at the material point
            endif
          enddo
        enddo
      endif; endif

    enddo neighbors
  endif



  !****************************************************************************
  !*** calculate dipole formation and annihilation

  !*** formation by glide
  do c = 1,2
    rhoDotSingle2DipoleGlide(:,2*c-1) = -2.0_pReal * dUpper(:,c) / prm%burgers &
                                                   * (      rhoSgl(:,2*c-1)  * abs(gdot(:,2*c)) &   ! negative mobile --> positive mobile
                                                      +     rhoSgl(:,2*c)    * abs(gdot(:,2*c-1)) & ! positive mobile --> negative mobile
                                                      + abs(rhoSgl(:,2*c+4)) * abs(gdot(:,2*c-1)))  ! positive mobile --> negative immobile

    rhoDotSingle2DipoleGlide(:,2*c) = -2.0_pReal * dUpper(:,c) / prm%burgers &
                                                 * (      rhoSgl(:,2*c-1)  * abs(gdot(:,2*c)) &     ! negative mobile --> positive mobile
                                                    +     rhoSgl(:,2*c)    * abs(gdot(:,2*c-1)) &   ! positive mobile --> negative mobile
                                                    + abs(rhoSgl(:,2*c+3)) * abs(gdot(:,2*c)))      ! negative mobile --> positive immobile

    rhoDotSingle2DipoleGlide(:,2*c+3) = -2.0_pReal * dUpper(:,c) / prm%burgers &
                                                   * rhoSgl(:,2*c+3) * abs(gdot(:,2*c))             ! negative mobile --> positive immobile

    rhoDotSingle2DipoleGlide(:,2*c+4) = -2.0_pReal * dUpper(:,c) / prm%burgers &
                                                   * rhoSgl(:,2*c+4) * abs(gdot(:,2*c-1))           ! positive mobile --> negative immobile

    rhoDotSingle2DipoleGlide(:,c+8) = abs(rhoDotSingle2DipoleGlide(:,2*c+3)) &
                                    + abs(rhoDotSingle2DipoleGlide(:,2*c+4)) &
                                    - rhoDotSingle2DipoleGlide(:,2*c-1) &
                                    - rhoDotSingle2DipoleGlide(:,2*c)
  enddo


  !*** athermal annihilation
  rhoDotAthermalAnnihilation = 0.0_pReal
  forall (c=1:2) &
    rhoDotAthermalAnnihilation(:,c+8) = -2.0_pReal * dLower(:,c) / prm%burgers &
       * (  2.0_pReal * (rhoSgl(:,2*c-1) * abs(gdot(:,2*c)) + rhoSgl(:,2*c) * abs(gdot(:,2*c-1))) &             ! was single hitting single
          + 2.0_pReal * (abs(rhoSgl(:,2*c+3)) * abs(gdot(:,2*c)) + abs(rhoSgl(:,2*c+4)) * abs(gdot(:,2*c-1))) & ! was single hitting immobile single or was immobile single hit by single
          + rhoDip(:,c) * (abs(gdot(:,2*c-1)) + abs(gdot(:,2*c))))                                              ! single knocks dipole constituent

  ! annihilated screw dipoles leave edge jogs behind on the colinear system
  if (lattice_structure(ph) == LATTICE_fcc_ID) &
    forall (s = 1:ns, prm%colinearSystem(s) > 0) &
      rhoDotAthermalAnnihilation(prm%colinearSystem(s),1:2) = - rhoDotAthermalAnnihilation(s,10) &
        * 0.25_pReal * sqrt(stt%rho_forest(s,of)) * (dUpper(s,2) + dLower(s,2)) * prm%edgeJogFactor


  !*** thermally activated annihilation of edge dipoles by climb
  rhoDotThermalAnnihilation = 0.0_pReal
  selfDiffusion = prm%Dsd0 * exp(-prm%selfDiffusionEnergy / (kB * Temperature))
  vClimb = prm%atomicVolume * selfDiffusion * prm%mu &
         / ( kB * Temperature  * PI * (1.0_pReal-prm%nu) * (dUpper(:,1) + dLower(:,1)))
  forall (s = 1:ns, dUpper(s,1) > dLower(s,1)) &
    rhoDotThermalAnnihilation(s,9) = max(- 4.0_pReal * rhoDip(s,1) * vClimb(s) / (dUpper(s,1) - dLower(s,1)), &
                                         - rhoDip(s,1) / timestep - rhoDotAthermalAnnihilation(s,9) &
                                                                  - rhoDotSingle2DipoleGlide(s,9))    ! make sure that we do not annihilate more dipoles than we have

  rhoDot = rhoDotFlux &
         + rhoDotMultiplication &
         + rhoDotSingle2DipoleGlide &
         + rhoDotAthermalAnnihilation &
         + rhoDotThermalAnnihilation

# 1325 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_nonlocal.f90"


  if (    any(rho(:,mob) + rhoDot(:,1:4)  * timestep < -prm%atol_rho) &
     .or. any(rho(:,dip) + rhoDot(:,9:10) * timestep < -prm%atol_rho)) then






    plasticState(ph)%dotState = IEEE_value(1.0_pReal,IEEE_quiet_NaN)
  else
    dot%rho(:,of) = pack(rhoDot,.true.)
    dot%gamma(:,of) = sum(gdot,2)
  endif

  end associate

end subroutine plastic_nonlocal_dotState


!--------------------------------------------------------------------------------------------------
!> @brief Compatibility update
!> @detail Compatibility is defined as normalized product of signed cosine of the angle between the slip
! plane normals and signed cosine of the angle between the slip directions. Only the largest values
! that sum up to a total of 1 are considered, all others are set to zero.
!--------------------------------------------------------------------------------------------------
module subroutine plastic_nonlocal_updateCompatibility(orientation,instance,i,e)

  type(rotation), dimension(1,discretization_nIP,discretization_nElem), intent(in) :: &
    orientation                                                                                     ! crystal orientation
  integer, intent(in) :: &
    instance, &
    i, &
    e

  integer :: &
    n, &                                                                                            ! neighbor index
    neighbor_e, &                                                                                   ! element index of my neighbor
    neighbor_i, &                                                                                   ! integration point index of my neighbor
    ph, &
    neighbor_phase, &
    ns, &                                                                                           ! number of active slip systems
    s1, &                                                                                           ! slip system index (me)
    s2                                                                                              ! slip system index (my neighbor)
  real(pReal), dimension(2,param(instance)%sum_N_sl,param(instance)%sum_N_sl,nIPneighbors) :: &
    my_compatibility                                                                                ! my_compatibility for current element and ip
  real(pReal) :: &
    my_compatibilitySum, &
    thresholdValue, &
    nThresholdValues
  logical, dimension(param(instance)%sum_N_sl) :: &
    belowThreshold
  type(rotation) :: mis

  ph = material_phaseAt(1,e)

  associate(prm => param(instance))
  ns = prm%sum_N_sl

  !*** start out fully compatible
  my_compatibility = 0.0_pReal
  forall(s1 = 1:ns) my_compatibility(:,s1,s1,:) = 1.0_pReal

  neighbors: do n = 1,nIPneighbors
    neighbor_e = IPneighborhood(1,n,i,e)
    neighbor_i = IPneighborhood(2,n,i,e)

    neighbor_phase = material_phaseAt(1,neighbor_e)

    if (neighbor_e <= 0 .or. neighbor_i <= 0) then
      !* FREE SURFACE
      !* Set surface transmissivity to the value specified in the material.config
      forall(s1 = 1:ns) my_compatibility(:,s1,s1,n) = sqrt(prm%surfaceTransmissivity)
    elseif (neighbor_phase /= ph) then
      !* PHASE BOUNDARY
      !* If we encounter a different nonlocal phase at the neighbor,
      !* we consider this to be a real "physical" phase boundary, so completely incompatible.
      !* If one of the two phases has a local plasticity law,
      !* we do not consider this to be a phase boundary, so completely compatible.
      if (.not. phase_localPlasticity(neighbor_phase) .and. .not. phase_localPlasticity(ph)) &
        forall(s1 = 1:ns) my_compatibility(:,s1,s1,n) = 0.0_pReal
    elseif (prm%grainboundaryTransmissivity >= 0.0_pReal) then
      !* GRAIN BOUNDARY !
      !* fixed transmissivity for adjacent ips with different texture (only if explicitly given in material.config)
      if (material_texture(1,i,e) /= material_texture(1,neighbor_i,neighbor_e) .and. &
          (.not. phase_localPlasticity(neighbor_phase))) &
        forall(s1 = 1:ns) my_compatibility(:,s1,s1,n) = sqrt(prm%grainboundaryTransmissivity)
    else
      !* GRAIN BOUNDARY ?
      !* Compatibility defined by relative orientation of slip systems:
      !* The my_compatibility value is defined as the product of the slip normal projection and the slip direction projection.
      !* Its sign is always positive for screws, for edges it has the same sign as the slip normal projection.
      !* Since the sum for each slip system can easily exceed one (which would result in a transmissivity larger than one),
      !* only values above or equal to a certain threshold value are considered. This threshold value is chosen, such that
      !* the number of compatible slip systems is minimized with the sum of the original compatibility values exceeding one.
      !* Finally the smallest compatibility value is decreased until the sum is exactly equal to one.
      !* All values below the threshold are set to zero.
      mis = orientation(1,i,e)%misorientation(orientation(1,neighbor_i,neighbor_e))
      mySlipSystems: do s1 = 1,ns
        neighborSlipSystems: do s2 = 1,ns
          my_compatibility(1,s2,s1,n) =     math_inner(prm%slip_normal(1:3,s1), &
                                                       mis%rotate(prm%slip_normal(1:3,s2))) &
                                      * abs(math_inner(prm%slip_direction(1:3,s1), &
                                                       mis%rotate(prm%slip_direction(1:3,s2))))
          my_compatibility(2,s2,s1,n) = abs(math_inner(prm%slip_normal(1:3,s1), &
                                                       mis%rotate(prm%slip_normal(1:3,s2)))) &
                                      * abs(math_inner(prm%slip_direction(1:3,s1), &
                                                       mis%rotate(prm%slip_direction(1:3,s2))))
        enddo neighborSlipSystems

        my_compatibilitySum = 0.0_pReal
        belowThreshold = .true.
        do while (my_compatibilitySum < 1.0_pReal .and. any(belowThreshold))
          thresholdValue = maxval(my_compatibility(2,:,s1,n), belowThreshold)                       ! screws always positive
          nThresholdValues = real(count(my_compatibility(2,:,s1,n) >= thresholdValue),pReal)
          where (my_compatibility(2,:,s1,n) >= thresholdValue) belowThreshold = .false.
          if (my_compatibilitySum + thresholdValue * nThresholdValues > 1.0_pReal) &
            where (abs(my_compatibility(:,:,s1,n)) >= thresholdValue) &
              my_compatibility(:,:,s1,n) = sign((1.0_pReal - my_compatibilitySum)/nThresholdValues,&
                                                 my_compatibility(:,:,s1,n))
          my_compatibilitySum = my_compatibilitySum + nThresholdValues * thresholdValue
        enddo

        where(belowThreshold) my_compatibility(1,:,s1,n) = 0.0_pReal
        where(belowThreshold) my_compatibility(2,:,s1,n) = 0.0_pReal

      enddo mySlipSystems
    endif

  enddo neighbors

  compatibility(:,:,:,:,i,e) = my_compatibility

  end associate

end subroutine plastic_nonlocal_updateCompatibility


!--------------------------------------------------------------------------------------------------
!> @brief writes results to HDF5 output file
!--------------------------------------------------------------------------------------------------
module subroutine plastic_nonlocal_results(instance,group)

  integer,         intent(in) :: instance
  character(len=*),intent(in) :: group

  integer :: o

  associate(prm => param(instance),dst => microstructure(instance),stt=>state(instance))
  outputsLoop: do o = 1,size(prm%output)
    select case(trim(prm%output(o)))
      case('rho_sgl_mob_edg_pos')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_sgl_mob_edg_pos, 'rho_sgl_mob_edg_pos', &
                                                     'positive mobile edge density','1/m²')
      case('rho_sgl_imm_edg_pos')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_sgl_imm_edg_pos, 'rho_sgl_imm_edg_pos',&
                                                     'positive immobile edge density','1/m²')
      case('rho_sgl_mob_edg_neg')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_sgl_mob_edg_neg, 'rho_sgl_mob_edg_neg',&
                                                     'negative mobile edge density','1/m²')
      case('rho_sgl_imm_edg_neg')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_sgl_imm_edg_neg, 'rho_sgl_imm_edg_neg',&
                                                     'negative immobile edge density','1/m²')
      case('rho_dip_edg')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_dip_edg, 'rho_dip_edg',&
                                                     'edge dipole density','1/m²')
      case('rho_sgl_mob_scr_pos')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_sgl_mob_scr_pos, 'rho_sgl_mob_scr_pos',&
                                                     'positive mobile screw density','1/m²')
      case('rho_sgl_imm_scr_pos')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_sgl_imm_scr_pos, 'rho_sgl_imm_scr_pos',&
                                                     'positive immobile screw density','1/m²')
      case('rho_sgl_mob_scr_neg')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_sgl_mob_scr_neg, 'rho_sgl_mob_scr_neg',&
                                                     'negative mobile screw density','1/m²')
      case('rho_sgl_imm_scr_neg')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_sgl_imm_scr_neg, 'rho_sgl_imm_scr_neg',&
                                                     'negative immobile screw density','1/m²')
      case('rho_dip_scr')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_dip_scr, 'rho_dip_scr',&
                                                     'screw dipole density','1/m²')
      case('rho_forest')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%rho_forest, 'rho_forest',&
                                                     'forest density','1/m²')
      case('v_edg_pos')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%v_edg_pos, 'v_edg_pos',&
                                                     'positive edge velocity','m/s')
      case('v_edg_neg')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%v_edg_neg, 'v_edg_neg',&
                                                     'negative edge velocity','m/s')
      case('v_scr_pos')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%v_scr_pos, 'v_scr_pos',&
                                                     'positive srew velocity','m/s')
      case('v_scr_neg')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%v_scr_neg, 'v_scr_neg',&
                                                     'negative screw velocity','m/s')
      case('gamma')
        if(prm%sum_N_sl>0) call results_writeDataset(group,stt%gamma,'gamma',&
                                                     'plastic shear','1')
      case('tau_pass')
        if(prm%sum_N_sl>0) call results_writeDataset(group,dst%tau_pass,'tau_pass',&
                                                     'passing stress for slip','Pa')
    end select
  enddo outputsLoop
  end associate

end subroutine plastic_nonlocal_results


!--------------------------------------------------------------------------------------------------
!> @brief populates the initial dislocation density
!--------------------------------------------------------------------------------------------------
subroutine stateInit(ini,phase,NipcMyPhase)

  type(tInitialParameters) :: &
    ini
  integer,intent(in) :: &
    phase, &
    NipcMyPhase
  integer :: &
    e, &
    i, &
    f, &
    from, &
    upto, &
    s, &
    instance, &
    phasemember
  real(pReal), dimension(2) :: &
    noise, &
    rnd
  real(pReal) :: &
    meanDensity, &
    totalVolume, &
    densityBinning, &
    minimumIpVolume
  real(pReal), dimension(NipcMyPhase) :: &
    volume

  instance = phase_plasticityInstance(phase)
  associate(stt => state(instance))

  if (ini%rhoSglRandom > 0.0_pReal) then ! randomly distribute dislocation segments on random slip system and of random type in the volume
    do e = 1,discretization_nElem
      do i = 1,discretization_nIP
        if (material_phaseAt(1,e) == phase) volume(material_phasememberAt(1,i,e)) = IPvolume(i,e)
      enddo
    enddo
    totalVolume     = sum(volume)
    minimumIPVolume = minval(volume)
    densityBinning  = ini%rhoSglRandomBinning / minimumIpVolume ** (2.0_pReal / 3.0_pReal)

    ! fill random material points with dislocation segments until the desired overall density is reached
    meanDensity = 0.0_pReal
    do while(meanDensity < ini%rhoSglRandom)
      call random_number(rnd)
      phasemember = nint(rnd(1)*real(NipcMyPhase,pReal) + 0.5_pReal)
      s           = nint(rnd(2)*real(sum(ini%N_sl),pReal)*4.0_pReal + 0.5_pReal)
      meanDensity = meanDensity + densityBinning * volume(phasemember) / totalVolume
      stt%rhoSglMobile(s,phasemember) = densityBinning
    enddo
  else                                ! homogeneous distribution with noise
    do e = 1, NipcMyPhase
      do f = 1,size(ini%N_sl,1)
        from = 1 + sum(ini%N_sl(1:f-1))
        upto = sum(ini%N_sl(1:f))
        do s = from,upto
          noise = [math_sampleGaussVar(0.0_pReal, ini%rhoSglScatter), &
                   math_sampleGaussVar(0.0_pReal, ini%rhoSglScatter)]
          stt%rho_sgl_mob_edg_pos(s,e) = ini%rhoSglEdgePos0(f)  + noise(1)
          stt%rho_sgl_mob_edg_neg(s,e) = ini%rhoSglEdgeNeg0(f)  + noise(1)
          stt%rho_sgl_mob_scr_pos(s,e) = ini%rhoSglScrewPos0(f) + noise(2)
          stt%rho_sgl_mob_scr_neg(s,e) = ini%rhoSglScrewNeg0(f) + noise(2)
        enddo
        stt%rho_dip_edg(from:upto,e)   = ini%rhoDipEdge0(f)
        stt%rho_dip_scr(from:upto,e)   = ini%rhoDipScrew0(f)
      enddo
    enddo
  endif

  end associate

end subroutine stateInit


!--------------------------------------------------------------------------------------------------
!> @brief calculates kinetics
!--------------------------------------------------------------------------------------------------
subroutine kinetics(v, dv_dtau, dv_dtauNS, tau, tauNS, tauThreshold, c, Temperature, instance)

  integer, intent(in) :: &
    c, &                                                                                            !< dislocation character (1:edge, 2:screw)
    instance
  real(pReal), intent(in) :: &
    Temperature                                                                                     !< temperature
  real(pReal), dimension(param(instance)%sum_N_sl), intent(in) :: &
    tau, &                                                                                          !< resolved external shear stress (without non Schmid effects)
    tauNS, &                                                                                        !< resolved external shear stress (including non Schmid effects)
    tauThreshold                                                                                    !< threshold shear stress
  real(pReal), dimension(param(instance)%sum_N_sl), intent(out) ::  &
    v, &                                                                                            !< velocity
    dv_dtau, &                                                                                      !< velocity derivative with respect to resolved shear stress (without non Schmid contributions)
    dv_dtauNS                                                                                       !< velocity derivative with respect to resolved shear stress (including non Schmid contributions)

  integer :: &
    ns, &                                                                                           !< short notation for the total number of active slip systems
    s                                                                                               !< index of my current slip system
  real(pReal) :: &
    tauRel_P, &
    tauRel_S, &
    tauEff, &                                                                                       !< effective shear stress
    tPeierls, &                                                                                     !< waiting time in front of a peierls barriers
    tSolidSolution, &                                                                               !< waiting time in front of a solid solution obstacle
    vViscous, &                                                                                     !< viscous glide velocity
    dtPeierls_dtau, &                                                                               !< derivative with respect to resolved shear stress
    dtSolidSolution_dtau, &                                                                         !< derivative with respect to resolved shear stress
    meanfreepath_S, &                                                                               !< mean free travel distance for dislocations between two solid solution obstacles
    meanfreepath_P, &                                                                               !< mean free travel distance for dislocations between two Peierls barriers
    jumpWidth_P, &                                                                                  !< depth of activated area
    jumpWidth_S, &                                                                                  !< depth of activated area
    activationLength_P, &                                                                           !< length of activated dislocation line
    activationLength_S, &                                                                           !< length of activated dislocation line
    activationVolume_P, &                                                                           !< volume that needs to be activated to overcome barrier
    activationVolume_S, &                                                                           !< volume that needs to be activated to overcome barrier
    activationEnergy_P, &                                                                           !< energy that is needed to overcome barrier
    activationEnergy_S, &                                                                           !< energy that is needed to overcome barrier
    criticalStress_P, &                                                                             !< maximum obstacle strength
    criticalStress_S, &                                                                             !< maximum obstacle strength
    mobility                                                                                        !< dislocation mobility

  associate(prm => param(instance))
  ns = prm%sum_N_sl
  v = 0.0_pReal
  dv_dtau = 0.0_pReal
  dv_dtauNS = 0.0_pReal

  do s = 1,ns
    if (abs(tau(s)) > tauThreshold(s)) then

      !* Peierls contribution
      !* Effective stress includes non Schmid constributions
      !* The derivative only gives absolute values; the correct sign is taken care of in the formula for the derivative of the velocity
      tauEff = max(0.0_pReal, abs(tauNS(s)) - tauThreshold(s))                                      ! ensure that the effective stress is positive
      meanfreepath_P = prm%burgers(s)
      jumpWidth_P = prm%burgers(s)
      activationLength_P = prm%doublekinkwidth *prm%burgers(s)
      activationVolume_P = activationLength_P * jumpWidth_P * prm%burgers(s)
      criticalStress_P = prm%peierlsStress(s,c)
      activationEnergy_P = criticalStress_P * activationVolume_P
      tauRel_P = min(1.0_pReal, tauEff / criticalStress_P)                                          ! ensure that the activation probability cannot become greater than one
      tPeierls = 1.0_pReal / prm%fattack &
               * exp(activationEnergy_P / (kB * Temperature) &
                     * (1.0_pReal - tauRel_P**prm%p)**prm%q)
      if (tauEff < criticalStress_P) then
        dtPeierls_dtau = tPeierls * prm%p * prm%q * activationVolume_P / (kB * Temperature) &
                       * (1.0_pReal - tauRel_P**prm%p)**(prm%q-1.0_pReal) * tauRel_P**(prm%p-1.0_pReal)
      else
        dtPeierls_dtau = 0.0_pReal
      endif

      !* Contribution from solid solution strengthening
      !* The derivative only gives absolute values; the correct sign is taken care of in the formula for the derivative of the velocity
      tauEff = abs(tau(s)) - tauThreshold(s)
      meanfreepath_S = prm%burgers(s) / sqrt(prm%solidSolutionConcentration)
      jumpWidth_S = prm%solidSolutionSize * prm%burgers(s)
      activationLength_S = prm%burgers(s) / sqrt(prm%solidSolutionConcentration)
      activationVolume_S = activationLength_S * jumpWidth_S * prm%burgers(s)
      activationEnergy_S = prm%solidSolutionEnergy
      criticalStress_S = activationEnergy_S / activationVolume_S
      tauRel_S = min(1.0_pReal, tauEff / criticalStress_S)                                          ! ensure that the activation probability cannot become greater than one
      tSolidSolution = 1.0_pReal /  prm%fattack &
                     * exp(activationEnergy_S / (kB * Temperature)* (1.0_pReal - tauRel_S**prm%p)**prm%q)
      if (tauEff < criticalStress_S) then
        dtSolidSolution_dtau = tSolidSolution * prm%p * prm%q * activationVolume_S / (kB * Temperature) &
                             * (1.0_pReal - tauRel_S**prm%p)**(prm%q-1.0_pReal)* tauRel_S**(prm%p-1.0_pReal)
      else
        dtSolidSolution_dtau = 0.0_pReal
      endif

      !* viscous glide velocity
      tauEff = abs(tau(s)) - tauThreshold(s)
      mobility = prm%burgers(s) / prm%viscosity
      vViscous = mobility * tauEff

      !* Mean velocity results from waiting time at peierls barriers and solid solution obstacles with respective meanfreepath of
      !* free flight at glide velocity in between.
      !* adopt sign from resolved stress
      v(s) = sign(1.0_pReal,tau(s)) &
           / (tPeierls / meanfreepath_P + tSolidSolution / meanfreepath_S + 1.0_pReal / vViscous)
      dv_dtau(s)   = v(s)**2.0_pReal * (dtSolidSolution_dtau / meanfreepath_S + mobility /vViscous**2.0_pReal)
      dv_dtauNS(s) = v(s)**2.0_pReal * dtPeierls_dtau / meanfreepath_P
    endif
  enddo

  end associate

end subroutine kinetics


!--------------------------------------------------------------------------------------------------
!> @brief returns copy of current dislocation densities from state
!> @details raw values is rectified
!--------------------------------------------------------------------------------------------------
function getRho(instance,of,ip,el)

  integer, intent(in) :: instance, of,ip,el
  real(pReal), dimension(param(instance)%sum_N_sl,10) :: getRho

  associate(prm => param(instance))

  getRho = reshape(state(instance)%rho(:,of),[prm%sum_N_sl,10])

  ! ensure positive densities (not for imm, they have a sign)
  getRho(:,mob) = max(getRho(:,mob),0.0_pReal)
  getRho(:,dip) = max(getRho(:,dip),0.0_pReal)

  where(abs(getRho) < max(prm%significantN/IPvolume(ip,el)**(2.0_pReal/3.0_pReal),prm%significantRho)) &
    getRho = 0.0_pReal

  end associate

end function getRho


!--------------------------------------------------------------------------------------------------
!> @brief returns copy of current dislocation densities from state
!> @details raw values is rectified
!--------------------------------------------------------------------------------------------------
function getRho0(instance,of,ip,el)

  integer, intent(in) :: instance, of,ip,el
  real(pReal), dimension(param(instance)%sum_N_sl,10) :: getRho0

  associate(prm => param(instance))

  getRho0 = reshape(state0(instance)%rho(:,of),[prm%sum_N_sl,10])

  ! ensure positive densities (not for imm, they have a sign)
  getRho0(:,mob) = max(getRho0(:,mob),0.0_pReal)
  getRho0(:,dip) = max(getRho0(:,dip),0.0_pReal)

  where(abs(getRho0) < max(prm%significantN/IPvolume(ip,el)**(2.0_pReal/3.0_pReal),prm%significantRho)) &
    getRho0 = 0.0_pReal

  end associate

end function getRho0

end submodule plastic_nonlocal
# 44 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2

# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/crystallite.f90" 1
!--------------------------------------------------------------------------------------------------
!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH
!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH
!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH
!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH
!> @author Christoph Kords, Max-Planck-Institut für Eisenforschung GmbH
!> @author Chen Zhang, Michigan State University
!> @brief crystallite state integration functions and reporting of results
!--------------------------------------------------------------------------------------------------

module crystallite
  use prec
  use IO
  use HDF5_utilities
  use DAMASK_interface
  use config
  use debug
  use numerics
  use rotations
  use math
  use FEsolving
  use material
  use constitutive
  use discretization
  use lattice
  use results

  implicit none
  private

  real(pReal),               dimension(:,:,:),        allocatable, public :: &
    crystallite_dt                                                                                  !< requested time increment of each grain
  real(pReal),               dimension(:,:,:),        allocatable :: &
    crystallite_subdt, &                                                                            !< substepped time increment of each grain
    crystallite_subFrac, &                                                                          !< already calculated fraction of increment
    crystallite_subStep                                                                             !< size of next integration step
  type(rotation),            dimension(:,:,:),        allocatable :: &
    crystallite_orientation                                                                         !< current orientation
  real(pReal),               dimension(:,:,:,:,:),    allocatable, public, protected :: &
    crystallite_Fe, &                                                                               !< current "elastic" def grad (end of converged time step)
    crystallite_P, &                                                                                !< 1st Piola-Kirchhoff stress per grain
    crystallite_S0, &                                                                               !< 2nd Piola-Kirchhoff stress vector at start of FE inc
    crystallite_Fp0, &                                                                              !< plastic def grad at start of FE inc
    crystallite_Fi0, &                                                                              !< intermediate def grad at start of FE inc
    crystallite_F0, &                                                                               !< def grad at start of FE inc
    crystallite_Lp0, &                                                                              !< plastic velocitiy grad at start of FE inc
    crystallite_Li0                                                                                 !< intermediate velocitiy grad at start of FE inc
  real(pReal),               dimension(:,:,:,:,:),    allocatable, public :: &
    crystallite_S, &                                                                                !< current 2nd Piola-Kirchhoff stress vector (end of converged time step)
    crystallite_partionedS0, &                                                                      !< 2nd Piola-Kirchhoff stress vector at start of homog inc
    crystallite_Fp, &                                                                               !< current plastic def grad (end of converged time step)
    crystallite_partionedFp0,&                                                                      !< plastic def grad at start of homog inc
    crystallite_Fi, &                                                                               !< current intermediate def grad (end of converged time step)
    crystallite_partionedFi0,&                                                                      !< intermediate def grad at start of homog inc
    crystallite_partionedF,  &                                                                      !< def grad to be reached at end of homog inc
    crystallite_partionedF0, &                                                                      !< def grad at start of homog inc
    crystallite_Lp, &                                                                               !< current plastic velocitiy grad (end of converged time step)
    crystallite_partionedLp0, &                                                                     !< plastic velocity grad at start of homog inc
    crystallite_Li, &                                                                               !< current intermediate velocitiy grad (end of converged time step)
    crystallite_partionedLi0                                                                        !< intermediate velocity grad at start of homog inc
  real(pReal),                dimension(:,:,:,:,:),    allocatable :: &
    crystallite_subFp0,&                                                                            !< plastic def grad at start of crystallite inc
    crystallite_subFi0,&                                                                            !< intermediate def grad at start of crystallite inc
    crystallite_subF,  &                                                                            !< def grad to be reached at end of crystallite inc
    crystallite_subF0, &                                                                            !< def grad at start of crystallite inc
    crystallite_subLp0,&                                                                            !< plastic velocity grad at start of crystallite inc
    crystallite_subLi0                                                                              !< intermediate velocity grad at start of crystallite inc
  real(pReal),                dimension(:,:,:,:,:,:,:), allocatable, public, protected :: &
    crystallite_dPdF                                                                                !< current individual dPdF per grain (end of converged time step)
  logical,                    dimension(:,:,:),         allocatable, public :: &
    crystallite_requested                                                                           !< used by upper level (homogenization) to request crystallite calculation
  logical,                    dimension(:,:,:),         allocatable :: &
    crystallite_converged, &                                                                        !< convergence flag
    crystallite_todo, &                                                                             !< flag to indicate need for further computation
    crystallite_localPlasticity                                                                     !< indicates this grain to have purely local constitutive law

  type :: tOutput                                                                                   !< new requested output (per phase)
    character(len=pStringLen), allocatable, dimension(:) :: &
      label
  end type tOutput
  type(tOutput), allocatable, dimension(:) :: output_constituent

  type :: tNumerics
    integer :: &
      iJacoLpresiduum, &                                                                            !< frequency of Jacobian update of residuum in Lp
      nState, &                                                                                     !< state loop limit
      nStress                                                                                       !< stress loop limit
    real(pReal) :: &
      subStepMinCryst, &                                                                            !< minimum (relative) size of sub-step allowed during cutback
      subStepSizeCryst, &                                                                           !< size of first substep when cutback
      subStepSizeLp, &                                                                              !< size of first substep when cutback in Lp calculation
      subStepSizeLi, &                                                                              !< size of first substep when cutback in Li calculation
      stepIncreaseCryst, &                                                                          !< increase of next substep size when previous substep converged
      rtol_crystalliteState, &                                                                      !< relative tolerance in state loop
      rtol_crystalliteStress, &                                                                     !< relative tolerance in stress loop
      atol_crystalliteStress                                                                        !< absolute tolerance in stress loop
  end type tNumerics

  type(tNumerics) :: num                                                                            ! numerics parameters. Better name?

  procedure(), pointer :: integrateState

  public :: &
    crystallite_init, &
    crystallite_stress, &
    crystallite_stressTangent, &
    crystallite_orientations, &
    crystallite_push33ToRef, &
    crystallite_results, &
    crystallite_restartWrite, &
    crystallite_restartRead, &
    crystallite_forward

contains


!--------------------------------------------------------------------------------------------------
!> @brief allocates and initialize per grain variables
!--------------------------------------------------------------------------------------------------
subroutine crystallite_init

  logical, dimension(discretization_nIP,discretization_nElem) :: devNull
  integer :: &
    c, &                                                                                            !< counter in integration point component loop
    i, &                                                                                            !< counter in integration point loop
    e, &                                                                                            !< counter in element loop
    cMax, &                                                                                         !< maximum number of  integration point components
    iMax, &                                                                                         !< maximum number of integration points
    eMax, &                                                                                         !< maximum number of elements
    myNcomponents                                                                                   !< number of components at current IP

  write(6,'(/,a)')   ' <<<+-  crystallite init  -+>>>'

  cMax = homogenization_maxNgrains
  iMax = discretization_nIP
  eMax = discretization_nElem

  allocate(crystallite_partionedF(3,3,cMax,iMax,eMax),source=0.0_pReal)

  allocate(crystallite_S0, &
           crystallite_F0, crystallite_Fi0,crystallite_Fp0, &
                           crystallite_Li0,crystallite_Lp0, &
           crystallite_partionedS0, &
           crystallite_partionedF0,crystallite_partionedFp0,crystallite_partionedFi0, &
                                   crystallite_partionedLp0,crystallite_partionedLi0, &
           crystallite_S,crystallite_P, &
           crystallite_Fe,crystallite_Fi,crystallite_Fp, &
                          crystallite_Li,crystallite_Lp, &
           crystallite_subF,crystallite_subF0, &
           crystallite_subFp0,crystallite_subFi0, &
           crystallite_subLi0,crystallite_subLp0, &
           source = crystallite_partionedF)

  allocate(crystallite_dPdF(3,3,3,3,cMax,iMax,eMax),source=0.0_pReal)

  allocate(crystallite_dt(cMax,iMax,eMax),source=0.0_pReal)
  allocate(crystallite_subdt,crystallite_subFrac,crystallite_subStep, &
           source = crystallite_dt)

  allocate(crystallite_orientation(cMax,iMax,eMax))

  allocate(crystallite_localPlasticity(cMax,iMax,eMax),       source=.true.)
  allocate(crystallite_requested(cMax,iMax,eMax),             source=.false.)
  allocate(crystallite_todo(cMax,iMax,eMax),                  source=.false.)
  allocate(crystallite_converged(cMax,iMax,eMax),             source=.true.)

  num%subStepMinCryst        = config_numerics%getFloat('substepmincryst',       defaultVal=1.0e-3_pReal)
  num%subStepSizeCryst       = config_numerics%getFloat('substepsizecryst',      defaultVal=0.25_pReal)
  num%stepIncreaseCryst      = config_numerics%getFloat('stepincreasecryst',     defaultVal=1.5_pReal)

  num%subStepSizeLp          = config_numerics%getFloat('substepsizelp',         defaultVal=0.5_pReal)
  num%subStepSizeLi          = config_numerics%getFloat('substepsizeli',         defaultVal=0.5_pReal)

  num%rtol_crystalliteState  = config_numerics%getFloat('rtol_crystallitestate', defaultVal=1.0e-6_pReal)
  num%rtol_crystalliteStress = config_numerics%getFloat('rtol_crystallitestress',defaultVal=1.0e-6_pReal)
  num%atol_crystalliteStress = config_numerics%getFloat('atol_crystallitestress',defaultVal=1.0e-8_pReal)

  num%iJacoLpresiduum        = config_numerics%getInt  ('ijacolpresiduum',       defaultVal=1)

  num%nState                 = config_numerics%getInt  ('nstate',                defaultVal=20)
  num%nStress                = config_numerics%getInt  ('nstress',               defaultVal=40)

  if(num%subStepMinCryst   <= 0.0_pReal)      call IO_error(301,ext_msg='subStepMinCryst')
  if(num%subStepSizeCryst  <= 0.0_pReal)      call IO_error(301,ext_msg='subStepSizeCryst')
  if(num%stepIncreaseCryst <= 0.0_pReal)      call IO_error(301,ext_msg='stepIncreaseCryst')

  if(num%subStepSizeLp <= 0.0_pReal)          call IO_error(301,ext_msg='subStepSizeLp')
  if(num%subStepSizeLi <= 0.0_pReal)          call IO_error(301,ext_msg='subStepSizeLi')

  if(num%rtol_crystalliteState  <= 0.0_pReal) call IO_error(301,ext_msg='rtol_crystalliteState')
  if(num%rtol_crystalliteStress <= 0.0_pReal) call IO_error(301,ext_msg='rtol_crystalliteStress')
  if(num%atol_crystalliteStress <= 0.0_pReal) call IO_error(301,ext_msg='atol_crystalliteStress')

  if(num%iJacoLpresiduum < 1)                 call IO_error(301,ext_msg='iJacoLpresiduum')

  if(num%nState < 1)                          call IO_error(301,ext_msg='nState')
  if(num%nStress< 1)                          call IO_error(301,ext_msg='nStress')

  select case(numerics_integrator)
    case(1)
      integrateState => integrateStateFPI
    case(2)
      integrateState => integrateStateEuler
    case(3)
      integrateState => integrateStateAdaptiveEuler
    case(4)
      integrateState => integrateStateRK4
    case(5)
      integrateState => integrateStateRKCK45
  end select

  allocate(output_constituent(size(config_phase)))
  do c = 1, size(config_phase)

    allocate(output_constituent(c)%label(1))
    output_constituent(c)%label(1)= 'GfortranBug86277'
    output_constituent(c)%label  = config_phase(c)%getStrings('(output)',defaultVal=output_constituent(c)%label )
    if (output_constituent(c)%label (1) == 'GfortranBug86277') output_constituent(c)%label  = [character(len=pStringLen)::]



  enddo

  call config_deallocate('material.config/phase')

!--------------------------------------------------------------------------------------------------
! initialize
 !$OMP PARALLEL DO PRIVATE(myNcomponents,i,c)
  do e = FEsolving_execElem(1),FEsolving_execElem(2)
    myNcomponents = homogenization_Ngrains(material_homogenizationAt(e))
    do i = FEsolving_execIP(1), FEsolving_execIP(2); do c = 1, myNcomponents
      crystallite_Fp0(1:3,1:3,c,i,e) = material_orientation0(c,i,e)%asMatrix()                      ! plastic def gradient reflects init orientation
      crystallite_Fp0(1:3,1:3,c,i,e) = crystallite_Fp0(1:3,1:3,c,i,e) &
                                     / math_det33(crystallite_Fp0(1:3,1:3,c,i,e))**(1.0_pReal/3.0_pReal)
      crystallite_Fi0(1:3,1:3,c,i,e) = constitutive_initialFi(c,i,e)
      crystallite_F0(1:3,1:3,c,i,e)  = math_I3
      crystallite_localPlasticity(c,i,e) = phase_localPlasticity(material_phaseAt(c,e))
      crystallite_Fe(1:3,1:3,c,i,e)  = math_inv33(matmul(crystallite_Fi0(1:3,1:3,c,i,e), &
                                                         crystallite_Fp0(1:3,1:3,c,i,e)))           ! assuming that euler angles are given in internal strain free configuration
      crystallite_Fp(1:3,1:3,c,i,e)  = crystallite_Fp0(1:3,1:3,c,i,e)
      crystallite_Fi(1:3,1:3,c,i,e)  = crystallite_Fi0(1:3,1:3,c,i,e)
      crystallite_requested(c,i,e) = .true.
    enddo; enddo
  enddo
  !$OMP END PARALLEL DO

  if(any(.not. crystallite_localPlasticity) .and. .not. usePingPong) call IO_error(601)             ! exit if nonlocal but no ping-pong ToDo: Why not check earlier? or in nonlocal?

  crystallite_partionedFp0 = crystallite_Fp0
  crystallite_partionedFi0 = crystallite_Fi0
  crystallite_partionedF0  = crystallite_F0
  crystallite_partionedF   = crystallite_F0

  call crystallite_orientations()

  !$OMP PARALLEL DO
  do e = FEsolving_execElem(1),FEsolving_execElem(2)
    do i = FEsolving_execIP(1),FEsolving_execIP(2)
      do c = 1,homogenization_Ngrains(material_homogenizationAt(e))
        call constitutive_dependentState(crystallite_partionedF0(1:3,1:3,c,i,e), &
                                         crystallite_partionedFp0(1:3,1:3,c,i,e), &
                                         c,i,e)                                                     ! update dependent state variables to be consistent with basic states
     enddo
    enddo
  enddo
  !$OMP END PARALLEL DO

  devNull = crystallite_stress()
  call crystallite_stressTangent

# 283 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/crystallite.f90"

end subroutine crystallite_init


!--------------------------------------------------------------------------------------------------
!> @brief calculate stress (P)
!--------------------------------------------------------------------------------------------------
function crystallite_stress(dummyArgumentToPreventInternalCompilerErrorWithGCC)

  logical, dimension(discretization_nIP,discretization_nElem) :: crystallite_stress
  real(pReal), intent(in), optional :: &
    dummyArgumentToPreventInternalCompilerErrorWithGCC
  real(pReal) :: &
    formerSubStep
  integer :: &
    NiterationCrystallite, &                                                                        ! number of iterations in crystallite loop
    c, &                                                                                            !< counter in integration point component loop
    i, &                                                                                            !< counter in integration point loop
    e, &                                                                                            !< counter in element loop
    startIP, endIP, &
    s

# 325 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/crystallite.f90"

!--------------------------------------------------------------------------------------------------
! initialize to starting condition
  crystallite_subStep = 0.0_pReal
  !$OMP PARALLEL DO
  elementLooping1: do e = FEsolving_execElem(1),FEsolving_execElem(2)
    do i = FEsolving_execIP(1),FEsolving_execIP(2); do c = 1,homogenization_Ngrains(material_homogenizationAt(e))
      homogenizationRequestsCalculation: if (crystallite_requested(c,i,e)) then
        plasticState    (material_phaseAt(c,e))%subState0(      :,material_phaseMemberAt(c,i,e)) = &
        plasticState    (material_phaseAt(c,e))%partionedState0(:,material_phaseMemberAt(c,i,e))

        do s = 1, phase_Nsources(material_phaseAt(c,e))
          sourceState(material_phaseAt(c,e))%p(s)%subState0(      :,material_phaseMemberAt(c,i,e)) = &
          sourceState(material_phaseAt(c,e))%p(s)%partionedState0(:,material_phaseMemberAt(c,i,e))
        enddo
        crystallite_subFp0(1:3,1:3,c,i,e) = crystallite_partionedFp0(1:3,1:3,c,i,e)
        crystallite_subLp0(1:3,1:3,c,i,e) = crystallite_partionedLp0(1:3,1:3,c,i,e)
        crystallite_subFi0(1:3,1:3,c,i,e) = crystallite_partionedFi0(1:3,1:3,c,i,e)
        crystallite_subLi0(1:3,1:3,c,i,e) = crystallite_partionedLi0(1:3,1:3,c,i,e)
        crystallite_subF0(1:3,1:3,c,i,e)  = crystallite_partionedF0(1:3,1:3,c,i,e)
        crystallite_subFrac(c,i,e) = 0.0_pReal
        crystallite_subStep(c,i,e) = 1.0_pReal/num%subStepSizeCryst
        crystallite_todo(c,i,e) = .true.
        crystallite_converged(c,i,e) = .false.                                                      ! pretend failed step of 1/subStepSizeCryst
      endif homogenizationRequestsCalculation
    enddo; enddo
  enddo elementLooping1
  !$OMP END PARALLEL DO

  singleRun: if (FEsolving_execELem(1) == FEsolving_execElem(2) .and. &
                 FEsolving_execIP  (1) == FEsolving_execIP  (2)) then
    startIP = FEsolving_execIP(1)
    endIP   = startIP
  else singleRun
    startIP = 1
    endIP   = discretization_nIP
  endif singleRun

  NiterationCrystallite = 0
  cutbackLooping: do while (any(crystallite_todo(:,startIP:endIP,FEsolving_execELem(1):FEsolving_execElem(2))))
    NiterationCrystallite = NiterationCrystallite + 1





    !$OMP PARALLEL DO PRIVATE(formerSubStep)
    elementLooping3: do e = FEsolving_execElem(1),FEsolving_execElem(2)
      do i = FEsolving_execIP(1),FEsolving_execIP(2)
        do c = 1,homogenization_Ngrains(material_homogenizationAt(e))
!--------------------------------------------------------------------------------------------------
!  wind forward
          if (crystallite_converged(c,i,e)) then
            formerSubStep = crystallite_subStep(c,i,e)
            crystallite_subFrac(c,i,e) = crystallite_subFrac(c,i,e) + crystallite_subStep(c,i,e)
            crystallite_subStep(c,i,e) = min(1.0_pReal - crystallite_subFrac(c,i,e), &
                                             num%stepIncreaseCryst * crystallite_subStep(c,i,e))

            crystallite_todo(c,i,e) = crystallite_subStep(c,i,e) > 0.0_pReal                        ! still time left to integrate on?
            if (crystallite_todo(c,i,e)) then
              crystallite_subF0 (1:3,1:3,c,i,e) = crystallite_subF(1:3,1:3,c,i,e)
              crystallite_subLp0(1:3,1:3,c,i,e) = crystallite_Lp  (1:3,1:3,c,i,e)
              crystallite_subLi0(1:3,1:3,c,i,e) = crystallite_Li  (1:3,1:3,c,i,e)
              crystallite_subFp0(1:3,1:3,c,i,e) = crystallite_Fp  (1:3,1:3,c,i,e)
              crystallite_subFi0(1:3,1:3,c,i,e) = crystallite_Fi  (1:3,1:3,c,i,e)
              !if abbrevation, make c and p private in omp
              plasticState(    material_phaseAt(c,e))%subState0(:,material_phaseMemberAt(c,i,e)) &
                = plasticState(material_phaseAt(c,e))%state(    :,material_phaseMemberAt(c,i,e))
              do s = 1, phase_Nsources(material_phaseAt(c,e))
                sourceState(    material_phaseAt(c,e))%p(s)%subState0(:,material_phaseMemberAt(c,i,e)) &
                  = sourceState(material_phaseAt(c,e))%p(s)%state(    :,material_phaseMemberAt(c,i,e))
              enddo
            endif

!--------------------------------------------------------------------------------------------------
!  cut back (reduced time and restore)
          else
            crystallite_subStep(c,i,e)       = num%subStepSizeCryst * crystallite_subStep(c,i,e)
            crystallite_Fp   (1:3,1:3,c,i,e) =            crystallite_subFp0(1:3,1:3,c,i,e)
            crystallite_Fi   (1:3,1:3,c,i,e) =            crystallite_subFi0(1:3,1:3,c,i,e)
            crystallite_S    (1:3,1:3,c,i,e) =            crystallite_S0    (1:3,1:3,c,i,e)
            if (crystallite_subStep(c,i,e) < 1.0_pReal) then                                        ! actual (not initial) cutback
              crystallite_Lp (1:3,1:3,c,i,e) =            crystallite_subLp0(1:3,1:3,c,i,e)
              crystallite_Li (1:3,1:3,c,i,e) =            crystallite_subLi0(1:3,1:3,c,i,e)
            endif
            plasticState    (material_phaseAt(c,e))%state(    :,material_phaseMemberAt(c,i,e)) &
              = plasticState(material_phaseAt(c,e))%subState0(:,material_phaseMemberAt(c,i,e))
            do s = 1, phase_Nsources(material_phaseAt(c,e))
              sourceState(    material_phaseAt(c,e))%p(s)%state(    :,material_phaseMemberAt(c,i,e)) &
                = sourceState(material_phaseAt(c,e))%p(s)%subState0(:,material_phaseMemberAt(c,i,e))
            enddo

                                                                                                    ! cant restore dotState here, since not yet calculated in first cutback after initialization
            crystallite_todo(c,i,e) = crystallite_subStep(c,i,e) > num%subStepMinCryst              ! still on track or already done (beyond repair)
          endif

!--------------------------------------------------------------------------------------------------
!  prepare for integration
          if (crystallite_todo(c,i,e)) then
            crystallite_subF(1:3,1:3,c,i,e) = crystallite_subF0(1:3,1:3,c,i,e) &
                                            + crystallite_subStep(c,i,e) *( crystallite_partionedF (1:3,1:3,c,i,e) &
                                                                           -crystallite_partionedF0(1:3,1:3,c,i,e))
            crystallite_Fe(1:3,1:3,c,i,e) = matmul(matmul(crystallite_subF(1:3,1:3,c,i,e), &
                                                          math_inv33(crystallite_Fp(1:3,1:3,c,i,e))), &
                                                   math_inv33(crystallite_Fi(1:3,1:3,c,i,e)))
            crystallite_subdt(c,i,e) = crystallite_subStep(c,i,e) * crystallite_dt(c,i,e)
            crystallite_converged(c,i,e) = .false.
          endif

        enddo
      enddo
    enddo elementLooping3
    !$OMP END PARALLEL DO

!--------------------------------------------------------------------------------------------------
!  integrate --- requires fully defined state array (basic + dependent state)
    if (any(crystallite_todo)) call integrateState                                                  ! TODO: unroll into proper elementloop to avoid N^2 for single point evaluation
    where(.not. crystallite_converged .and. crystallite_subStep > num%subStepMinCryst) &            ! do not try non-converged but fully cutbacked any further
      crystallite_todo = .true.                                                                     ! TODO: again unroll this into proper elementloop to avoid N^2 for single point evaluation


  enddo cutbackLooping

! return whether converged or not
  crystallite_stress = .false.
  elementLooping5: do e = FEsolving_execElem(1),FEsolving_execElem(2)
    do i = FEsolving_execIP(1),FEsolving_execIP(2)
      crystallite_stress(i,e) = all(crystallite_converged(:,i,e))
    enddo
  enddo elementLooping5

end function crystallite_stress


!--------------------------------------------------------------------------------------------------
!> @brief calculate tangent (dPdF)
!--------------------------------------------------------------------------------------------------
subroutine crystallite_stressTangent

  integer :: &
    c, &                                                                                            !< counter in integration point component loop
    i, &                                                                                            !< counter in integration point loop
    e, &                                                                                            !< counter in element loop
    o, &
    p

  real(pReal), dimension(3,3)     ::   devNull, &
                                       invSubFp0,invSubFi0,invFp,invFi, &
                                       temp_33_1, temp_33_2, temp_33_3, temp_33_4
  real(pReal), dimension(3,3,3,3) ::   dSdFe, &
                                       dSdF, &
                                       dSdFi, &
                                       dLidS, &                                                     ! tangent in lattice configuration
                                       dLidFi, &
                                       dLpdS, &
                                       dLpdFi, &
                                       dFidS, &
                                       dFpinvdF, &
                                       rhs_3333, &
                                       lhs_3333, &
                                       temp_3333
  real(pReal), dimension(9,9)::        temp_99
  logical :: error

  !$OMP PARALLEL DO PRIVATE(dSdF,dSdFe,dSdFi,dLpdS,dLpdFi,dFpinvdF,dLidS,dLidFi,dFidS,o,p, &
  !$OMP                     invSubFp0,invSubFi0,invFp,invFi, &
  !$OMP                     rhs_3333,lhs_3333,temp_99,temp_33_1,temp_33_2,temp_33_3,temp_33_4,temp_3333,error)
  elementLooping: do e = FEsolving_execElem(1),FEsolving_execElem(2)
    do i = FEsolving_execIP(1),FEsolving_execIP(2)
      do c = 1,homogenization_Ngrains(material_homogenizationAt(e))

        call constitutive_SandItsTangents(devNull,dSdFe,dSdFi, &
                                         crystallite_Fe(1:3,1:3,c,i,e), &
                                         crystallite_Fi(1:3,1:3,c,i,e),c,i,e)
        call constitutive_LiAndItsTangents(devNull,dLidS,dLidFi, &
                                           crystallite_S (1:3,1:3,c,i,e), &
                                           crystallite_Fi(1:3,1:3,c,i,e), &
                                           c,i,e)

        invFp = math_inv33(crystallite_Fp(1:3,1:3,c,i,e))
        invFi = math_inv33(crystallite_Fi(1:3,1:3,c,i,e))
        invSubFp0 = math_inv33(crystallite_subFp0(1:3,1:3,c,i,e))
        invSubFi0 = math_inv33(crystallite_subFi0(1:3,1:3,c,i,e))

        if (sum(abs(dLidS)) < tol_math_check) then
          dFidS = 0.0_pReal
        else
          lhs_3333 = 0.0_pReal; rhs_3333 = 0.0_pReal
          do o=1,3; do p=1,3
            lhs_3333(1:3,1:3,o,p) = lhs_3333(1:3,1:3,o,p) &
                                  + crystallite_subdt(c,i,e)*matmul(invSubFi0,dLidFi(1:3,1:3,o,p))
            lhs_3333(1:3,o,1:3,p) = lhs_3333(1:3,o,1:3,p) &
                                  + invFi*invFi(p,o)
            rhs_3333(1:3,1:3,o,p) = rhs_3333(1:3,1:3,o,p) &
                                  - crystallite_subdt(c,i,e)*matmul(invSubFi0,dLidS(1:3,1:3,o,p))
          enddo; enddo
          call math_invert(temp_99,error,math_3333to99(lhs_3333))
          if (error) then
            call IO_warning(warning_ID=600,el=e,ip=i,g=c, &
                            ext_msg='inversion error in analytic tangent calculation')
            dFidS = 0.0_pReal
          else
            dFidS = math_mul3333xx3333(math_99to3333(temp_99),rhs_3333)
          endif
          dLidS = math_mul3333xx3333(dLidFi,dFidS) + dLidS
        endif

        call constitutive_LpAndItsTangents(devNull,dLpdS,dLpdFi, &
                                           crystallite_S (1:3,1:3,c,i,e), &
                                           crystallite_Fi(1:3,1:3,c,i,e),c,i,e)                     ! call constitutive law to calculate Lp tangent in lattice configuration
        dLpdS = math_mul3333xx3333(dLpdFi,dFidS) + dLpdS

!--------------------------------------------------------------------------------------------------
! calculate dSdF
        temp_33_1 = transpose(matmul(invFp,invFi))
        temp_33_2 = matmul(crystallite_subF(1:3,1:3,c,i,e),invSubFp0)
        temp_33_3 = matmul(matmul(crystallite_subF(1:3,1:3,c,i,e),invFp), invSubFi0)

        do o=1,3; do p=1,3
          rhs_3333(p,o,1:3,1:3)  = matmul(dSdFe(p,o,1:3,1:3),temp_33_1)
          temp_3333(1:3,1:3,p,o) = matmul(matmul(temp_33_2,dLpdS(1:3,1:3,p,o)), invFi) &
                                 + matmul(temp_33_3,dLidS(1:3,1:3,p,o))
        enddo; enddo
        lhs_3333 = crystallite_subdt(c,i,e)*math_mul3333xx3333(dSdFe,temp_3333) &
                 + math_mul3333xx3333(dSdFi,dFidS)

        call math_invert(temp_99,error,math_identity2nd(9)+math_3333to99(lhs_3333))
        if (error) then
          call IO_warning(warning_ID=600,el=e,ip=i,g=c, &
                          ext_msg='inversion error in analytic tangent calculation')
          dSdF = rhs_3333
        else
          dSdF = math_mul3333xx3333(math_99to3333(temp_99),rhs_3333)
        endif

!--------------------------------------------------------------------------------------------------
! calculate dFpinvdF
        temp_3333 = math_mul3333xx3333(dLpdS,dSdF)
        do o=1,3; do p=1,3
          dFpinvdF(1:3,1:3,p,o) = -crystallite_subdt(c,i,e) &
                                * matmul(invSubFp0, matmul(temp_3333(1:3,1:3,p,o),invFi))
        enddo; enddo

!--------------------------------------------------------------------------------------------------
! assemble dPdF
        temp_33_1 = matmul(crystallite_S(1:3,1:3,c,i,e),transpose(invFp))
        temp_33_2 = matmul(invFp,temp_33_1)
        temp_33_3 = matmul(crystallite_subF(1:3,1:3,c,i,e),invFp)
        temp_33_4 = matmul(temp_33_3,crystallite_S(1:3,1:3,c,i,e))

        crystallite_dPdF(1:3,1:3,1:3,1:3,c,i,e) = 0.0_pReal
        do p=1,3
          crystallite_dPdF(p,1:3,p,1:3,c,i,e) = transpose(temp_33_2)
        enddo
        do o=1,3; do p=1,3
          crystallite_dPdF(1:3,1:3,p,o,c,i,e) = crystallite_dPdF(1:3,1:3,p,o,c,i,e) &
                                              + matmul(matmul(crystallite_subF(1:3,1:3,c,i,e), &
                                                       dFpinvdF(1:3,1:3,p,o)),temp_33_1) &
                                              + matmul(matmul(temp_33_3,dSdF(1:3,1:3,p,o)), &
                                                       transpose(invFp)) &
                                              + matmul(temp_33_4,transpose(dFpinvdF(1:3,1:3,p,o)))
        enddo; enddo

    enddo; enddo
  enddo elementLooping
  !$OMP END PARALLEL DO

end subroutine crystallite_stressTangent


!--------------------------------------------------------------------------------------------------
!> @brief calculates orientations
!--------------------------------------------------------------------------------------------------
subroutine crystallite_orientations

  integer &
    c, &                                                                                            !< counter in integration point component loop
    i, &                                                                                            !< counter in integration point loop
    e                                                                                               !< counter in element loop

  !$OMP PARALLEL DO
  do e = FEsolving_execElem(1),FEsolving_execElem(2)
    do i = FEsolving_execIP(1),FEsolving_execIP(2)
      do c = 1,homogenization_Ngrains(material_homogenizationAt(e))
        call crystallite_orientation(c,i,e)%fromMatrix(transpose(math_rotationalPart(crystallite_Fe(1:3,1:3,c,i,e))))
  enddo; enddo; enddo
  !$OMP END PARALLEL DO

  nonlocalPresent: if (any(plasticState%nonLocal)) then
    !$OMP PARALLEL DO
    do e = FEsolving_execElem(1),FEsolving_execElem(2)
      do i = FEsolving_execIP(1),FEsolving_execIP(2)
        if (plasticState(material_phaseAt(1,e))%nonLocal) &
          call plastic_nonlocal_updateCompatibility(crystallite_orientation, &
                                                    phase_plasticityInstance(material_phaseAt(i,e)),i,e)
    enddo; enddo
    !$OMP END PARALLEL DO
  endif nonlocalPresent

end subroutine crystallite_orientations


!--------------------------------------------------------------------------------------------------
!> @brief Map 2nd order tensor to reference config
!--------------------------------------------------------------------------------------------------
function crystallite_push33ToRef(ipc,ip,el, tensor33)

  real(pReal), dimension(3,3) :: crystallite_push33ToRef
  real(pReal), dimension(3,3), intent(in) :: tensor33
  real(pReal), dimension(3,3)             :: T
  integer, intent(in):: &
    el, &
    ip, &
    ipc

  T = matmul(material_orientation0(ipc,ip,el)%asMatrix(), &                                         ! ToDo: initial orientation correct?
             transpose(math_inv33(crystallite_subF(1:3,1:3,ipc,ip,el))))
  crystallite_push33ToRef = matmul(transpose(T),matmul(tensor33,T))

end function crystallite_push33ToRef


!--------------------------------------------------------------------------------------------------
!> @brief writes crystallite results to HDF5 output file
!--------------------------------------------------------------------------------------------------
subroutine crystallite_results

  integer :: p,o
  real(pReal),    allocatable, dimension(:,:,:) :: selected_tensors
  type(rotation), allocatable, dimension(:)     :: selected_rotations
  character(len=pStringLen)                     :: group,structureLabel

  do p=1,size(config_name_phase)
    group = trim('current/constituent')//'/'//trim(config_name_phase(p))//'/generic'

    call results_closeGroup(results_addGroup(group))

    do o = 1, size(output_constituent(p)%label)
      select case (output_constituent(p)%label(o))
        case('f')
          selected_tensors = select_tensors(crystallite_partionedF,p)
          call results_writeDataset(group,selected_tensors,'F',&
                                   'deformation gradient','1')
        case('fe')
          selected_tensors = select_tensors(crystallite_Fe,p)
          call results_writeDataset(group,selected_tensors,'Fe',&
                                   'elastic deformation gradient','1')
        case('fp')
          selected_tensors = select_tensors(crystallite_Fp,p)
          call results_writeDataset(group,selected_tensors,'Fp',&
                                   'plastic deformation gradient','1')
        case('fi')
          selected_tensors = select_tensors(crystallite_Fi,p)
          call results_writeDataset(group,selected_tensors,'Fi',&
                                   'inelastic deformation gradient','1')
        case('lp')
          selected_tensors = select_tensors(crystallite_Lp,p)
          call results_writeDataset(group,selected_tensors,'Lp',&
                                   'plastic velocity gradient','1/s')
        case('li')
          selected_tensors = select_tensors(crystallite_Li,p)
          call results_writeDataset(group,selected_tensors,'Li',&
                                   'inelastic velocity gradient','1/s')
        case('p')
          selected_tensors = select_tensors(crystallite_P,p)
          call results_writeDataset(group,selected_tensors,'P',&
                                   'First Piola-Kirchoff stress','Pa')
        case('s')
          selected_tensors = select_tensors(crystallite_S,p)
          call results_writeDataset(group,selected_tensors,'S',&
                                   'Second Piola-Kirchoff stress','Pa')
        case('orientation')
          select case(lattice_structure(p))
            case(lattice_ISO_ID)
              structureLabel = 'iso'
            case(lattice_FCC_ID)
              structureLabel = 'fcc'
            case(lattice_BCC_ID)
              structureLabel = 'bcc'
            case(lattice_BCT_ID)
              structureLabel = 'bct'
            case(lattice_HEX_ID)
              structureLabel = 'hex'
            case(lattice_ORT_ID)
              structureLabel = 'ort'
          end select
          selected_rotations = select_rotations(crystallite_orientation,p)
          call results_writeDataset(group,selected_rotations,'orientation',&
                                   'crystal orientation as quaternion',structureLabel)
      end select
    enddo
  enddo

  contains

  !------------------------------------------------------------------------------------------------
  !> @brief select tensors for output
  !------------------------------------------------------------------------------------------------
  function select_tensors(dataset,instance)

    integer, intent(in) :: instance
    real(pReal), dimension(:,:,:,:,:), intent(in) :: dataset
    real(pReal), allocatable, dimension(:,:,:) :: select_tensors
    integer :: e,i,c,j

    allocate(select_tensors(3,3,count(material_phaseAt==instance)*discretization_nIP))

    j=0
    do e = 1, size(material_phaseAt,2)
      do i = 1, discretization_nIP
        do c = 1, size(material_phaseAt,1)                                                          !ToDo: this needs to be changed for varying Ngrains
          if (material_phaseAt(c,e) == instance) then
            j = j + 1
            select_tensors(1:3,1:3,j) = dataset(1:3,1:3,c,i,e)
          endif
        enddo
      enddo
    enddo

  end function select_tensors


!--------------------------------------------------------------------------------------------------
!> @brief select rotations for output
!--------------------------------------------------------------------------------------------------
  function select_rotations(dataset,instance)

    integer, intent(in) :: instance
    type(rotation), dimension(:,:,:), intent(in) :: dataset
    type(rotation), allocatable, dimension(:) :: select_rotations
    integer :: e,i,c,j

    allocate(select_rotations(count(material_phaseAt==instance)*homogenization_maxNgrains*discretization_nIP))

    j=0
    do e = 1, size(material_phaseAt,2)
      do i = 1, discretization_nIP
        do c = 1, size(material_phaseAt,1)                                                          !ToDo: this needs to be changed for varying Ngrains
           if (material_phaseAt(c,e) == instance) then
             j = j + 1
             select_rotations(j) = dataset(c,i,e)
           endif
        enddo
      enddo
   enddo

 end function select_rotations

end subroutine crystallite_results


!--------------------------------------------------------------------------------------------------
!> @brief calculation of stress (P) with time integration based on a residuum in Lp and
!> intermediate acceleration of the Newton-Raphson correction
!--------------------------------------------------------------------------------------------------
logical function integrateStress(ipc,ip,el,timeFraction)

  integer, intent(in)::         el, &                                                               ! element index
                                      ip, &                                                         ! integration point index
                                      ipc                                                           ! grain index
  real(pReal), optional, intent(in) :: timeFraction                                                 ! fraction of timestep

  real(pReal), dimension(3,3)::       F, &                                                          ! deformation gradient at end of timestep
                                      Fp_new, &                                                     ! plastic deformation gradient at end of timestep
                                      invFp_new, &                                                  ! inverse of Fp_new
                                      invFp_current, &                                              ! inverse of Fp_current
                                      Lpguess, &                                                    ! current guess for plastic velocity gradient
                                      Lpguess_old, &                                                ! known last good guess for plastic velocity gradient
                                      Lp_constitutive, &                                            ! plastic velocity gradient resulting from constitutive law
                                      residuumLp, &                                                 ! current residuum of plastic velocity gradient
                                      residuumLp_old, &                                             ! last residuum of plastic velocity gradient
                                      deltaLp, &                                                    ! direction of next guess
                                      Fi_new, &                                                     ! gradient of intermediate deformation stages
                                      invFi_new, &
                                      invFi_current, &                                              ! inverse of Fi_current
                                      Liguess, &                                                    ! current guess for intermediate velocity gradient
                                      Liguess_old, &                                                ! known last good guess for intermediate velocity gradient
                                      Li_constitutive, &                                            ! intermediate velocity gradient resulting from constitutive law
                                      residuumLi, &                                                 ! current residuum of intermediate velocity gradient
                                      residuumLi_old, &                                             ! last residuum of intermediate velocity gradient
                                      deltaLi, &                                                    ! direction of next guess
                                      Fe, &                                                         ! elastic deformation gradient
                                      Fe_new, &
                                      S, &                                                          ! 2nd Piola-Kirchhoff Stress in plastic (lattice) configuration
                                      A, &
                                      B, &
                                      temp_33
  real(pReal), dimension(9) ::        temp_9                                                        ! needed for matrix inversion by LAPACK
  integer,     dimension(9) ::        devNull_9                                                     ! needed for matrix inversion by LAPACK
  real(pReal), dimension(9,9) ::      dRLp_dLp, &                                                   ! partial derivative of residuum (Jacobian for Newton-Raphson scheme)
                                      dRLi_dLi                                                      ! partial derivative of residuumI (Jacobian for Newton-Raphson scheme)
  real(pReal), dimension(3,3,3,3)::   dS_dFe, &                                                     ! partial derivative of 2nd Piola-Kirchhoff stress
                                      dS_dFi, &
                                      dFe_dLp, &                                                    ! partial derivative of elastic deformation gradient
                                      dFe_dLi, &
                                      dFi_dLi, &
                                      dLp_dFi, &
                                      dLi_dFi, &
                                      dLp_dS, &
                                      dLi_dS
  real(pReal)                         steplengthLp, &
                                      steplengthLi, &
                                      dt, &                                                         ! time increment
                                      atol_Lp, &
                                      atol_Li, &
                                      devNull
  integer                             NiterationStressLp, &                                         ! number of stress integrations
                                      NiterationStressLi, &                                         ! number of inner stress integrations
                                      ierr, &                                                       ! error indicator for LAPACK
                                      o, &
                                      p, &
                                      jacoCounterLp, &
                                      jacoCounterLi                                                 ! counters to check for Jacobian update
  logical :: error
  external :: &
    dgesv

  integrateStress = .false.

  if (present(timeFraction)) then
    dt = crystallite_subdt(ipc,ip,el) * timeFraction
    F  = crystallite_subF0(1:3,1:3,ipc,ip,el) &
       + (crystallite_subF(1:3,1:3,ipc,ip,el) - crystallite_subF0(1:3,1:3,ipc,ip,el)) * timeFraction
  else
    dt = crystallite_subdt(ipc,ip,el)
    F  = crystallite_subF(1:3,1:3,ipc,ip,el)
  endif

  Lpguess = crystallite_Lp(1:3,1:3,ipc,ip,el)                                                       ! take as first guess
  Liguess = crystallite_Li(1:3,1:3,ipc,ip,el)                                                       ! take as first guess

  call math_invert33(invFp_current,devNull,error,crystallite_subFp0(1:3,1:3,ipc,ip,el))
  if (error) return ! error
  call math_invert33(invFi_current,devNull,error,crystallite_subFi0(1:3,1:3,ipc,ip,el))
  if (error) return ! error

  A = matmul(F,invFp_current)                                                                       ! intermediate tensor needed later to calculate dFe_dLp

  jacoCounterLi  = 0
  steplengthLi   = 1.0_pReal
  residuumLi_old = 0.0_pReal
  Liguess_old    = Liguess

  NiterationStressLi = 0
  LiLoop: do
    NiterationStressLi = NiterationStressLi + 1
    if (NiterationStressLi>num%nStress) return ! error

    invFi_new = matmul(invFi_current,math_I3 - dt*Liguess)
    Fi_new    = math_inv33(invFi_new)

    jacoCounterLp  = 0
    steplengthLp   = 1.0_pReal
    residuumLp_old = 0.0_pReal
    Lpguess_old    = Lpguess

    NiterationStressLp = 0
    LpLoop: do
      NiterationStressLp = NiterationStressLp + 1
      if (NiterationStressLp>num%nStress) return ! error

      B  = math_I3 - dt*Lpguess
      Fe = matmul(matmul(A,B), invFi_new)
      call constitutive_SandItsTangents(S, dS_dFe, dS_dFi, &
                                        Fe, Fi_new, ipc, ip, el)

      call constitutive_LpAndItsTangents(Lp_constitutive, dLp_dS, dLp_dFi, &
                                         S, Fi_new, ipc, ip, el)

      !* update current residuum and check for convergence of loop
      atol_Lp = max(num%rtol_crystalliteStress * max(norm2(Lpguess),norm2(Lp_constitutive)), &      ! absolute tolerance from largest acceptable relative error
                    num%atol_crystalliteStress)                                                     ! minimum lower cutoff
      residuumLp = Lpguess - Lp_constitutive

      if (any(IEEE_is_NaN(residuumLp))) then
        return ! error
      elseif (norm2(residuumLp) < atol_Lp) then                                                     ! converged if below absolute tolerance
        exit LpLoop
      elseif (NiterationStressLp == 1 .or. norm2(residuumLp) < norm2(residuumLp_old)) then          ! not converged, but improved norm of residuum (always proceed in first iteration)...
        residuumLp_old = residuumLp                                                                 ! ...remember old values and...
        Lpguess_old    = Lpguess
        steplengthLp   = 1.0_pReal                                                                  ! ...proceed with normal step length (calculate new search direction)
      else                                                                                          ! not converged and residuum not improved...
        steplengthLp = num%subStepSizeLp * steplengthLp                                             ! ...try with smaller step length in same direction
        Lpguess      = Lpguess_old &
                     + deltaLp * stepLengthLp
        cycle LpLoop
      endif

     !* calculate Jacobian for correction term
      if (mod(jacoCounterLp, num%iJacoLpresiduum) == 0) then
        jacoCounterLp = jacoCounterLp + 1

        do o=1,3; do p=1,3
          dFe_dLp(o,1:3,p,1:3) = A(o,p)*transpose(invFi_new)                                        ! dFe_dLp(i,j,k,l) = -dt * A(i,k) invFi(l,j)
        enddo; enddo
        dFe_dLp  = - dt * dFe_dLp
        dRLp_dLp = math_identity2nd(9) &
                 - math_3333to99(math_mul3333xx3333(math_mul3333xx3333(dLp_dS,dS_dFe),dFe_dLp))
        temp_9 = math_33to9(residuumLp)
        call dgesv(9,1,dRLp_dLp,9,devNull_9,temp_9,9,ierr)                                          ! solve dRLp/dLp * delta Lp = -res for delta Lp
        if (ierr /= 0) return ! error
        deltaLp = - math_9to33(temp_9)
      endif

      Lpguess = Lpguess &
              + deltaLp * steplengthLp
    enddo LpLoop

    call constitutive_LiAndItsTangents(Li_constitutive, dLi_dS, dLi_dFi, &
                                       S, Fi_new, ipc, ip, el)

    !* update current residuum and check for convergence of loop
    atol_Li = max(num%rtol_crystalliteStress * max(norm2(Liguess),norm2(Li_constitutive)), &        ! absolute tolerance from largest acceptable relative error
                  num%atol_crystalliteStress)                                                       ! minimum lower cutoff
    residuumLi = Liguess - Li_constitutive
    if (any(IEEE_is_NaN(residuumLi))) then
      return ! error
    elseif (norm2(residuumLi) < atol_Li) then                                                       ! converged if below absolute tolerance
      exit LiLoop
    elseif (NiterationStressLi == 1 .or. norm2(residuumLi) < norm2(residuumLi_old)) then            ! not converged, but improved norm of residuum (always proceed in first iteration)...
      residuumLi_old = residuumLi                                                                   ! ...remember old values and...
      Liguess_old    = Liguess
      steplengthLi   = 1.0_pReal                                                                    ! ...proceed with normal step length (calculate new search direction)
    else                                                                                            ! not converged and residuum not improved...
      steplengthLi = num%subStepSizeLi �s] for each trans system
      t_tw, &                                                                                       !< twin thickness [m] for each twin system
      clambdaslip, &                                                                                !< Adj. parameter for distance between 2 forest dislocations for each slip system
      t_tr, &                                                                                       !< martensite lamellar thickness [m] for each trans system and instance
      p, &                                                                                          !< p-exponent in glide velocity
      q, &                                                                                          !< q-exponent in glide velocity
      r, &                                                                                          !< r-exponent in twin nucleation rate
      s, &                                                                                          !< s-exponent in trans nucleation rate
      gamma_char, &                                                                                 !< characteristic shear for twins
      b
    real(preal),               allocatable, dimension(:,:) :: &
      h_sl_sl, &                                                                                    !<
      h_sl_tw, &                                                                                    !<
      h_tw_tw, &                                                                                    !<
      h_sl_tr, &                                                                                    !<
      h_tr_tr, &                                                                                    !<
      n0_sl, &                                                                                      !< slip system normal
      forestprojection, &
      c66
    real(preal),               allocatable, dimension(:,:,:) :: &
      p_sl, &
      p_tw, &
      p_tr, &
      c66_tw, &
      c66_tr
    integer :: &
      sum_n_sl, &                                                                                   !< total number of active slip system
      sum_n_tw, &                                                                                   !< total number of active twin system
      sum_n_tr
    integer,                   allocatable, dimension(:,:) :: &
      fcc_twinnucleationslippair                                                                    ! ToDo: Better name? Is also use for trans
    character(len=pStringLen), allocatable, dimension(:) :: &
      output
    logical :: &
      extendeddislocations, &                                                                       !< consider split into partials for climb calculation
      fcctwintransnucleation, &                                                                     !< twinning and transformation models are for fcc
      dipoleformation
  end type                                                                                          
 
  type :: tdislotwinstate
    real(preal),                  dimension(:,:),   pointer :: &
      rho_mob, &
      rho_dip, &
      gamma_sl, &
      f_tw, &
      f_tr
  end type tdislotwinstate
 
  type :: tdislotwinmicrostructure
    real(preal),                  dimension(:,:),   allocatable :: &
      lambda_sl, &                                                                                  !< mean free path between 2 obstacles seen by a moving dislocation
      lambda_tw, &                                                                                  !< mean free path between 2 obstacles seen by a growing twin
      lambda_tr, &                                                                                  !< mean free path between 2 obstacles seen by a growing martensite
      tau_pass, &
      tau_hat_tw, &
      tau_hat_tr, &
      v_tw, &                                                                                       !< volume of a new twin
      v_tr, &                                                                                       !< volume of a new martensite disc
      tau_r_tw, &                                                                                   !< stress to bring partials close together (twin)
      tau_r_tr
  end type tdislotwinmicrostructure
 
!--------------------------------------------------------------------------------------------------
! containers for parameters and state
  type(tparameters),              allocatable, dimension(:) :: param
  type(tdislotwinstate),          allocatable, dimension(:) :: &
    dotstate, &
    state
  type(tdislotwinmicrostructure), allocatable, dimension(:) :: dependentstate
 
contains
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine plastic_dislotwin_init
 
  integer :: &
    ninstance, &
    p, i, &
    nipcmyphase, &
    sizestate, sizedotstate, &
    startindex, endindex
  integer,     dimension(:), allocatable :: &
    n_sl, n_tw, n_tr
  real(preal), allocatable, dimension(:) :: &
    rho_mob_0, &                                                                                    !< initial unipolar dislocation density per slip system
    rho_dip_0
  character(len=pStringLen) :: &
    extmsg = ''
 
  write(6,'(/,a)') ' <<<+-  constitutive_'//plasticity_dislotwin_label//' init  -+>>>'; flush(6)
 
  write(6,'(/,a)') ' Ma and Roters, Acta Materialia 52(12):3603–3612, 2004'
  write(6,'(a)')   ' https://doi.org/10.1016/j.actamat.2004.04.012'
 
  write(6,'(/,a)') ' Roters et al., Computational Materials Science 39:91–95, 2007'
  write(6,'(a)')   ' https://doi.org/10.1016/j.commatsci.2006.04.014'
 
  write(6,'(/,a)') ' Wong et al., Acta Materialia 118:140–151, 2016'
  write(6,'(a,/)') ' https://doi.org/10.1016/j.actamat.2016.07.032'
 
  ninstance = count(phase_plasticity == plasticity_dislotwin_id)
 
  if (iand(debug_level(debug_constitutive),debug_levelbasic) /= 0) &
    write(6,'(a16,1x,i5,/)') '# instances:',ninstance
 
  allocate(param(ninstance))
  allocate(state(ninstance))
  allocate(dotstate(ninstance))
  allocate(dependentstate(ninstance))
 
  do p = 1, size(phase_plasticity)
    if (phase_plasticity(p) /= plasticity_dislotwin_id) cycle
    associate(prm => param(phase_plasticityinstance(p)), &
              dot => dotstate(phase_plasticityinstance(p)), &
              stt => state(phase_plasticityinstance(p)), &
              dst => dependentstate(phase_plasticityinstance(p)), &
              config   => config_phase(p))
 
    prm%output = config%getStrings('(output)', defaultval=emptystringarray)
 
    ! This data is read in already in lattice
    prm%mu  = lattice_mu(p)
    prm%nu  = lattice_nu(p)
    prm%C66 = lattice_c66(1:6,1:6,p)
 
!--------------------------------------------------------------------------------------------------
! slip related parameters
    n_sl         = config%getInts('nslip',defaultval=emptyintarray)
    prm%sum_N_sl = sum(abs(n_sl))
    slipactive: if (prm%sum_N_sl > 0) then
      prm%P_sl    = lattice_schmidmatrix_slip(n_sl,config%getString('lattice_structure'),&
                                              config%getFloat('c/a',defaultval=0.0_preal))
      prm%h_sl_sl = lattice_interaction_slipbyslip(n_sl,config%getFloats('interaction_slipslip'), &
                                                   config%getString('lattice_structure'))
      prm%forestProjection = lattice_forestprojection_edge(n_sl,config%getString('lattice_structure'),&
                                                           config%getFloat('c/a',defaultval=0.0_preal))
      prm%forestProjection = transpose(prm%forestProjection)
 
      prm%n0_sl            = lattice_slip_normal(n_sl,config%getString('lattice_structure'),&
                                                 config%getFloat('c/a',defaultval=0.0_preal))
      prm%fccTwinTransNucleation = merge(.true., .false., lattice_structure(p) == lattice_fcc_id) &
                                 .and. (n_sl(1) == 12)
      if(prm%fccTwinTransNucleation) prm%fcc_twinNucleationSlipPair = lattice_fcc_twinnucleationslippair
 
      rho_mob_0                = config%getFloats('rhoedge0',   requiredsize=size(n_sl))
      rho_dip_0                = config%getFloats('rhoedgedip0',requiredsize=size(n_sl))
      prm%v0                   = config%getFloats('v0',         requiredsize=size(n_sl))
      prm%b_sl                 = config%getFloats('slipburgers',requiredsize=size(n_sl))
      prm%Delta_F              = config%getFloats('qedge',      requiredsize=size(n_sl))
      prm%CLambdaSlip          = config%getFloats('clambdaslip',requiredsize=size(n_sl))
      prm%p                    = config%getFloats('p_slip',     requiredsize=size(n_sl))
      prm%q                    = config%getFloats('q_slip',     requiredsize=size(n_sl))
      prm%B                    = config%getFloats('b',          requiredsize=size(n_sl), &
                                                  defaultval=[(0.0_preal, i=1,size(n_sl))])
 
      prm%tau_0                = config%getFloat('solidsolutionstrength')
      prm%CEdgeDipMinDistance  = config%getFloat('cedgedipmindistance')
      prm%D0                   = config%getFloat('d0')
      prm%Qsd                  = config%getFloat('qsd')
      prm%ExtendedDislocations = config%keyExists('/extend_dislocations/')
      if (prm%ExtendedDislocations) then
        prm%SFE_0K             = config%getFloat('sfe_0k')
        prm%dSFE_dT            = config%getFloat('dsfe_dt')
      endif
 
      prm%dipoleformation = .not. config%keyExists('/nodipoleformation/')
 
      ! multiplication factor according to crystal structure (nearest neighbors bcc vs fcc/hex)
      ! details: Argon & Moffat, Acta Metallurgica, Vol. 29, pg 293 to 299, 1981
      prm%omega = config%getFloat('omega',  defaultval = 1000.0_preal) &
                * merge(12.0_preal,8.0_preal,any(lattice_structure(p) == [lattice_fcc_id,lattice_hex_id]))
 
      ! expand: family => system
      rho_mob_0        = math_expand(rho_mob_0,       n_sl)
      rho_dip_0        = math_expand(rho_dip_0,       n_sl)
      prm%v0           = math_expand(prm%v0,          n_sl)
      prm%b_sl         = math_expand(prm%b_sl,        n_sl)
      prm%Delta_F      = math_expand(prm%Delta_F,     n_sl)
      prm%CLambdaSlip  = math_expand(prm%CLambdaSlip, n_sl)
      prm%p            = math_expand(prm%p,           n_sl)
      prm%q            = math_expand(prm%q,           n_sl)
      prm%B            = math_expand(prm%B,           n_sl)
 
      ! sanity checks
      if (    prm%D0           <= 0.0_preal)          extmsg = trim(extmsg)//' D0'
      if (    prm%Qsd          <= 0.0_preal)          extmsg = trim(extmsg)//' Qsd'
      if (any(rho_mob_0        <  0.0_preal))         extmsg = trim(extmsg)//' rho_mob_0'
      if (any(rho_dip_0        <  0.0_preal))         extmsg = trim(extmsg)//' rho_dip_0'
      if (any(prm%v0           <  0.0_preal))         extmsg = trim(extmsg)//' v0'
      if (any(prm%b_sl         <= 0.0_preal))         extmsg = trim(extmsg)//' b_sl'
      if (any(prm%Delta_F      <= 0.0_preal))         extmsg = trim(extmsg)//' Delta_F'
      if (any(prm%CLambdaSlip  <= 0.0_preal))         extmsg = trim(extmsg)//' CLambdaSlip'
      if (any(prm%B            <  0.0_preal))         extmsg = trim(extmsg)//' B'
      if (any(prm%p<=0.0_preal .or. prm%p>1.0_preal)) extmsg = trim(extmsg)//' p'
      if (any(prm%q< 1.0_preal .or. prm%q>2.0_preal)) extmsg = trim(extmsg)//' q'
    else slipactive
      rho_mob_0 = emptyrealarray; rho_dip_0 = emptyrealarray
      allocate(prm%b_sl,prm%Delta_F,prm%v0,prm%CLambdaSlip,prm%p,prm%q,prm%B,source=emptyrealarray)
      allocate(prm%forestProjection(0,0),prm%h_sl_sl(0,0))
    endif slipactive
 
!--------------------------------------------------------------------------------------------------
! twin related parameters
    n_tw         = config%getInts('ntwin', defaultval=emptyintarray)
    prm%sum_N_tw = sum(abs(n_tw))
    twinactive: if (prm%sum_N_tw > 0) then
      prm%P_tw  = lattice_schmidmatrix_twin(n_tw,config%getString('lattice_structure'),&
                                                   config%getFloat('c/a',defaultval=0.0_preal))
      prm%h_tw_tw   = lattice_interaction_twinbytwin(n_tw,&
                                                     config%getFloats('interaction_twintwin'), &
                                                     config%getString('lattice_structure'))
 
      prm%b_tw      = config%getFloats('twinburgers',  requiredsize=size(n_tw))
      prm%t_tw      = config%getFloats('twinsize',     requiredsize=size(n_tw))
      prm%r         = config%getFloats('r_twin',       requiredsize=size(n_tw))
 
      prm%xc_twin   = config%getFloat('xc_twin')
      prm%L_tw      = config%getFloat('l0_twin')
      prm%i_tw      = config%getFloat('cmfptwin')
 
      prm%gamma_char= lattice_characteristicshear_twin(n_tw,config%getString('lattice_structure'),&
                                                       config%getFloat('c/a',defaultval=0.0_preal))
 
      prm%C66_tw    = lattice_c66_twin(n_tw,prm%C66,config%getString('lattice_structure'),&
                                       config%getFloat('c/a',defaultval=0.0_preal))
 
      if (.not. prm%fccTwinTransNucleation) then
        prm%dot_N_0_tw = config%getFloats('ndot0_twin')
        prm%dot_N_0_tw = math_expand(prm%dot_N_0_tw,n_tw)
      endif
 
      ! expand: family => system
      prm%b_tw = math_expand(prm%b_tw,n_tw)
      prm%t_tw = math_expand(prm%t_tw,n_tw)
      prm%r    = math_expand(prm%r,n_tw)
 
      ! sanity checks
      if (    prm%xc_twin       < 0.0_preal)  extmsg = trim(extmsg)//' xc_twin'
      if (    prm%L_tw          < 0.0_preal)  extmsg = trim(extmsg)//' L_tw'
      if (    prm%i_tw          < 0.0_preal)  extmsg = trim(extmsg)//' i_tw'
      if (any(prm%b_tw          < 0.0_preal)) extmsg = trim(extmsg)//' b_tw'
      if (any(prm%t_tw          < 0.0_preal)) extmsg = trim(extmsg)//' t_tw'
      if (any(prm%r             < 0.0_preal)) extmsg = trim(extmsg)//' r'
      if (.not. prm%fccTwinTransNucleation) then
        if (any(prm%dot_N_0_tw  < 0.0_preal)) extmsg = trim(extmsg)//' dot_N_0_tw'
      endif
    else twinactive
      allocate(prm%gamma_char,prm%b_tw,prm%dot_N_0_tw,prm%t_tw,prm%r,source=emptyrealarray)
      allocate(prm%h_tw_tw(0,0))
    endif twinactive
 
!--------------------------------------------------------------------------------------------------
! transformation related parameters
    n_tr         = config%getInts('ntrans', defaultval=emptyintarray)
    prm%sum_N_tr = sum(abs(n_tr))
    transactive: if (prm%sum_N_tr > 0) then
      prm%b_tr = config%getFloats('transburgers')
      prm%b_tr = math_expand(prm%b_tr,n_tr)
 
      prm%h             = config%getFloat('transstackheight', defaultval=0.0_preal) ! ToDo: How to handle that???
      prm%i_tr          = config%getFloat('cmfptrans',        defaultval=0.0_preal) ! ToDo: How to handle that???
      prm%gamma_fcc_hex = config%getFloat('deltag')
      prm%xc_trans      = config%getFloat('xc_trans',         defaultval=0.0_preal) ! ToDo: How to handle that???
      prm%L_tr          = config%getFloat('l0_trans')
 
      prm%h_tr_tr = lattice_interaction_transbytrans(n_tr,config%getFloats('interaction_transtrans'), &
                                                     config%getString('lattice_structure'))
 
      prm%C66_tr  = lattice_c66_trans(n_tr,prm%C66,config%getString('trans_lattice_structure'), &
                                      0.0_preal, &
                                      config%getFloat('a_bcc', defaultval=0.0_preal), &
                                      config%getFloat('a_fcc', defaultval=0.0_preal))
 
      prm%P_tr    = lattice_schmidmatrix_trans(n_tr,config%getString('trans_lattice_structure'), &
                                               0.0_preal, &
                                               config%getFloat('a_bcc', defaultval=0.0_preal), &
                                               config%getFloat('a_fcc', defaultval=0.0_preal))
 
      if (lattice_structure(p) /= lattice_fcc_id) then
        prm%dot_N_0_tr = config%getFloats('ndot0_trans')
        prm%dot_N_0_tr = math_expand(prm%dot_N_0_tr,n_tr)
      endif
      prm%t_tr = config%getFloats('lamellarsize')
      prm%t_tr = math_expand(prm%t_tr,n_tr)
      prm%s    = config%getFloats('s_trans',defaultval=[0.0_preal])
      prm%s    = math_expand(prm%s,n_tr)
 
      ! sanity checks
      if (    prm%xc_trans      < 0.0_preal)  extmsg = trim(extmsg)//' xc_trans'
      if (    prm%L_tr          < 0.0_preal)  extmsg = trim(extmsg)//' L_tr'
      if (    prm%i_tr          < 0.0_preal)  extmsg = trim(extmsg)//' i_tr'
      if (any(prm%t_tr          < 0.0_preal)) extmsg = trim(extmsg)//' t_tr'
      if (any(prm%s             < 0.0_preal)) extmsg = trim(extmsg)//' s'
      if (lattice_structure(p) /= lattice_fcc_id) then
        if (any(prm%dot_N_0_tr  < 0.0_preal)) extmsg = trim(extmsg)//' dot_N_0_tr'
      endif
    else transactive
      allocate(prm%s,prm%b_tr,prm%t_tr,prm%dot_N_0_tr,source=emptyrealarray)
      allocate(prm%h_tr_tr(0,0))
    endif transactive
 
!--------------------------------------------------------------------------------------------------
! shearband related parameters
    prm%sbVelocity = config%getFloat('shearbandvelocity',defaultval=0.0_preal)
    if (prm%sbVelocity > 0.0_preal) then
      prm%sbResistance = config%getFloat('shearbandresistance')
      prm%E_sb         = config%getFloat('qedgepersbsystem')
      prm%p_sb         = config%getFloat('p_shearband')
      prm%q_sb         = config%getFloat('q_shearband')
 
      ! sanity checks
      if (prm%sbResistance  <  0.0_preal) extmsg = trim(extmsg)//' shearbandresistance'
      if (prm%E_sb          <  0.0_preal) extmsg = trim(extmsg)//' qedgepersbsystem'
      if (prm%p_sb          <= 0.0_preal) extmsg = trim(extmsg)//' p_shearband'
      if (prm%q_sb          <= 0.0_preal) extmsg = trim(extmsg)//' q_shearband'
    endif
 
!--------------------------------------------------------------------------------------------------
! parameters required for several mechanisms and their interactions
    if(prm%sum_N_sl + prm%sum_N_tw + prm%sum_N_tw > 0) &
      prm%D = config%getFloat('grainsize')
 
    twinorslipactive: if (prm%sum_N_tw + prm%sum_N_tr > 0) then
      prm%SFE_0K  = config%getFloat('sfe_0k')
      prm%dSFE_dT = config%getFloat('dsfe_dt')
      prm%V_cs    = config%getFloat('vcrossslip')
    endif twinorslipactive
 
    slipandtwinactive: if (prm%sum_N_sl * prm%sum_N_tw > 0) then
      prm%h_sl_tw = lattice_interaction_slipbytwin(n_sl,n_tw,&
                                                   config%getFloats('interaction_sliptwin'), &
                                                   config%getString('lattice_structure'))
      if (prm%fccTwinTransNucleation .and. size(n_tw) /= 1) extmsg = trim(extmsg)//' interaction_sliptwin'
    endif slipandtwinactive
 
    slipandtransactive: if (prm%sum_N_sl * prm%sum_N_tr > 0) then
      prm%h_sl_tr = lattice_interaction_slipbytrans(n_sl,n_tr,&
                                                    config%getFloats('interaction_sliptrans'), &
                                            config%getString('lattice_structure'))
      if (prm%fccTwinTransNucleation .and. size(n_tr) /= 1) extmsg = trim(extmsg)//' interaction_sliptrans'
    endif slipandtransactive
 
!--------------------------------------------------------------------------------------------------
! allocate state arrays
    nipcmyphase  = count(material_phaseat == p) * discretization_nip
    sizedotstate = size(['rho_mob ','rho_dip ','gamma_sl']) * prm%sum_N_sl &
                 + size(['f_tw'])                           * prm%sum_N_tw &
                 + size(['f_tr'])                           * prm%sum_N_tr
    sizestate = sizedotstate
 
    call material_allocateplasticstate(p,nipcmyphase,sizestate,sizedotstate,0)
 
!--------------------------------------------------------------------------------------------------
! locally defined state aliases and initialization of state0 and atol
    startindex = 1
    endindex   = prm%sum_N_sl
    stt%rho_mob=>plasticstate(p)%state(startindex:endindex,:)
    stt%rho_mob= spread(rho_mob_0,2,nipcmyphase)
    dot%rho_mob=>plasticstate(p)%dotState(startindex:endindex,:)
    plasticstate(p)%atol(startindex:endindex) = config%getFloat('atol_rho',defaultval=1.0_preal)
    if (any(plasticstate(p)%atol(startindex:endindex) < 0.0_preal)) extmsg = trim(extmsg)//' atol_rho'
 
    startindex = endindex + 1
    endindex   = endindex + prm%sum_N_sl
    stt%rho_dip=>plasticstate(p)%state(startindex:endindex,:)
    stt%rho_dip= spread(rho_dip_0,2,nipcmyphase)
    dot%rho_dip=>plasticstate(p)%dotState(startindex:endindex,:)
    plasticstate(p)%atol(startindex:endindex) = config%getFloat('atol_rho',defaultval=1.0_preal)
 
    startindex = endindex + 1
    endindex   = endindex + prm%sum_N_sl
    stt%gamma_sl=>plasticstate(p)%state(startindex:endindex,:)
    dot%gamma_sl=>plasticstate(p)%dotState(startindex:endindex,:)
    plasticstate(p)%atol(startindex:endindex) = 1.0e-2_preal
    ! global alias
    plasticstate(p)%slipRate        => plasticstate(p)%dotState(startindex:endindex,:)
 
    startindex = endindex + 1
    endindex   = endindex + prm%sum_N_tw
    stt%f_tw=>plasticstate(p)%state(startindex:endindex,:)
    dot%f_tw=>plasticstate(p)%dotState(startindex:endindex,:)
    plasticstate(p)%atol(startindex:endindex) = config%getFloat('f_twin',defaultval=1.0e-7_preal)
    if (any(plasticstate(p)%atol(startindex:endindex) < 0.0_preal)) extmsg = trim(extmsg)//' f_twin'
 
    startindex = endindex + 1
    endindex   = endindex + prm%sum_N_tr
    stt%f_tr=>plasticstate(p)%state(startindex:endindex,:)
    dot%f_tr=>plasticstate(p)%dotState(startindex:endindex,:)
    plasticstate(p)%atol(startindex:endindex) = config%getFloat('f_trans',defaultval=1.0e-6_preal)
    if (any(plasticstate(p)%atol(startindex:endindex) < 0.0_preal)) extmsg = trim(extmsg)//' f_trans'
 
    allocate(dst%Lambda_sl             (prm%sum_N_sl,nipcmyphase),source=0.0_preal)
    allocate(dst%tau_pass              (prm%sum_N_sl,nipcmyphase),source=0.0_preal)
 
    allocate(dst%Lambda_tw             (prm%sum_N_tw,nipcmyphase),source=0.0_preal)
    allocate(dst%tau_hat_tw            (prm%sum_N_tw,nipcmyphase),source=0.0_preal)
    allocate(dst%tau_r_tw              (prm%sum_N_tw,nipcmyphase),source=0.0_preal)
    allocate(dst%V_tw                  (prm%sum_N_tw,nipcmyphase),source=0.0_preal)
 
    allocate(dst%Lambda_tr             (prm%sum_N_tr,nipcmyphase),source=0.0_preal)
    allocate(dst%tau_hat_tr            (prm%sum_N_tr,nipcmyphase),source=0.0_preal)
    allocate(dst%tau_r_tr              (prm%sum_N_tr,nipcmyphase),source=0.0_preal)
    allocate(dst%V_tr                  (prm%sum_N_tr,nipcmyphase),source=0.0_preal)
 
    plasticstate(p)%state0 = plasticstate(p)%state                                                  ! ToDo: this could be done centrally
 
    end associate
 
!--------------------------------------------------------------------------------------------------
!  exit if any parameter is out of range
    if (extmsg /= '') call io_error(211,ext_msg=trim(extmsg)//'('//plasticity_dislotwin_label//')')
 
  enddo
 
end subroutine plastic_dislotwin_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module function plastic_dislotwin_homogenizedc(ipc,ip,el) result(homogenizedc)
 
  real(preal), dimension(6,6) :: &
    homogenizedc
  integer,     intent(in) :: &
    ipc, &                                                                                          !< component-ID of integration point
    ip, &                                                                                           !< integration point
    el
 
  integer :: i, &
             of
  real(preal) :: f_unrotated
 
  of = material_phasememberat(ipc,ip,el)
  associate(prm => param(phase_plasticityinstance(material_phaseat(ipc,el))),&
            stt => state(phase_plasticityinstance(material_phaseat(ipc,el))))
 
  f_unrotated = 1.0_preal &
              - sum(stt%f_tw(1:prm%sum_N_tw,of)) &
              - sum(stt%f_tr(1:prm%sum_N_tr,of))
 
  homogenizedc = f_unrotated * prm%C66
  do i=1,prm%sum_N_tw
    homogenizedc = homogenizedc &
                 + stt%f_tw(i,of)*prm%C66_tw(1:6,1:6,i)
  enddo
  do i=1,prm%sum_N_tr
    homogenizedc = homogenizedc &
                 + stt%f_tr(i,of)*prm%C66_tr(1:6,1:6,i)
  enddo
 
  end associate
 
end function plastic_dislotwin_homogenizedc
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine plastic_dislotwin_lpanditstangent(lp,dlp_dmp,mp,t,instance,of)
 
  real(preal), dimension(3,3),     intent(out) :: lp
  real(preal), dimension(3,3,3,3), intent(out) :: dlp_dmp
  real(preal), dimension(3,3),     intent(in)  :: mp
  integer,                         intent(in)  :: instance,of
  real(preal),                     intent(in)  :: t
 
  integer :: i,k,l,m,n
  real(preal) :: &
     f_unrotated,stressratio_p,&
     boltzmannratio, &
     ddot_gamma_dtau, &
     tau
  real(preal), dimension(param(instance)%sum_N_sl) :: &
    dot_gamma_sl,ddot_gamma_dtau_slip
  real(preal), dimension(param(instance)%sum_N_tw) :: &
    dot_gamma_twin,ddot_gamma_dtau_twin
  real(preal), dimension(param(instance)%sum_N_tr) :: &
    dot_gamma_tr,ddot_gamma_dtau_trans
  real(preal):: dot_gamma_sb
  real(preal), dimension(3,3) :: eigvectors, p_sb
  real(preal), dimension(3)   :: eigvalues
  real(preal), dimension(3,6), parameter :: &
    sb_scomposition = &
      reshape(real([&
         1, 0, 1, &
         1, 0,-1, &
         1, 1, 0, &
         1,-1, 0, &
         0, 1, 1, &
         0, 1,-1  &
         ],preal),[ 3,6]), &
    sb_mcomposition = &
      reshape(real([&
         1, 0,-1, &
         1, 0,+1, &
         1,-1, 0, &
         1, 1, 0, &
         0, 1,-1, &
         0, 1, 1  &
         ],preal),[ 3,6])
 
  associate(prm => param(instance), stt => state(instance))
 
  f_unrotated = 1.0_preal &
              - sum(stt%f_tw(1:prm%sum_N_tw,of)) &
              - sum(stt%f_tr(1:prm%sum_N_tr,of))
 
  lp = 0.0_preal
  dlp_dmp = 0.0_preal
 
  call kinetics_slip(mp,t,instance,of,dot_gamma_sl,ddot_gamma_dtau_slip)
  slipcontribution: do i = 1, prm%sum_N_sl
    lp = lp + dot_gamma_sl(i)*prm%P_sl(1:3,1:3,i)
    forall (k=1:3,l=1:3,m=1:3,n=1:3) &
      dlp_dmp(k,l,m,n) = dlp_dmp(k,l,m,n) &
                       + ddot_gamma_dtau_slip(i) * prm%P_sl(k,l,i) * prm%P_sl(m,n,i)
  enddo slipcontribution
 
  !ToDo: Why do this before shear banding?
  lp      = lp      * f_unrotated
  dlp_dmp = dlp_dmp * f_unrotated
 
  shearbandingcontribution: if(dneq0(prm%sbVelocity)) then
 
    boltzmannratio = prm%E_sb/(kb*t)
    call math_eigh33(mp,eigvalues,eigvectors)                                                       ! is Mp symmetric by design?
 
    do i = 1,6
      p_sb = 0.5_preal * math_outer(matmul(eigvectors,sb_scomposition(1:3,i)),&
                                    matmul(eigvectors,sb_mcomposition(1:3,i)))
      tau = math_tensordot(mp,p_sb)
 
      significantshearbandstress: if (abs(tau) > tol_math_check) then
        stressratio_p = (abs(tau)/prm%sbResistance)**prm%p_sb
        dot_gamma_sb = sign(prm%sbVelocity*exp(-boltzmannratio*(1-stressratio_p)**prm%q_sb), tau)
        ddot_gamma_dtau = abs(dot_gamma_sb)*boltzmannratio* prm%p_sb*prm%q_sb/ prm%sbResistance &
                   * (abs(tau)/prm%sbResistance)**(prm%p_sb-1.0_preal) &
                   * (1.0_preal-stressratio_p)**(prm%q_sb-1.0_preal)
 
        lp = lp + dot_gamma_sb * p_sb
        forall (k=1:3,l=1:3,m=1:3,n=1:3) &
          dlp_dmp(k,l,m,n) = dlp_dmp(k,l,m,n) &
                           + ddot_gamma_dtau * p_sb(k,l) * p_sb(m,n)
      endif significantshearbandstress
    enddo
 
  endif shearbandingcontribution
 
  call kinetics_twin(mp,t,dot_gamma_sl,instance,of,dot_gamma_twin,ddot_gamma_dtau_twin)
  twincontibution: do i = 1, prm%sum_N_tw
    lp = lp + dot_gamma_twin(i)*prm%P_tw(1:3,1:3,i) * f_unrotated
    forall (k=1:3,l=1:3,m=1:3,n=1:3) &
      dlp_dmp(k,l,m,n) = dlp_dmp(k,l,m,n) &
                       + ddot_gamma_dtau_twin(i)* prm%P_tw(k,l,i)*prm%P_tw(m,n,i) * f_unrotated
  enddo twincontibution
 
  call kinetics_trans(mp,t,dot_gamma_sl,instance,of,dot_gamma_tr,ddot_gamma_dtau_trans)
  transcontibution: do i = 1, prm%sum_N_tr
    lp = lp + dot_gamma_tr(i)*prm%P_tr(1:3,1:3,i) * f_unrotated
    forall (k=1:3,l=1:3,m=1:3,n=1:3) &
      dlp_dmp(k,l,m,n) = dlp_dmp(k,l,m,n) &
                       + ddot_gamma_dtau_trans(i)* prm%P_tr(k,l,i)*prm%P_tr(m,n,i) * f_unrotated
  enddo transcontibution
 
 
  end associate
 
end subroutine plastic_dislotwin_lpanditstangent
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine plastic_dislotwin_dotstate(mp,t,instance,of)
 
  real(preal), dimension(3,3),  intent(in):: &
    mp
  real(preal),                  intent(in) :: &
    t
  integer,                      intent(in) :: &
    instance, &
    of
 
  integer :: i
  real(preal) :: &
    f_unrotated, &
    rho_dip_distance, &
    v_cl, &                                                                                         !< climb velocity
    gamma, &                                                                                        !< stacking fault energy
    tau, &
    sigma_cl, &                                                                                     !< climb stress
    b_d
  real(preal), dimension(param(instance)%sum_N_sl) :: &
    dot_rho_dip_formation, &
    dot_rho_dip_climb, &
    rho_dip_distance_min, &
    dot_gamma_sl
  real(preal), dimension(param(instance)%sum_N_tw) :: &
    dot_gamma_twin
  real(preal), dimension(param(instance)%sum_N_tr) :: &
    dot_gamma_tr
 
  associate(prm => param(instance),    stt => state(instance), &
            dot => dotstate(instance), dst => dependentstate(instance))
 
  f_unrotated = 1.0_preal &
              - sum(stt%f_tw(1:prm%sum_N_tw,of)) &
              - sum(stt%f_tr(1:prm%sum_N_tr,of))
 
  call kinetics_slip(mp,t,instance,of,dot_gamma_sl)
  dot%gamma_sl(:,of) = abs(dot_gamma_sl)
 
  rho_dip_distance_min = prm%CEdgeDipMinDistance*prm%b_sl
 
  slipstate: do i = 1, prm%sum_N_sl
    tau = math_tensordot(mp,prm%P_sl(1:3,1:3,i))
 
    significantslipstress: if (deq0(tau)) then
      dot_rho_dip_formation(i) = 0.0_preal
      dot_rho_dip_climb(i) = 0.0_preal
    else significantslipstress
      rho_dip_distance = 3.0_preal*prm%mu*prm%b_sl(i)/(16.0_preal*pi*abs(tau))
      rho_dip_distance = math_clip(rho_dip_distance, right = dst%Lambda_sl(i,of))
      rho_dip_distance = math_clip(rho_dip_distance, left  = rho_dip_distance_min(i))
 
      if (prm%dipoleFormation) then
        dot_rho_dip_formation(i) = 2.0_preal*(rho_dip_distance-rho_dip_distance_min(i))/prm%b_sl(i) &
                                 * stt%rho_mob(i,of)*abs(dot_gamma_sl(i))
      else
        dot_rho_dip_formation(i) = 0.0_preal
      endif
 
      if (deq(rho_dip_distance,rho_dip_distance_min(i))) then
        dot_rho_dip_climb(i) = 0.0_preal
      else
      !@details: Refer: Argon & Moffat, Acta Metallurgica, Vol. 29, pg 293 to 299, 1981
        sigma_cl = dot_product(prm%n0_sl(1:3,i),matmul(mp,prm%n0_sl(1:3,i)))
        if (prm%ExtendedDislocations) then
          gamma = prm%SFE_0K + prm%dSFE_dT * t
          b_d = 24.0_preal*pi*(1.0_preal - prm%nu)/(2.0_preal + prm%nu)* gamma/(prm%mu*prm%b_sl(i))
        else
          b_d = 1.0_preal
        endif
        v_cl = 2.0_preal*prm%omega*b_d**2.0_preal*exp(-prm%Qsd/(kb*t)) &
             * (exp(abs(sigma_cl)*prm%b_sl(i)**3.0_preal/(kb*t)) - 1.0_preal)
 
        dot_rho_dip_climb(i) = 4.0_preal*v_cl*stt%rho_dip(i,of) &
                             / (rho_dip_distance-rho_dip_distance_min(i))
      endif
    endif significantslipstress
  enddo slipstate
 
  dot%rho_mob(:,of) = abs(dot_gamma_sl)/(prm%b_sl*dst%Lambda_sl(:,of)) &
                    - dot_rho_dip_formation &
                    - 2.0_preal*rho_dip_distance_min/prm%b_sl * stt%rho_mob(:,of)*abs(dot_gamma_sl)
 
  dot%rho_dip(:,of) = dot_rho_dip_formation &
                    - 2.0_preal*rho_dip_distance_min/prm%b_sl * stt%rho_dip(:,of)*abs(dot_gamma_sl) &
                    - dot_rho_dip_climb
 
  call kinetics_twin(mp,t,dot_gamma_sl,instance,of,dot_gamma_twin)
  dot%f_tw(:,of) = f_unrotated*dot_gamma_twin/prm%gamma_char
 
  call kinetics_trans(mp,t,dot_gamma_sl,instance,of,dot_gamma_tr)
  dot%f_tr(:,of) = f_unrotated*dot_gamma_tr
 
  end associate
 
end subroutine plastic_dislotwin_dotstate
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine plastic_dislotwin_dependentstate(t,instance,of)
 
  integer,       intent(in) :: &
    instance, &
    of
  real(preal),   intent(in) :: &
    t
 
  real(preal) :: &
    sumf_twin,gamma,sumf_trans
  real(preal), dimension(param(instance)%sum_N_sl) :: &
    inv_lambda_sl_sl, &                                                                             !< 1/mean free distance between 2 forest dislocations seen by a moving dislocation
    inv_lambda_sl_tw, &                                                                             !< 1/mean free distance between 2 twin stacks from different systems seen by a moving dislocation
    inv_lambda_sl_tr
  real(preal), dimension(param(instance)%sum_N_tw) :: &
    inv_lambda_tw_tw, &                                                                             !< 1/mean free distance between 2 twin stacks from different systems seen by a growing twin
    f_over_t_tw
   real(preal), dimension(param(instance)%sum_N_tr) :: &
    inv_lambda_tr_tr, &                                                                             !< 1/mean free distance between 2 martensite stacks from different systems seen by a growing martensite
    f_over_t_tr
  real(preal), dimension(:), allocatable :: &
    x0
 
 
  associate(prm => param(instance),&
            stt => state(instance),&
            dst => dependentstate(instance))
 
  sumf_twin  = sum(stt%f_tw(1:prm%sum_N_tw,of))
  sumf_trans = sum(stt%f_tr(1:prm%sum_N_tr,of))
 
  gamma = prm%SFE_0K + prm%dSFE_dT * t
 
  !* rescaled volume fraction for topology
  f_over_t_tw = stt%f_tw(1:prm%sum_N_tw,of)/prm%t_tw                                                ! this is per system ...
  f_over_t_tr = sumf_trans/prm%t_tr                                                                 ! but this not
                                                                                                    ! ToDo ...Physically correct, but naming could be adjusted
 
  inv_lambda_sl_sl = sqrt(matmul(prm%forestProjection, &
                                 stt%rho_mob(:,of)+stt%rho_dip(:,of)))/prm%CLambdaSlip
 
  if (prm%sum_N_tw > 0 .and. prm%sum_N_sl > 0) &
    inv_lambda_sl_tw = matmul(prm%h_sl_tw,f_over_t_tw)/(1.0_preal-sumf_twin)
 
  inv_lambda_tw_tw = matmul(prm%h_tw_tw,f_over_t_tw)/(1.0_preal-sumf_twin)
 
  if (prm%sum_N_tr > 0 .and. prm%sum_N_sl > 0) &
    inv_lambda_sl_tr = matmul(prm%h_sl_tr,f_over_t_tr)/(1.0_preal-sumf_trans)
 
  inv_lambda_tr_tr = matmul(prm%h_tr_tr,f_over_t_tr)/(1.0_preal-sumf_trans)
 
  if ((prm%sum_N_tw > 0) .or. (prm%sum_N_tr > 0)) then                                              ! ToDo: better logic needed here
    dst%Lambda_sl(:,of) = prm%D &
                        / (1.0_preal+prm%D*(inv_lambda_sl_sl + inv_lambda_sl_tw + inv_lambda_sl_tr))
  else
    dst%Lambda_sl(:,of) = prm%D &
                        / (1.0_preal+prm%D*inv_lambda_sl_sl) !!!!!! correct?
  endif
 
  dst%Lambda_tw(:,of) = prm%i_tw*prm%D/(1.0_preal+prm%D*inv_lambda_tw_tw)
  dst%Lambda_tr(:,of) = prm%i_tr*prm%D/(1.0_preal+prm%D*inv_lambda_tr_tr)
 
  !* threshold stress for dislocation motion
  dst%tau_pass(:,of) = prm%mu*prm%b_sl* sqrt(matmul(prm%h_sl_sl,stt%rho_mob(:,of)+stt%rho_dip(:,of)))
 
  !* threshold stress for growing twin/martensite
  if(prm%sum_N_tw == prm%sum_N_sl) &
    dst%tau_hat_tw(:,of) = gamma/(3.0_preal*prm%b_tw) &
                         + 3.0_preal*prm%b_tw*prm%mu/(prm%L_tw*prm%b_sl) ! slip burgers here correct?
  if(prm%sum_N_tr == prm%sum_N_sl) &
    dst%tau_hat_tr(:,of) = gamma/(3.0_preal*prm%b_tr) &
                         + 3.0_preal*prm%b_tr*prm%mu/(prm%L_tr*prm%b_sl) & ! slip burgers here correct?
                         + prm%h*prm%gamma_fcc_hex/ (3.0_preal*prm%b_tr)
 
  dst%V_tw(:,of) = (pi/4.0_preal)*prm%t_tw*dst%Lambda_tw(:,of)**2.0_preal
  dst%V_tr(:,of) = (pi/4.0_preal)*prm%t_tr*dst%Lambda_tr(:,of)**2.0_preal
 
 
  x0 = prm%mu*prm%b_tw**2.0_preal/(gamma*8.0_preal*pi)*(2.0_preal+prm%nu)/(1.0_preal-prm%nu)        ! ToDo: In the paper, this is the burgers vector for slip and is the same for twin and trans
  dst%tau_r_tw(:,of) = prm%mu*prm%b_tw/(2.0_preal*pi)*(1.0_preal/(x0+prm%xc_twin)+cos(pi/3.0_preal)/x0)
 
  x0 = prm%mu*prm%b_tr**2.0_preal/(gamma*8.0_preal*pi)*(2.0_preal+prm%nu)/(1.0_preal-prm%nu)        ! ToDo: In the paper, this is the burgers vector for slip
  dst%tau_r_tr(:,of) = prm%mu*prm%b_tr/(2.0_preal*pi)*(1.0_preal/(x0+prm%xc_trans)+cos(pi/3.0_preal)/x0)
 
  end associate
 
end subroutine plastic_dislotwin_dependentstate
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine plastic_dislotwin_results(instance,group)
 
  integer,          intent(in) :: instance
  character(len=*), intent(in) :: group
 
  integer :: o
 
 associate(prm => param(instance), stt => state(instance), dst => dependentstate(instance))
  outputsloop: do o = 1,size(prm%output)
    select case(trim(prm%output(o)))
 
      case('rho_mob')
        if(prm%sum_N_sl>0) call results_writedataset(group,stt%rho_mob,'rho_mob',&
                                                     'mobile dislocation density','1/m²')
      case('rho_dip')
        if(prm%sum_N_sl>0) call results_writedataset(group,stt%rho_dip,'rho_dip',&
                                                     'dislocation dipole density''1/m²')
      case('gamma_sl')
        if(prm%sum_N_sl>0) call results_writedataset(group,stt%gamma_sl,'gamma_sl',&
                                                     'plastic shear','1')
      case('lambda_sl')
        if(prm%sum_N_sl>0) call results_writedataset(group,dst%Lambda_sl,'Lambda_sl',&
                                                     'mean free path for slip','m')
      case('tau_pass')
        if(prm%sum_N_sl>0) call results_writedataset(group,dst%tau_pass,'tau_pass',&
                                                     'passing stress for slip','Pa')
 
      case('f_tw')
        if(prm%sum_N_tw>0) call results_writedataset(group,stt%f_tw,'f_tw',&
                                                     'twinned volume fraction','m³/m³')
      case('lambda_tw')
        if(prm%sum_N_tw>0) call results_writedataset(group,dst%Lambda_tw,'Lambda_tw',&
                                                     'mean free path for twinning','m')
      case('tau_hat_tw')
        if(prm%sum_N_tw>0) call results_writedataset(group,dst%tau_hat_tw,'tau_hat_tw',&
                                                     'threshold stress for twinning','Pa')
 
      case('f_tr')
        if(prm%sum_N_tr>0) call results_writedataset(group,stt%f_tr,'f_tr',&
                                                     'martensite volume fraction','m³/m³')
 
    end select
  enddo outputsloop
  end associate
 
end subroutine plastic_dislotwin_results
 
 
!--------------------------------------------------------------------------------------------------
!         stress, and the resolved stress.
! NOTE: Against the common convention, the result (i.e. intent(out)) variables are the last to
! have the optional arguments at the end
!--------------------------------------------------------------------------------------------------
pure subroutine kinetics_slip(Mp,T,instance,of, &
                              dot_gamma_sl,ddot_gamma_dtau_slip,tau_slip)
 
  real(preal), dimension(3,3),  intent(in) :: &
    mp
  real(preal),                  intent(in) :: &
    t
  integer,                      intent(in) :: &
    instance, &
    of
 
  real(preal), dimension(param(instance)%sum_N_sl), intent(out) :: &
    dot_gamma_sl
  real(preal), dimension(param(instance)%sum_N_sl), optional, intent(out) :: &
    ddot_gamma_dtau_slip, &
    tau_slip
  real(preal), dimension(param(instance)%sum_N_sl) :: &
    ddot_gamma_dtau
 
  real(preal), dimension(param(instance)%sum_N_sl) :: &
    tau, &
    stressratio, &
    stressratio_p, &
    boltzmannratio, &
    v_wait_inverse, &                                                                               !< inverse of the effective velocity of a dislocation waiting at obstacles (unsigned)
    v_run_inverse, &                                                                                !< inverse of the velocity of a free moving dislocation (unsigned)
    dv_wait_inverse_dtau, &
    dv_run_inverse_dtau, &
    dv_dtau, &
    tau_eff
  integer :: i
 
  associate(prm => param(instance), stt => state(instance), dst => dependentstate(instance))
 
  do i = 1, prm%sum_N_sl
    tau(i) = math_tensordot(mp,prm%P_sl(1:3,1:3,i))
  enddo
 
  tau_eff = abs(tau)-dst%tau_pass(:,of)
 
  significantstress: where(tau_eff > tol_math_check)
    stressratio    = tau_eff/prm%tau_0
    stressratio_p  = stressratio** prm%p
    boltzmannratio = prm%Delta_F/(kb*t)
    v_wait_inverse = prm%v0**(-1.0_preal) * exp(boltzmannratio*(1.0_preal-stressratio_p)** prm%q)
    v_run_inverse  = prm%B/(tau_eff*prm%b_sl)
 
    dot_gamma_sl = sign(stt%rho_mob(:,of)*prm%b_sl/(v_wait_inverse+v_run_inverse),tau)
 
    dv_wait_inverse_dtau = -1.0_preal * v_wait_inverse * prm%p * prm%q * boltzmannratio &
                         * (stressratio**(prm%p-1.0_preal)) &
                         * (1.0_preal-stressratio_p)**(prm%q-1.0_preal) &
                         / prm%tau_0
    dv_run_inverse_dtau  = -1.0_preal * v_run_inverse/tau_eff
    dv_dtau              = -1.0_preal * (dv_wait_inverse_dtau+dv_run_inverse_dtau) &
                         / (v_wait_inverse+v_run_inverse)**2.0_preal
    ddot_gamma_dtau = dv_dtau*stt%rho_mob(:,of)*prm%b_sl
  else where significantstress
    dot_gamma_sl    = 0.0_preal
    ddot_gamma_dtau = 0.0_preal
  end where significantstress
 
  end associate
 
  if(present(ddot_gamma_dtau_slip)) ddot_gamma_dtau_slip = ddot_gamma_dtau
  if(present(tau_slip))             tau_slip             = tau
 
end subroutine kinetics_slip
 
 
!--------------------------------------------------------------------------------------------------
!         stress.
! NOTE: Against the common convention, the result (i.e. intent(out)) variables are the last to
! have the optional arguments at the end.
!--------------------------------------------------------------------------------------------------
pure subroutine kinetics_twin(Mp,T,dot_gamma_sl,instance,of,&
                              dot_gamma_twin,ddot_gamma_dtau_twin)
 
  real(preal), dimension(3,3),  intent(in) :: &
    mp
  real(preal),                  intent(in) :: &
    t
  integer,                      intent(in) :: &
    instance, &
    of
  real(preal), dimension(param(instance)%sum_N_sl), intent(in) :: &
    dot_gamma_sl
 
  real(preal), dimension(param(instance)%sum_N_tw), intent(out) :: &
    dot_gamma_twin
  real(preal), dimension(param(instance)%sum_N_tw), optional, intent(out) :: &
    ddot_gamma_dtau_twin
 
  real, dimension(param(instance)%sum_N_tw) :: &
    tau, &
    ndot0, &
    stressratio_r, &
    ddot_gamma_dtau
 
  integer :: i,s1,s2
 
  associate(prm => param(instance), stt => state(instance), dst => dependentstate(instance))
 
  do i = 1, prm%sum_N_tw
    tau(i) = math_tensordot(mp,prm%P_tw(1:3,1:3,i))
    isfcc: if (prm%fccTwinTransNucleation) then
      s1=prm%fcc_twinNucleationSlipPair(1,i)
      s2=prm%fcc_twinNucleationSlipPair(2,i)
      if (tau(i) < dst%tau_r_tw(i,of)) then                                                         ! ToDo: correct?
        ndot0=(abs(dot_gamma_sl(s1))*(stt%rho_mob(s2,of)+stt%rho_dip(s2,of))+&
               abs(dot_gamma_sl(s2))*(stt%rho_mob(s1,of)+stt%rho_dip(s1,of)))/&                     ! ToDo: MD: it would be more consistent to use shearrates from state
                (prm%L_tw*prm%b_sl(i))*&
                (1.0_preal-exp(-prm%V_cs/(kb*t)*(dst%tau_r_tw(i,of)-tau(i))))                       ! P_ncs
      else
        ndot0=0.0_preal
      end if
    else isfcc
      ndot0=prm%dot_N_0_tw(i)
    endif isfcc
  enddo
 
  significantstress: where(tau > tol_math_check)
    stressratio_r   = (dst%tau_hat_tw(:,of)/tau)**prm%r
    dot_gamma_twin  = prm%gamma_char * dst%V_tw(:,of) * ndot0*exp(-stressratio_r)
    ddot_gamma_dtau = (dot_gamma_twin*prm%r/tau)*stressratio_r
  else where significantstress
    dot_gamma_twin  = 0.0_preal
    ddot_gamma_dtau = 0.0_preal
  end where significantstress
 
  end associate
 
  if(present(ddot_gamma_dtau_twin)) ddot_gamma_dtau_twin = ddot_gamma_dtau
 
end subroutine kinetics_twin
 
 
!--------------------------------------------------------------------------------------------------
!         resolved stress.
! NOTE: Against the common convention, the result (i.e. intent(out)) variables are the last to
! have the optional arguments at the end.
!--------------------------------------------------------------------------------------------------
pure subroutine kinetics_trans(Mp,T,dot_gamma_sl,instance,of,&
                              dot_gamma_tr,ddot_gamma_dtau_trans)
 
  real(preal), dimension(3,3),  intent(in) :: &
    mp
  real(preal),                  intent(in) :: &
    t
  integer,                      intent(in) :: &
    instance, &
    of
  real(preal), dimension(param(instance)%sum_N_sl), intent(in) :: &
    dot_gamma_sl
 
  real(preal), dimension(param(instance)%sum_N_tr), intent(out) :: &
    dot_gamma_tr
  real(preal), dimension(param(instance)%sum_N_tr), optional, intent(out) :: &
    ddot_gamma_dtau_trans
 
  real, dimension(param(instance)%sum_N_tr) :: &
    tau, &
    ndot0, &
    stressratio_s, &
    ddot_gamma_dtau
 
  integer :: i,s1,s2
  associate(prm => param(instance), stt => state(instance), dst => dependentstate(instance))
 
  do i = 1, prm%sum_N_tr
    tau(i) = math_tensordot(mp,prm%P_tr(1:3,1:3,i))
    isfcc: if (prm%fccTwinTransNucleation) then
      s1=prm%fcc_twinNucleationSlipPair(1,i)
      s2=prm%fcc_twinNucleationSlipPair(2,i)
      if (tau(i) < dst%tau_r_tr(i,of)) then                                                         ! ToDo: correct?
        ndot0=(abs(dot_gamma_sl(s1))*(stt%rho_mob(s2,of)+stt%rho_dip(s2,of))+&
               abs(dot_gamma_sl(s2))*(stt%rho_mob(s1,of)+stt%rho_dip(s1,of)))/&                     ! ToDo: MD: it would be more consistent to use shearrates from state
                (prm%L_tr*prm%b_sl(i))*&
                (1.0_preal-exp(-prm%V_cs/(kb*t)*(dst%tau_r_tr(i,of)-tau(i))))                       ! P_ncs
      else
        ndot0=0.0_preal
      end if
    else isfcc
      ndot0=prm%dot_N_0_tr(i)
    endif isfcc
  enddo
 
  significantstress: where(tau > tol_math_check)
    stressratio_s   = (dst%tau_hat_tr(:,of)/tau)**prm%s
    dot_gamma_tr    = dst%V_tr(:,of) * ndot0*exp(-stressratio_s)
    ddot_gamma_dtau = (dot_gamma_tr*prm%s/tau)*stressratio_s
  else where significantstress
    dot_gamma_tr  = 0.0_preal
    ddot_gamma_dtau = 0.0_preal
  end where significantstress
 
  end associate
 
  if(present(ddot_gamma_dtau_trans)) ddot_gamma_dtau_trans = ddot_gamma_dtau
 
end subroutine kinetics_trans
 
end submodule plastic_dislotwin
# 42 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_disloUCLA.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
submodule(constitutive) plastic_disloucla
 
  real(preal), parameter :: &
    kb = 1.38e-23_preal                                                                             
 
  type :: tparameters
    real(preal) :: &
      d    = 1.0_preal, &                                                                           
      mu   = 1.0_preal, &                                                                           
      d_0  = 1.0_preal, &                                                                           
      q_cl = 1.0_preal                                                                              
    real(preal),               allocatable, dimension(:) :: &
      b_sl, &                                                                                       !< magnitude of burgers vector [m]
      d_a, &
      i_sl, &                                                                                       !< Adj. parameter for distance between 2 forest dislocations
      atomicvolume, &
      tau_0, &
      !* mobility law parameters
      delta_f, &                                                                                    
      v0, &                                                                                         
      p, &                                                                                          
      q, &                                                                                          
      b, &                                                                                          
      kink_height, &                                                                                
      w, &                                                                                          
      omega                                                                                         
    real(preal),               allocatable, dimension(:,:) :: &
      h_sl_sl, &                                                                                    !< slip resistance from slip activity
      forestprojection
    real(preal),               allocatable, dimension(:,:,:) :: &
      p_sl, &
      nonschmid_pos, &
      nonschmid_neg
    integer :: &
      sum_n_sl
    character(len=pStringLen), allocatable, dimension(:) :: &
      output
    logical :: &
      dipoleformation
  end type                                                                                          
 
  type :: tdislouclastate
    real(preal), dimension(:,:), pointer :: &
      rho_mob, &
      rho_dip, &
      gamma_sl
  end type tdislouclastate
 
  type :: tdisloucladependentstate
    real(preal), dimension(:,:), allocatable :: &
      lambda_sl, &
      threshold_stress
  end type tdisloucladependentstate
 
!--------------------------------------------------------------------------------------------------
! containers for parameters and state
  type(tparameters),              allocatable, dimension(:) :: param
  type(tdislouclastate),          allocatable, dimension(:) :: &
    dotstate, &
    state
  type(tdisloucladependentstate), allocatable, dimension(:) :: dependentstate
 
contains
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine plastic_disloucla_init
 
  integer :: &
    ninstance, &
    p, i, &
    nipcmyphase, &
    sizestate, sizedotstate, &
    startindex, endindex
  integer,    dimension(:), allocatable :: &
    n_sl
  real(preal),dimension(:), allocatable :: &
    rho_mob_0, &                                                                                    !< initial dislocation density
    rho_dip_0, &                                                                                    !< initial dipole density
    a
  character(len=pStringLen) :: &
    extmsg = ''
 
  write(6,'(/,a)') ' <<<+-  plastic_'//plasticity_disloucla_label//' init  -+>>>'; flush(6)
 
  write(6,'(/,a)') ' Cereceda et al., International Journal of Plasticity 78:242–256, 2016'
  write(6,'(a)')   ' https://dx.doi.org/10.1016/j.ijplas.2015.09.002'
 
  ninstance = count(phase_plasticity == plasticity_disloucla_id)
  if (iand(debug_level(debug_constitutive),debug_levelbasic) /= 0) &
    write(6,'(a16,1x,i5,/)') '# instances:',ninstance
 
  allocate(param(ninstance))
  allocate(state(ninstance))
  allocate(dotstate(ninstance))
  allocate(dependentstate(ninstance))
 
  do p = 1, size(phase_plasticity)
    if (phase_plasticity(p) /= plasticity_disloucla_id) cycle
    associate(prm => param(phase_plasticityinstance(p)), &
              dot => dotstate(phase_plasticityinstance(p)), &
              stt => state(phase_plasticityinstance(p)), &
              dst => dependentstate(phase_plasticityinstance(p)), &
              config => config_phase(p))
 
    prm%output = config%getStrings('(output)',defaultval=emptystringarray)
 
    ! This data is read in already in lattice
    prm%mu = lattice_mu(p)
 
!--------------------------------------------------------------------------------------------------
! slip related parameters
    n_sl         = config%getInts('nslip',defaultval=emptyintarray)
    prm%sum_N_sl = sum(abs(n_sl))
    slipactive: if (prm%sum_N_sl > 0) then
      prm%P_sl = lattice_schmidmatrix_slip(n_sl,config%getString('lattice_structure'),&
                                           config%getFloat('c/a',defaultval=0.0_preal))
 
      if(trim(config%getString('lattice_structure')) == 'bcc') then
        a = config%getFloats('nonschmid_coefficients',defaultval = emptyrealarray)
        prm%nonSchmid_pos = lattice_nonschmidmatrix(n_sl,a,+1)
        prm%nonSchmid_neg = lattice_nonschmidmatrix(n_sl,a,-1)
      else
        prm%nonSchmid_pos = prm%P_sl
        prm%nonSchmid_neg = prm%P_sl
      endif
 
      prm%h_sl_sl = lattice_interaction_slipbyslip(n_sl,config%getFloats('interaction_slipslip'), &
                                                   config%getString('lattice_structure'))
      prm%forestProjection = lattice_forestprojection_edge(n_sl,config%getString('lattice_structure'),&
                                                           config%getFloat('c/a',defaultval=0.0_preal))
      prm%forestProjection = transpose(prm%forestProjection)
 
      rho_mob_0       = config%getFloats('rhoedge0',       requiredsize=size(n_sl))
      rho_dip_0       = config%getFloats('rhoedgedip0',    requiredsize=size(n_sl))
      prm%v0          = config%getFloats('v0',             requiredsize=size(n_sl))
      prm%b_sl        = config%getFloats('slipburgers',    requiredsize=size(n_sl))
      prm%delta_F     = config%getFloats('qedge',          requiredsize=size(n_sl))
 
      prm%i_sl        = config%getFloats('clambdaslip',    requiredsize=size(n_sl))
      prm%tau_0       = config%getFloats('tau_peierls',    requiredsize=size(n_sl))
      prm%p           = config%getFloats('p_slip',         requiredsize=size(n_sl), &
                                         defaultval=[(1.0_preal,i=1,size(n_sl))])
      prm%q           = config%getFloats('q_slip',         requiredsize=size(n_sl), &
                                         defaultval=[(1.0_preal,i=1,size(n_sl))])
      prm%kink_height = config%getFloats('kink_height',    requiredsize=size(n_sl))
      prm%w           = config%getFloats('kink_width',     requiredsize=size(n_sl))
      prm%omega       = config%getFloats('omega',          requiredsize=size(n_sl))
      prm%B           = config%getFloats('friction_coeff', requiredsize=size(n_sl))
 
      prm%D               = config%getFloat('grainsize')
      prm%D_0             = config%getFloat('d0')
      prm%Q_cl            = config%getFloat('qsd')
      prm%atomicVolume    = config%getFloat('catomicvolume')       * prm%b_sl**3.0_preal
      prm%D_a             = config%getFloat('cedgedipmindistance') * prm%b_sl
      prm%dipoleformation = config%getFloat('dipoleformationfactor') > 0.0_preal                    !should be on by default, ToDo: change to /key/-type key
 
      ! expand: family => system
      rho_mob_0          = math_expand(rho_mob_0,          n_sl)
      rho_dip_0          = math_expand(rho_dip_0,          n_sl)
      prm%q              = math_expand(prm%q,              n_sl)
      prm%p              = math_expand(prm%p,              n_sl)
      prm%delta_F        = math_expand(prm%delta_F,        n_sl)
      prm%b_sl           = math_expand(prm%b_sl,           n_sl)
      prm%kink_height    = math_expand(prm%kink_height,    n_sl)
      prm%w              = math_expand(prm%w,              n_sl)
      prm%omega          = math_expand(prm%omega,          n_sl)
      prm%tau_0          = math_expand(prm%tau_0,          n_sl)
      prm%v0             = math_expand(prm%v0,             n_sl)
      prm%B              = math_expand(prm%B,              n_sl)
      prm%i_sl           = math_expand(prm%i_sl,           n_sl)
      prm%atomicVolume   = math_expand(prm%atomicVolume,   n_sl)
      prm%D_a            = math_expand(prm%D_a,            n_sl)
 
      ! sanity checks
      if (    prm%D_0          <= 0.0_preal)  extmsg = trim(extmsg)//' D_0'
      if (    prm%Q_cl         <= 0.0_preal)  extmsg = trim(extmsg)//' Q_cl'
      if (any(rho_mob_0        <  0.0_preal)) extmsg = trim(extmsg)//' rhoedge0'
      if (any(rho_dip_0        <  0.0_preal)) extmsg = trim(extmsg)//' rhoedgedip0'
      if (any(prm%v0           <  0.0_preal)) extmsg = trim(extmsg)//' v0'
      if (any(prm%b_sl         <= 0.0_preal)) extmsg = trim(extmsg)//' b_sl'
      if (any(prm%delta_F      <= 0.0_preal)) extmsg = trim(extmsg)//' qedge'
      if (any(prm%tau_0        <  0.0_preal)) extmsg = trim(extmsg)//' tau_0'
      if (any(prm%D_a          <= 0.0_preal)) extmsg = trim(extmsg)//' cedgedipmindistance or b_sl'
      if (any(prm%atomicVolume <= 0.0_preal)) extmsg = trim(extmsg)//' catomicvolume or b_sl'
 
    else slipactive
      rho_mob_0= emptyrealarray; rho_dip_0 = emptyrealarray
      allocate(prm%b_sl,prm%D_a,prm%i_sl,prm%atomicVolume,prm%tau_0, &
               prm%delta_F,prm%v0,prm%p,prm%q,prm%B,prm%kink_height,prm%w,prm%omega, &
               source = emptyrealarray)
      allocate(prm%forestProjection(0,0))
      allocate(prm%h_sl_sl         (0,0))
    endif slipactive
 
!--------------------------------------------------------------------------------------------------
! allocate state arrays
    nipcmyphase = count(material_phaseat == p) * discretization_nip
    sizedotstate = size(['rho_mob ','rho_dip ','gamma_sl']) * prm%sum_N_sl
    sizestate = sizedotstate
 
    call material_allocateplasticstate(p,nipcmyphase,sizestate,sizedotstate,0)
 
!--------------------------------------------------------------------------------------------------
! state aliases and initialization
    startindex = 1
    endindex   = prm%sum_N_sl
    stt%rho_mob => plasticstate(p)%state(startindex:endindex,:)
    stt%rho_mob =  spread(rho_mob_0,2,nipcmyphase)
    dot%rho_mob => plasticstate(p)%dotState(startindex:endindex,:)
    plasticstate(p)%atol(startindex:endindex) = config%getFloat('atol_rho',defaultval=1.0_preal)
    if (any(plasticstate(p)%atol(startindex:endindex) < 0.0_preal)) extmsg = trim(extmsg)//' atol_rho'
 
    startindex = endindex + 1
    endindex   = endindex + prm%sum_N_sl
    stt%rho_dip => plasticstate(p)%state(startindex:endindex,:)
    stt%rho_dip =  spread(rho_dip_0,2,nipcmyphase)
    dot%rho_dip => plasticstate(p)%dotState(startindex:endindex,:)
    plasticstate(p)%atol(startindex:endindex) = config%getFloat('atol_rho',defaultval=1.0_preal)
 
    startindex = endindex + 1
    endindex   = endindex + prm%sum_N_sl
    stt%gamma_sl => plasticstate(p)%state(startindex:endindex,:)
    dot%gamma_sl => plasticstate(p)%dotState(startindex:endindex,:)
    plasticstate(p)%atol(startindex:endindex) = 1.0e-2_preal
    ! global alias
    plasticstate(p)%slipRate        => plasticstate(p)%dotState(startindex:endindex,:)
 
    allocate(dst%Lambda_sl(prm%sum_N_sl,nipcmyphase),         source=0.0_preal)
    allocate(dst%threshold_stress(prm%sum_N_sl,nipcmyphase),  source=0.0_preal)
 
    plasticstate(p)%state0 = plasticstate(p)%state                                                  ! ToDo: this could be done centrally
 
    end associate
 
!--------------------------------------------------------------------------------------------------
!  exit if any parameter is out of range
    if (extmsg /= '') call io_error(211,ext_msg=trim(extmsg)//'('//plasticity_disloucla_label//')')
 
  enddo
 
end subroutine plastic_disloucla_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure module subroutine plastic_disloucla_lpanditstangent(lp,dlp_dmp, &
                                                         mp,t,instance,of)
  real(preal), dimension(3,3),     intent(out) :: &
    lp
  real(preal), dimension(3,3,3,3), intent(out) :: &
    dlp_dmp
 
  real(preal), dimension(3,3), intent(in) :: &
    mp
  real(preal),                 intent(in) :: &
    t
  integer,                     intent(in) :: &
    instance, &
    of
 
  integer :: &
    i,k,l,m,n
  real(preal), dimension(param(instance)%sum_N_sl) :: &
    dot_gamma_pos,dot_gamma_neg, &
    ddot_gamma_dtau_pos,ddot_gamma_dtau_neg
 
  lp = 0.0_preal
  dlp_dmp = 0.0_preal
 
  associate(prm => param(instance))
 
  call kinetics(mp,t,instance,of,dot_gamma_pos,dot_gamma_neg,ddot_gamma_dtau_pos,ddot_gamma_dtau_neg)
  do i = 1, prm%sum_N_sl
    lp = lp + (dot_gamma_pos(i)+dot_gamma_neg(i))*prm%P_sl(1:3,1:3,i)
    forall (k=1:3,l=1:3,m=1:3,n=1:3) &
      dlp_dmp(k,l,m,n) = dlp_dmp(k,l,m,n) &
                       + ddot_gamma_dtau_pos(i) * prm%P_sl(k,l,i) * prm%nonSchmid_pos(m,n,i) &
                       + ddot_gamma_dtau_neg(i) * prm%P_sl(k,l,i) * prm%nonSchmid_neg(m,n,i)
  enddo
 
  end associate
 
end subroutine plastic_disloucla_lpanditstangent
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine plastic_disloucla_dotstate(mp,t,instance,of)
 
  real(preal), dimension(3,3),  intent(in) :: &
    mp
  real(preal),                  intent(in) :: &
    t
  integer,                      intent(in) :: &
    instance, &
    of
 
  real(preal) :: &
    vacancydiffusion
  real(preal), dimension(param(instance)%sum_N_sl) :: &
    gdot_pos, gdot_neg,&
    tau_pos,&
    tau_neg, &
    v_cl, &
    dot_rho_dip_formation, &
    dot_rho_dip_climb, &
    dip_distance
 
  associate(prm => param(instance), stt => state(instance),dot => dotstate(instance), dst => dependentstate(instance))
 
  call kinetics(mp,t,instance,of,&
                gdot_pos,gdot_neg, &
                tau_pos_out = tau_pos,tau_neg_out = tau_neg)
 
  dot%gamma_sl(:,of) = (gdot_pos+gdot_neg)                                                          ! ToDo: needs to be abs
  vacancydiffusion = prm%D_0*exp(-prm%Q_cl/(kb*t))
 
  where(deq0(tau_pos))                                                                              ! ToDo: use avg of pos and neg
    dot_rho_dip_formation = 0.0_preal
    dot_rho_dip_climb     = 0.0_preal
  else where
    dip_distance = math_clip(3.0_preal*prm%mu*prm%b_sl/(16.0_preal*pi*abs(tau_pos)), &
                             prm%D_a, &                                                             ! lower limit
                             dst%Lambda_sl(:,of))                                                   ! upper limit
    dot_rho_dip_formation = merge(2.0_preal*dip_distance* stt%rho_mob(:,of)*abs(dot%gamma_sl(:,of))/prm%b_sl, & ! ToDo: ignore region of spontaneous annihilation
                                  0.0_preal, &
                                  prm%dipoleformation)
    v_cl = (3.0_preal*prm%mu*vacancydiffusion*prm%atomicVolume/(2.0_preal*pi*kb*t)) &
                  * (1.0_preal/(dip_distance+prm%D_a))
    dot_rho_dip_climb = (4.0_preal*v_cl*stt%rho_dip(:,of))/(dip_distance-prm%D_a)                   ! ToDo: Discuss with Franz: Stress dependency?
  end where
 
  dot%rho_mob(:,of) = abs(dot%gamma_sl(:,of))/(prm%b_sl*dst%Lambda_sl(:,of)) &                      ! multiplication
                    - dot_rho_dip_formation &
                    - (2.0_preal*prm%D_a)/prm%b_sl*stt%rho_mob(:,of)*abs(dot%gamma_sl(:,of))        ! Spontaneous annihilation of 2 single edge dislocations
  dot%rho_dip(:,of) = dot_rho_dip_formation &
                    - (2.0_preal*prm%D_a)/prm%b_sl*stt%rho_dip(:,of)*abs(dot%gamma_sl(:,of)) &      ! Spontaneous annihilation of a single edge dislocation with a dipole constituent
                    - dot_rho_dip_climb
 
  end associate
 
end subroutine plastic_disloucla_dotstate
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine plastic_disloucla_dependentstate(instance,of)
 
  integer,      intent(in) :: &
    instance, &
    of
 
  real(preal), dimension(param(instance)%sum_N_sl) :: &
    dislocationspacing
 
  associate(prm => param(instance), stt => state(instance),dst => dependentstate(instance))
 
  dislocationspacing = sqrt(matmul(prm%forestProjection,stt%rho_mob(:,of)+stt%rho_dip(:,of)))
  dst%threshold_stress(:,of) = prm%mu*prm%b_sl &
                             * sqrt(matmul(prm%h_sl_sl,stt%rho_mob(:,of)+stt%rho_dip(:,of)))
 
  dst%Lambda_sl(:,of) = prm%D/(1.0_preal+prm%D*dislocationspacing/prm%i_sl)
 
  end associate
 
end subroutine plastic_disloucla_dependentstate
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine plastic_disloucla_results(instance,group)
 
  integer,          intent(in) :: instance
  character(len=*), intent(in) :: group
 
  integer :: o
 
  associate(prm => param(instance), stt => state(instance), dst => dependentstate(instance))
  outputsloop: do o = 1,size(prm%output)
    select case(trim(prm%output(o)))
      case('edge_density')                                                                          ! ToDo: should be rho_mob
        if(prm%sum_N_sl>0) call results_writedataset(group,stt%rho_mob,'rho_mob',&
                                                     'mobile dislocation density','1/m²')
      case('dipole_density')                                                                        ! ToDo: should be rho_dip
        if(prm%sum_N_sl>0) call results_writedataset(group,stt%rho_dip,'rho_dip',&
                                                     'dislocation dipole density''1/m²')
      case('shear_rate_slip')                                                                       ! should be gamma
        if(prm%sum_N_sl>0) call results_writedataset(group,stt%gamma_sl,'dot_gamma_sl',&            ! this is not dot!!
                                                     'plastic shear','1')
      case('mfp_slip')                                                                              !ToDo: should be Lambda
        if(prm%sum_N_sl>0) call results_writedataset(group,dst%Lambda_sl,'Lambda_sl',&
                                                     'mean free path for slip','m')
      case('threshold_stress_slip')                                                                 !ToDo: should be tau_pass
        if(prm%sum_N_sl>0) call results_writedataset(group,dst%threshold_stress,'tau_pass',&
                                                     'threshold stress for slip','Pa')
    end select
  enddo outputsloop
  end associate
 
end subroutine plastic_disloucla_results
 
 
!--------------------------------------------------------------------------------------------------
!         stress, and the resolved stress.
! NOTE: Against the common convention, the result (i.e. intent(out)) variables are the last to
! have the optional arguments at the end
!--------------------------------------------------------------------------------------------------
pure subroutine kinetics(Mp,T,instance,of, &
                 dot_gamma_pos,dot_gamma_neg,ddot_gamma_dtau_pos,ddot_gamma_dtau_neg,tau_pos_out,tau_neg_out)
 
  real(preal), dimension(3,3),  intent(in) :: &
    mp
  real(preal),                  intent(in) :: &
    t
  integer,                      intent(in) :: &
    instance, &
    of
 
  real(preal),                  intent(out), dimension(param(instance)%sum_N_sl) :: &
    dot_gamma_pos, &
    dot_gamma_neg
  real(preal),                  intent(out), optional, dimension(param(instance)%sum_N_sl) :: &
    ddot_gamma_dtau_pos, &
    ddot_gamma_dtau_neg, &
    tau_pos_out, &
    tau_neg_out
  real(preal), dimension(param(instance)%sum_N_sl) :: &
    stressratio, &
    stressratio_p,stressratio_pminus1, &
    dvel, vel, &
    tau_pos,tau_neg, &
    t_n, t_k, dtk,dtn, &
    needsgoodname                                                                                   ! ToDo: @Karo: any idea?
  integer :: j
 
  associate(prm => param(instance), stt => state(instance), dst => dependentstate(instance))
 
  do j = 1, prm%sum_N_sl
    tau_pos(j) = math_tensordot(mp,prm%nonSchmid_pos(1:3,1:3,j))
    tau_neg(j) = math_tensordot(mp,prm%nonSchmid_neg(1:3,1:3,j))
  enddo
 
 
  if (present(tau_pos_out)) tau_pos_out = tau_pos
  if (present(tau_neg_out)) tau_neg_out = tau_neg
 
  associate(boltzmannratio  => prm%delta_F/(kb*t), &
            dot_gamma_0     => stt%rho_mob(:,of)*prm%b_sl*prm%v0, &
            effectivelength => dst%Lambda_sl(:,of) - prm%w)
 
  significantpositivetau: where(abs(tau_pos)-dst%threshold_stress(:,of) > tol_math_check)
    stressratio = (abs(tau_pos)-dst%threshold_stress(:,of))/prm%tau_0
    stressratio_p       = stressratio** prm%p
    stressratio_pminus1 = stressratio**(prm%p-1.0_preal)
    needsgoodname       = exp(-boltzmannratio*(1-stressratio_p) ** prm%q)
 
    t_n = prm%b_sl/(needsgoodname*prm%omega*effectivelength)
    t_k = effectivelength * prm%B /(2.0_preal*prm%b_sl*tau_pos)
 
    vel = prm%kink_height/(t_n + t_k)
 
    dot_gamma_pos = dot_gamma_0 * sign(vel,tau_pos) * 0.5_preal
  else where significantpositivetau
    dot_gamma_pos = 0.0_preal
  end where significantpositivetau
 
  if (present(ddot_gamma_dtau_pos)) then
    significantpositivetau2: where(abs(tau_pos)-dst%threshold_stress(:,of) > tol_math_check)
      dtn = -1.0_preal * t_n * boltzmannratio * prm%p * prm%q * (1.0_preal-stressratio_p)**(prm%q - 1.0_preal) &
          * (stressratio)**(prm%p - 1.0_preal) / prm%tau_0
      dtk = -1.0_preal * t_k / tau_pos
 
      dvel = -1.0_preal * prm%kink_height * (dtk + dtn) / (t_n + t_k)**2.0_preal
 
      ddot_gamma_dtau_pos = dot_gamma_0 * dvel* 0.5_preal
    else where significantpositivetau2
      ddot_gamma_dtau_pos = 0.0_preal
    end where significantpositivetau2
  endif
 
  significantnegativetau: where(abs(tau_neg)-dst%threshold_stress(:,of) > tol_math_check)
    stressratio = (abs(tau_neg)-dst%threshold_stress(:,of))/prm%tau_0
    stressratio_p       = stressratio** prm%p
    stressratio_pminus1 = stressratio**(prm%p-1.0_preal)
    needsgoodname       = exp(-boltzmannratio*(1-stressratio_p) ** prm%q)
 
    t_n = prm%b_sl/(needsgoodname*prm%omega*effectivelength)
    t_k = effectivelength * prm%B /(2.0_preal*prm%b_sl*tau_pos)
 
    vel = prm%kink_height/(t_n + t_k)
 
    dot_gamma_neg = dot_gamma_0 * sign(vel,tau_neg) * 0.5_preal
  else where significantnegativetau
    dot_gamma_neg = 0.0_preal
  end where significantnegativetau
 
  if (present(ddot_gamma_dtau_neg)) then
    significantnegativetau2: where(abs(tau_neg)-dst%threshold_stress(:,of) > tol_math_check)
      dtn = -1.0_preal * t_n * boltzmannratio * prm%p * prm%q * (1.0_preal-stressratio_p)**(prm%q - 1.0_preal) &
          * (stressratio)**(prm%p - 1.0_preal) / prm%tau_0
      dtk = -1.0_preal * t_k / tau_neg
 
      dvel = -1.0_preal * prm%kink_height * (dtk + dtn) / (t_n + t_k)**2.0_preal
 
      ddot_gamma_dtau_neg = dot_gamma_0 * dvel * 0.5_preal
    else where significantnegativetau2
      ddot_gamma_dtau_neg = 0.0_preal
    end where significantnegativetau2
  end if
 
  end associate
  end associate
 
end subroutine kinetics
 
end submodule plastic_disloucla
# 43 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_nonlocal.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
submodule(constitutive) plastic_nonlocal
  use geometry_plastic_nonlocal, only: &
    nipneighbors    => geometry_plastic_nonlocal_nipneighbors, &
    ipneighborhood  => geometry_plastic_nonlocal_ipneighborhood, &
    ipvolume        => geometry_plastic_nonlocal_ipvolume0, &
    iparea          => geometry_plastic_nonlocal_iparea0, &
    ipareanormal    => geometry_plastic_nonlocal_ipareanormal0
 
  real(preal), parameter :: &
    kb = 1.38e-23_preal                                                                             
 
  ! storage order of dislocation types
  integer, dimension(8), parameter :: &
    sgl = [1,2,3,4,5,6,7,8]
  integer, dimension(5), parameter :: &
    edg = [1,2,5,6,9], &                                                                            !< edge
    scr = [3,4,7,8,10]                                                                              
  integer, dimension(4), parameter :: &
    mob = [1,2,3,4], &                                                                              !< mobile
    imm = [5,6,7,8]                                                                                 
  integer, dimension(2), parameter :: &
    dip = [9,10], &                                                                                 !< dipole
    imm_edg = imm(1:2), &                                                                           
    imm_scr = imm(3:4)                                                                              
  integer, parameter :: &
    mob_edg_pos = 1, &                                                                              !< mobile edge positive
    mob_edg_neg = 2, &                                                                              
    mob_scr_pos = 3, &                                                                              
    mob_scr_neg = 4                                                                                 
 
  ! BEGIN DEPRECATED
  integer, dimension(:,:,:), allocatable :: &
    irhou, &                                                                                        !< state indices for unblocked density
    iv, &                                                                                           !< state indices for dislcation velocities
    id
  !END DEPRECATED
 
  real(preal), dimension(:,:,:,:,:,:), allocatable :: &
    compatibility
 
  type :: tinitialparameters                                                                        
    real(preal) :: &
      rhosglscatter, &                                                                              !< standard deviation of scatter in initial dislocation density
      rhosglrandom, &
      rhosglrandombinning
    real(preal), dimension(:), allocatable :: &
      rhosgledgepos0, &                                                                             !< initial edge_pos dislocation density
      rhosgledgeneg0, &                                                                             !< initial edge_neg dislocation density
      rhosglscrewpos0, &                                                                            !< initial screw_pos dislocation density
      rhosglscrewneg0, &                                                                            !< initial screw_neg dislocation density
      rhodipedge0, &                                                                                !< initial edge dipole dislocation density
      rhodipscrew0
    integer,     dimension(:) ,allocatable :: &
      n_sl
  end type tinitialparameters
 
  type :: tparameters                                                                               
    real(preal) :: &
      atomicvolume, &                                                                               !< atomic volume
      dsd0, &                                                                                       !< prefactor for self-diffusion coefficient
      selfdiffusionenergy, &                                                                        !< activation enthalpy for diffusion
      atol_rho, &                                                                                   !< absolute tolerance for dislocation density in state integration
      significantrho, &                                                                             !< density considered significant
      significantn, &                                                                               !< number of dislocations considered significant
      doublekinkwidth, &                                                                            !< width of a doubkle kink in multiples of the burgers vector length b
      solidsolutionenergy, &                                                                        !< activation energy for solid solution in J
      solidsolutionsize, &                                                                          !< solid solution obstacle size in multiples of the burgers vector length
      solidsolutionconcentration, &                                                                 !< concentration of solid solution in atomic parts
      p, &                                                                                          !< parameter for kinetic law (Kocks,Argon,Ashby)
      q, &                                                                                          !< parameter for kinetic law (Kocks,Argon,Ashby)
      viscosity, &                                                                                  !< viscosity for dislocation glide in Pa s
      fattack, &                                                                                    !< attack frequency in Hz
      surfacetransmissivity, &                                                                      !< transmissivity at free surface
      grainboundarytransmissivity, &                                                                !< transmissivity at grain boundary (identified by different texture)
      cflfactor, &                                                                                  !< safety factor for CFL flux condition
      fedgemultiplication, &                                                                        !< factor that determines how much edge dislocations contribute to multiplication (0...1)
      linetensioneffect, &
      edgejogfactor, &
      mu, &
      nu
    real(preal), dimension(:),      allocatable :: &
      mindipoleheight_edge, &                                                                       !< minimum stable edge dipole height
      mindipoleheight_screw, &                                                                      !< minimum stable screw dipole height
      peierlsstress_edge, &
      peierlsstress_screw, &
      lambda0, &                                                                                    !< mean free path prefactor for each
      burgers
    real(preal), dimension(:,:),   allocatable :: &
      slip_normal, &
      slip_direction, &
      slip_transverse, &
      mindipoleheight, &                                                                            ! edge and screw
      peierlsstress, &                                                                              ! edge and screw
      interactionslipslip ,&                                                                        !< coefficients for slip-slip interaction
      forestprojection_edge, &                                                                      !< matrix of forest projections of edge dislocations
      forestprojection_screw
    real(preal), dimension(:,:,:), allocatable :: &
      schmid, &                                                                                     !< Schmid contribution
      nonschmid_pos, &
      nonschmid_neg
    integer :: &
      sum_n_sl
    integer,     dimension(:),     allocatable :: &
      colinearsystem
    character(len=pStringLen), dimension(:), allocatable :: &
      output
    logical :: &
      shortrangestresscorrection, &                                                                 !< use of short range stress correction by excess density gradient term
      nonschmidactive = .false.
  end type tparameters
 
  type :: tnonlocalmicrostructure
    real(preal), allocatable, dimension(:,:) :: &
     tau_pass, &
     tau_back
  end type tnonlocalmicrostructure
 
  type :: tnonlocalstate
    real(preal), pointer, dimension(:,:) :: &
      rho, &                                                                                        ! < all dislocations
        rhosgl, &
          rhosglmobile, &                       ! iRhoU
            rho_sgl_mob_edg_pos, &
            rho_sgl_mob_edg_neg, &
            rho_sgl_mob_scr_pos, &
            rho_sgl_mob_scr_neg, &
          rhosglimmobile, &
            rho_sgl_imm_edg_pos, &
            rho_sgl_imm_edg_neg, &
            rho_sgl_imm_scr_pos, &
            rho_sgl_imm_scr_neg, &
        rhodip, &
          rho_dip_edg, &
          rho_dip_scr, &
        rho_forest, &
      gamma, &
      v, &
          v_edg_pos, &
          v_edg_neg, &
          v_scr_pos, &
          v_scr_neg
  end type tnonlocalstate
 
  type(tnonlocalstate), allocatable, dimension(:) :: &
    deltastate, &
    dotstate, &
    state, &
    state0
 
  type(tparameters), dimension(:), allocatable :: param
 
  type(tnonlocalmicrostructure), dimension(:), allocatable :: microstructure
 
contains
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine plastic_nonlocal_init
 
  integer :: &
    ninstance, &
    p, &
    nipcmyphase, &
    sizestate, sizedotstate, sizedependentstate, sizedeltastate, &
    s1, s2, &
    s, t, l
  real(preal), dimension(:), allocatable :: &
    a
  character(len=pStringLen) :: &
    extmsg  = ''
  type(tinitialparameters) :: &
    ini
 
  write(6,'(/,a)') ' <<<+-  constitutive_'//plasticity_nonlocal_label//' init  -+>>>'; flush(6)
 
  write(6,'(/,a)') ' Reuber et al., Acta Materialia 71:333–348, 2014'
  write(6,'(a)')   ' https://doi.org/10.1016/j.actamat.2014.03.012'
 
  write(6,'(/,a)') ' Kords, Dissertation RWTH Aachen, 2014'
  write(6,'(a)')   ' http://publications.rwth-aachen.de/record/229993'
 
  ninstance = count(phase_plasticity == plasticity_nonlocal_id)
  if (iand(debug_level(debug_constitutive),debug_levelbasic) /= 0) &
    write(6,'(a16,1x,i5,/)') '# instances:',ninstance
 
  allocate(param(ninstance))
  allocate(state(ninstance))
  allocate(state0(ninstance))
  allocate(dotstate(ninstance))
  allocate(deltastate(ninstance))
  allocate(microstructure(ninstance))
 
  do p=1, size(config_phase)
    if (phase_plasticity(p) /= plasticity_nonlocal_id) cycle
 
    associate(prm => param(phase_plasticityinstance(p)), &
              dot => dotstate(phase_plasticityinstance(p)), &
              stt => state(phase_plasticityinstance(p)), &
              st0 => state0(phase_plasticityinstance(p)), &
              del => deltastate(phase_plasticityinstance(p)), &
              dst => microstructure(phase_plasticityinstance(p)), &
              config => config_phase(p))
 
    prm%output = config%getStrings('(output)',defaultval=emptystringarray)
 
    prm%atol_rho   = config%getFloat('atol_rho',defaultval=1.0e4_preal)
 
    ! This data is read in already in lattice
    prm%mu = lattice_mu(p)
    prm%nu = lattice_nu(p)
 
    ini%N_sl     = config%getInts('nslip',defaultval=emptyintarray)
    prm%sum_N_sl = sum(abs(ini%N_sl))
    slipactive: if (prm%sum_N_sl > 0) then
      prm%Schmid = lattice_schmidmatrix_slip(ini%N_sl,config%getString('lattice_structure'),&
                                             config%getFloat('c/a',defaultval=0.0_preal))
 
      if(trim(config%getString('lattice_structure')) == 'bcc') then
        a = config%getFloats('nonschmid_coefficients',defaultval = emptyrealarray)
        if(size(a) > 0) prm%nonSchmidActive = .true.
        prm%nonSchmid_pos  = lattice_nonschmidmatrix(ini%N_sl,a,+1)
        prm%nonSchmid_neg  = lattice_nonschmidmatrix(ini%N_sl,a,-1)
      else
        prm%nonSchmid_pos  = prm%Schmid
        prm%nonSchmid_neg  = prm%Schmid
      endif
 
      prm%interactionSlipSlip = lattice_interaction_slipbyslip(ini%N_sl, &
                                                               config%getFloats('interaction_slipslip'), &
                                                               config%getString('lattice_structure'))
 
      prm%forestProjection_edge  = lattice_forestprojection_edge(ini%N_sl,config%getString('lattice_structure'),&
                                                                  config%getFloat('c/a',defaultval=0.0_preal))
      prm%forestProjection_screw = lattice_forestprojection_screw(ini%N_sl,config%getString('lattice_structure'),&
                                                                  config%getFloat('c/a',defaultval=0.0_preal))
 
      prm%slip_direction  = lattice_slip_direction(ini%N_sl,config%getString('lattice_structure'),&
                                                    config%getFloat('c/a',defaultval=0.0_preal))
      prm%slip_transverse = lattice_slip_transverse(ini%N_sl,config%getString('lattice_structure'),&
                                                    config%getFloat('c/a',defaultval=0.0_preal))
      prm%slip_normal     = lattice_slip_normal(ini%N_sl,config%getString('lattice_structure'),&
                                                    config%getFloat('c/a',defaultval=0.0_preal))
 
      ! collinear systems (only for octahedral slip systems in fcc)
      allocate(prm%colinearSystem(prm%sum_N_sl), source = -1)
      do s1 = 1, prm%sum_N_sl
        do s2 = 1, prm%sum_N_sl
           if (all(deq0(math_cross(prm%slip_direction(1:3,s1),prm%slip_direction(1:3,s2)))) .and. &
               any(dneq0(math_cross(prm%slip_normal   (1:3,s1),prm%slip_normal   (1:3,s2))))) &
             prm%colinearSystem(s1) = s2
        enddo
      enddo
 
      ini%rhoSglEdgePos0  = config%getFloats('rhosgledgepos0',   requiredsize=size(ini%N_sl))
      ini%rhoSglEdgeNeg0  = config%getFloats('rhosgledgeneg0',   requiredsize=size(ini%N_sl))
      ini%rhoSglScrewPos0 = config%getFloats('rhosglscrewpos0',  requiredsize=size(ini%N_sl))
      ini%rhoSglScrewNeg0 = config%getFloats('rhosglscrewneg0',  requiredsize=size(ini%N_sl))
      ini%rhoDipEdge0     = config%getFloats('rhodipedge0',      requiredsize=size(ini%N_sl))
      ini%rhoDipScrew0    = config%getFloats('rhodipscrew0',     requiredsize=size(ini%N_sl))
 
      prm%lambda0         = config%getFloats('lambda0',          requiredsize=size(ini%N_sl))
      prm%burgers         = config%getFloats('burgers',          requiredsize=size(ini%N_sl))
 
      prm%lambda0 = math_expand(prm%lambda0,ini%N_sl)
      prm%burgers = math_expand(prm%burgers,ini%N_sl)
 
      prm%minDipoleHeight_edge  = config%getFloats('minimumdipoleheightedge',  requiredsize=size(ini%N_sl))
      prm%minDipoleHeight_screw = config%getFloats('minimumdipoleheightscrew', requiredsize=size(ini%N_sl))
      prm%minDipoleHeight_edge  = math_expand(prm%minDipoleHeight_edge, ini%N_sl)
      prm%minDipoleHeight_screw = math_expand(prm%minDipoleHeight_screw,ini%N_sl)
      allocate(prm%minDipoleHeight(prm%sum_N_sl,2))
      prm%minDipoleHeight(:,1)  = prm%minDipoleHeight_edge
      prm%minDipoleHeight(:,2)  = prm%minDipoleHeight_screw
 
      prm%peierlsstress_edge    = config%getFloats('peierlsstressedge',        requiredsize=size(ini%N_sl))
      prm%peierlsstress_screw   = config%getFloats('peierlsstressscrew',       requiredsize=size(ini%N_sl))
      prm%peierlsstress_edge    = math_expand(prm%peierlsstress_edge, ini%N_sl)
      prm%peierlsstress_screw   = math_expand(prm%peierlsstress_screw,ini%N_sl)
      allocate(prm%peierlsstress(prm%sum_N_sl,2))
      prm%peierlsstress(:,1)    = prm%peierlsstress_edge
      prm%peierlsstress(:,2)    = prm%peierlsstress_screw
 
      prm%significantRho              = config%getFloat('significantrho')
      prm%significantN                = config%getFloat('significantn', 0.0_preal)
      prm%CFLfactor                   = config%getFloat('cflfactor',defaultval=2.0_preal)
 
      prm%atomicVolume                = config%getFloat('atomicvolume')
      prm%Dsd0                        = config%getFloat('selfdiffusionprefactor') !,'dsd0'
      prm%selfDiffusionEnergy         = config%getFloat('selfdiffusionenergy') !,'qsd'
      prm%linetensionEffect           = config%getFloat('linetension')
      prm%edgeJogFactor               = config%getFloat('edgejog')!,'edgejogs'
      prm%doublekinkwidth             = config%getFloat('doublekinkwidth')
      prm%solidSolutionEnergy         = config%getFloat('solidsolutionenergy')
      prm%solidSolutionSize           = config%getFloat('solidsolutionsize')
      prm%solidSolutionConcentration  = config%getFloat('solidsolutionconcentration')
 
      prm%p                           = config%getFloat('p')
      prm%q                           = config%getFloat('q')
      prm%viscosity                   = config%getFloat('viscosity')
      prm%fattack                     = config%getFloat('attackfrequency')
 
      ! ToDo: discuss logic
      ini%rhoSglScatter               = config%getFloat('rhosglscatter')
      ini%rhoSglRandom                = config%getFloat('rhosglrandom',0.0_preal)
      if (config%keyExists('/rhosglrandom/')) &
        ini%rhoSglRandomBinning       = config%getFloat('rhosglrandombinning',0.0_preal) !ToDo: useful default?
     ! if (rhoSglRandom(instance) < 0.0_pReal) &
     ! if (rhoSglRandomBinning(instance) <= 0.0_pReal) &
 
      prm%surfaceTransmissivity       = config%getFloat('surfacetransmissivity',defaultval=1.0_preal)
      prm%grainboundaryTransmissivity = config%getFloat('grainboundarytransmissivity',defaultval=-1.0_preal)
      prm%fEdgeMultiplication         = config%getFloat('edgemultiplication')
      prm%shortRangeStressCorrection  = config%keyExists('/shortrangestresscorrection/')
 
!--------------------------------------------------------------------------------------------------
!  sanity checks
      if (any(prm%burgers          <  0.0_preal)) extmsg = trim(extmsg)//' burgers'
      if (any(prm%lambda0          <= 0.0_preal)) extmsg = trim(extmsg)//' lambda0'
 
      if (any(ini%rhoSglEdgePos0   <  0.0_preal)) extmsg = trim(extmsg)//' rhoSglEdgePos0'
      if (any(ini%rhoSglEdgeNeg0   <  0.0_preal)) extmsg = trim(extmsg)//' rhoSglEdgeNeg0'
      if (any(ini%rhoSglScrewPos0  <  0.0_preal)) extmsg = trim(extmsg)//' rhoSglScrewPos0'
      if (any(ini%rhoSglScrewNeg0  <  0.0_preal)) extmsg = trim(extmsg)//' rhoSglScrewNeg0'
      if (any(ini%rhoDipEdge0      <  0.0_preal)) extmsg = trim(extmsg)//' rhoDipEdge0'
      if (any(ini%rhoDipScrew0     <  0.0_preal)) extmsg = trim(extmsg)//' rhoDipScrew0'
 
      if (any(prm%peierlsstress    <  0.0_preal)) extmsg = trim(extmsg)//' peierlsstress'
      if (any(prm%minDipoleHeight  <  0.0_preal)) extmsg = trim(extmsg)//' minDipoleHeight'
 
      if (prm%viscosity           <= 0.0_preal)   extmsg = trim(extmsg)//' viscosity'
      if (prm%selfDiffusionEnergy <= 0.0_preal)   extmsg = trim(extmsg)//' selfDiffusionEnergy'
      if (prm%fattack             <= 0.0_preal)   extmsg = trim(extmsg)//' fattack'
      if (prm%doublekinkwidth     <= 0.0_preal)   extmsg = trim(extmsg)//' doublekinkwidth'
      if (prm%Dsd0                < 0.0_preal)    extmsg = trim(extmsg)//' Dsd0'
      if (prm%atomicVolume        <= 0.0_preal)   extmsg = trim(extmsg)//' atomicVolume'            ! ToDo: in disloUCLA, the atomic volume is given as a factor
 
      if (prm%significantN         < 0.0_preal)   extmsg = trim(extmsg)//' significantN'
      if (prm%significantrho       < 0.0_preal)   extmsg = trim(extmsg)//' significantrho'
      if (prm%atol_rho             < 0.0_preal)   extmsg = trim(extmsg)//' atol_rho'
      if (prm%CFLfactor            < 0.0_preal)   extmsg = trim(extmsg)//' CFLfactor'
 
      if (prm%p <= 0.0_preal .or. prm%p > 1.0_preal) extmsg = trim(extmsg)//' p'
      if (prm%q <  1.0_preal .or. prm%q > 2.0_preal) extmsg = trim(extmsg)//' q'
 
      if (prm%linetensionEffect <  0.0_preal .or. prm%linetensionEffect  > 1.0_preal) &
                                                  extmsg = trim(extmsg)//' linetensionEffect'
      if (prm%edgeJogFactor     <  0.0_preal .or. prm%edgeJogFactor      > 1.0_preal) &
                                                  extmsg = trim(extmsg)//' edgeJogFactor'
 
      if (prm%solidSolutionEnergy        <= 0.0_preal) extmsg = trim(extmsg)//' solidSolutionEnergy'
      if (prm%solidSolutionSize          <= 0.0_preal) extmsg = trim(extmsg)//' solidSolutionSize'
      if (prm%solidSolutionConcentration <= 0.0_preal) extmsg = trim(extmsg)//' solidSolutionConcentration'
 
      if (prm%grainboundaryTransmissivity  > 1.0_preal) extmsg = trim(extmsg)//' grainboundaryTransmissivity'
      if (prm%surfaceTransmissivity  <  0.0_preal .or. prm%surfaceTransmissivity  > 1.0_preal) &
                                                        extmsg = trim(extmsg)//' surfaceTransmissivity'
 
      if (prm%fEdgeMultiplication  <  0.0_preal .or. prm%fEdgeMultiplication  > 1.0_preal) &
        extmsg = trim(extmsg)//' fEdgeMultiplication'
 
    endif slipactive
 
!--------------------------------------------------------------------------------------------------
! allocate state arrays
    nipcmyphase  = count(material_phaseat==p) * discretization_nip
    sizedotstate = size([   'rhoSglEdgePosMobile   ','rhoSglEdgeNegMobile   ', &
                            'rhoSglScrewPosMobile  ','rhoSglScrewNegMobile  ', &
                            'rhoSglEdgePosImmobile ','rhoSglEdgeNegImmobile ', &
                            'rhoSglScrewPosImmobile','rhoSglScrewNegImmobile', &
                            'rhoDipEdge            ','rhoDipScrew           ', &
                            'gamma                 ' ]) * prm%sum_N_sl                              
    sizedependentstate = size([ 'rhoForest   ']) * prm%sum_N_sl                                     
    sizestate          = sizedotstate + sizedependentstate &
                       + size([ 'velocityEdgePos     ','velocityEdgeNeg     ', &
                                'velocityScrewPos    ','velocityScrewNeg    ', &
                                'maxDipoleHeightEdge ','maxDipoleHeightScrew' ]) * prm%sum_N_sl     
    sizedeltastate            = sizedotstate
 
    call material_allocateplasticstate(p,nipcmyphase,sizestate,sizedotstate,sizedeltastate)
 
    plasticstate(p)%nonlocal = .true.
    plasticstate(p)%offsetDeltaState = 0                                                            ! ToDo: state structure does not follow convention
 
    st0%rho => plasticstate(p)%state0                             (0*prm%sum_N_sl+1:10*prm%sum_N_sl,:)
    stt%rho => plasticstate(p)%state                              (0*prm%sum_N_sl+1:10*prm%sum_N_sl,:)
    dot%rho => plasticstate(p)%dotState                           (0*prm%sum_N_sl+1:10*prm%sum_N_sl,:)
    del%rho => plasticstate(p)%deltaState                         (0*prm%sum_N_sl+1:10*prm%sum_N_sl,:)
    plasticstate(p)%atol(1:10*prm%sum_N_sl) = prm%atol_rho
 
      stt%rhoSgl => plasticstate(p)%state                         (0*prm%sum_N_sl+1: 8*prm%sum_N_sl,:)
      dot%rhoSgl => plasticstate(p)%dotState                      (0*prm%sum_N_sl+1: 8*prm%sum_N_sl,:)
      del%rhoSgl => plasticstate(p)%deltaState                    (0*prm%sum_N_sl+1: 8*prm%sum_N_sl,:)
 
        stt%rhoSglMobile => plasticstate(p)%state                 (0*prm%sum_N_sl+1: 4*prm%sum_N_sl,:)
        dot%rhoSglMobile => plasticstate(p)%dotState              (0*prm%sum_N_sl+1: 4*prm%sum_N_sl,:)
        del%rhoSglMobile => plasticstate(p)%deltaState            (0*prm%sum_N_sl+1: 4*prm%sum_N_sl,:)
 
            stt%rho_sgl_mob_edg_pos => plasticstate(p)%state      (0*prm%sum_N_sl+1: 1*prm%sum_N_sl,:)
            dot%rho_sgl_mob_edg_pos => plasticstate(p)%dotState   (0*prm%sum_N_sl+1: 1*prm%sum_N_sl,:)
            del%rho_sgl_mob_edg_pos => plasticstate(p)%deltaState (0*prm%sum_N_sl+1: 1*prm%sum_N_sl,:)
 
            stt%rho_sgl_mob_edg_neg => plasticstate(p)%state      (1*prm%sum_N_sl+1: 2*prm%sum_N_sl,:)
            dot%rho_sgl_mob_edg_neg => plasticstate(p)%dotState   (1*prm%sum_N_sl+1: 2*prm%sum_N_sl,:)
            del%rho_sgl_mob_edg_neg => plasticstate(p)%deltaState (1*prm%sum_N_sl+1: 2*prm%sum_N_sl,:)
 
            stt%rho_sgl_mob_scr_pos => plasticstate(p)%state      (2*prm%sum_N_sl+1: 3*prm%sum_N_sl,:)
            dot%rho_sgl_mob_scr_pos => plasticstate(p)%dotState   (2*prm%sum_N_sl+1: 3*prm%sum_N_sl,:)
            del%rho_sgl_mob_scr_pos => plasticstate(p)%deltaState (2*prm%sum_N_sl+1: 3*prm%sum_N_sl,:)
 
            stt%rho_sgl_mob_scr_neg => plasticstate(p)%state      (3*prm%sum_N_sl+1: 4*prm%sum_N_sl,:)
            dot%rho_sgl_mob_scr_neg => plasticstate(p)%dotState   (3*prm%sum_N_sl+1: 4*prm%sum_N_sl,:)
            del%rho_sgl_mob_scr_neg => plasticstate(p)%deltaState (3*prm%sum_N_sl+1: 4*prm%sum_N_sl,:)
 
        stt%rhoSglImmobile => plasticstate(p)%state               (4*prm%sum_N_sl+1: 8*prm%sum_N_sl,:)
        dot%rhoSglImmobile => plasticstate(p)%dotState            (4*prm%sum_N_sl+1: 8*prm%sum_N_sl,:)
        del%rhoSglImmobile => plasticstate(p)%deltaState          (4*prm%sum_N_sl+1: 8*prm%sum_N_sl,:)
 
            stt%rho_sgl_imm_edg_pos => plasticstate(p)%state      (4*prm%sum_N_sl+1: 5*prm%sum_N_sl,:)
            dot%rho_sgl_imm_edg_pos => plasticstate(p)%dotState   (4*prm%sum_N_sl+1: 5*prm%sum_N_sl,:)
            del%rho_sgl_imm_edg_pos => plasticstate(p)%deltaState (4*prm%sum_N_sl+1: 5*prm%sum_N_sl,:)
 
            stt%rho_sgl_imm_edg_neg => plasticstate(p)%state      (5*prm%sum_N_sl+1: 6*prm%sum_N_sl,:)
            dot%rho_sgl_imm_edg_neg => plasticstate(p)%dotState   (5*prm%sum_N_sl+1: 6*prm%sum_N_sl,:)
            del%rho_sgl_imm_edg_neg => plasticstate(p)%deltaState (5*prm%sum_N_sl+1: 6*prm%sum_N_sl,:)
 
            stt%rho_sgl_imm_scr_pos => plasticstate(p)%state      (6*prm%sum_N_sl+1: 7*prm%sum_N_sl,:)
            dot%rho_sgl_imm_scr_pos => plasticstate(p)%dotState   (6*prm%sum_N_sl+1: 7*prm%sum_N_sl,:)
            del%rho_sgl_imm_scr_pos => plasticstate(p)%deltaState (6*prm%sum_N_sl+1: 7*prm%sum_N_sl,:)
 
            stt%rho_sgl_imm_scr_neg => plasticstate(p)%state      (7*prm%sum_N_sl+1: 8*prm%sum_N_sl,:)
            dot%rho_sgl_imm_scr_neg => plasticstate(p)%dotState   (7*prm%sum_N_sl+1: 8*prm%sum_N_sl,:)
            del%rho_sgl_imm_scr_neg => plasticstate(p)%deltaState (7*prm%sum_N_sl+1: 8*prm%sum_N_sl,:)
 
      stt%rhoDip => plasticstate(p)%state                         (8*prm%sum_N_sl+1:10*prm%sum_N_sl,:)
      dot%rhoDip => plasticstate(p)%dotState                      (8*prm%sum_N_sl+1:10*prm%sum_N_sl,:)
      del%rhoDip => plasticstate(p)%deltaState                    (8*prm%sum_N_sl+1:10*prm%sum_N_sl,:)
 
        stt%rho_dip_edg => plasticstate(p)%state                  (8*prm%sum_N_sl+1: 9*prm%sum_N_sl,:)
        dot%rho_dip_edg => plasticstate(p)%dotState               (8*prm%sum_N_sl+1: 9*prm%sum_N_sl,:)
        del%rho_dip_edg => plasticstate(p)%deltaState             (8*prm%sum_N_sl+1: 9*prm%sum_N_sl,:)
 
        stt%rho_dip_scr => plasticstate(p)%state                  (9*prm%sum_N_sl+1:10*prm%sum_N_sl,:)
        dot%rho_dip_scr => plasticstate(p)%dotState               (9*prm%sum_N_sl+1:10*prm%sum_N_sl,:)
        del%rho_dip_scr => plasticstate(p)%deltaState             (9*prm%sum_N_sl+1:10*prm%sum_N_sl,:)
 
    stt%gamma => plasticstate(p)%state                      (10*prm%sum_N_sl + 1:11*prm%sum_N_sl,1:nipcmyphase)
    dot%gamma => plasticstate(p)%dotState                   (10*prm%sum_N_sl + 1:11*prm%sum_N_sl,1:nipcmyphase)
    del%gamma => plasticstate(p)%deltaState                 (10*prm%sum_N_sl + 1:11*prm%sum_N_sl,1:nipcmyphase)
    plasticstate(p)%atol(10*prm%sum_N_sl+1:11*prm%sum_N_sl )  = config%getFloat('atol_gamma', defaultval = 1.0e-2_preal)
    if(any(plasticstate(p)%atol(10*prm%sum_N_sl+1:11*prm%sum_N_sl) < 0.0_preal)) &
      extmsg = trim(extmsg)//' atol_gamma'
    plasticstate(p)%slipRate => plasticstate(p)%dotState    (10*prm%sum_N_sl + 1:11*prm%sum_N_sl,1:nipcmyphase)
 
    stt%rho_forest => plasticstate(p)%state                 (11*prm%sum_N_sl + 1:12*prm%sum_N_sl,1:nipcmyphase)
    stt%v          => plasticstate(p)%state                 (12*prm%sum_N_sl + 1:16*prm%sum_N_sl,1:nipcmyphase)
        stt%v_edg_pos  => plasticstate(p)%state             (12*prm%sum_N_sl + 1:13*prm%sum_N_sl,1:nipcmyphase)
        stt%v_edg_neg  => plasticstate(p)%state             (13*prm%sum_N_sl + 1:14*prm%sum_N_sl,1:nipcmyphase)
        stt%v_scr_pos  => plasticstate(p)%state             (14*prm%sum_N_sl + 1:15*prm%sum_N_sl,1:nipcmyphase)
        stt%v_scr_neg  => plasticstate(p)%state             (15*prm%sum_N_sl + 1:16*prm%sum_N_sl,1:nipcmyphase)
 
    allocate(dst%tau_pass(prm%sum_N_sl,nipcmyphase),source=0.0_preal)
    allocate(dst%tau_back(prm%sum_N_sl,nipcmyphase),source=0.0_preal)
    end associate
 
    if (nipcmyphase > 0) call stateinit(ini,p,nipcmyphase)
    plasticstate(p)%state0 = plasticstate(p)%state
 
!--------------------------------------------------------------------------------------------------
!  exit if any parameter is out of range
    if (extmsg /= '') call io_error(211,ext_msg=trim(extmsg)//'('//plasticity_nonlocal_label//')')
 
  enddo
 
  allocate(compatibility(2,maxval(param%sum_N_sl),maxval(param%sum_N_sl),nipneighbors,&
                         discretization_nip,discretization_nelem), source=0.0_preal)
 
! BEGIN DEPRECATED----------------------------------------------------------------------------------
  allocate(irhou(maxval(param%sum_N_sl),4,ninstance), source=0)
  allocate(iv(maxval(param%sum_N_sl),4,ninstance),    source=0)
  allocate(id(maxval(param%sum_N_sl),2,ninstance),    source=0)
 
  initializeinstances: do p = 1, size(phase_plasticity)
    nipcmyphase = count(material_phaseat==p) * discretization_nip
    myphase2: if (phase_plasticity(p) == plasticity_nonlocal_id) then
      l = 0
      do t = 1,4
        do s = 1,param(phase_plasticityinstance(p))%sum_N_sl
          l = l + 1
          irhou(s,t,phase_plasticityinstance(p)) = l
        enddo
      enddo
      l = l + (4+2+1+1)*param(phase_plasticityinstance(p))%sum_N_sl ! immobile(4), dipole(2), shear, forest
      do t = 1,4
        do s = 1,param(phase_plasticityinstance(p))%sum_N_sl
          l = l + 1
          iv(s,t,phase_plasticityinstance(p)) = l
        enddo
      enddo
      do t = 1,2
        do s = 1,param(phase_plasticityinstance(p))%sum_N_sl
          l = l + 1
          id(s,t,phase_plasticityinstance(p)) = l
        enddo
      enddo
      if (id(param(phase_plasticityinstance(p))%sum_N_sl,2,phase_plasticityinstance(p)) /= plasticstate(p)%sizeState) &
        call io_error(0, ext_msg = 'state indices not properly set ('//plasticity_nonlocal_label//')')
    endif myphase2
  enddo initializeinstances
 
end subroutine plastic_nonlocal_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine plastic_nonlocal_dependentstate(f, fp, instance, of, ip, el)
 
  real(preal), dimension(3,3), intent(in) :: &
    f, &
    fp
  integer, intent(in) :: &
    instance, &
    of, &
    ip, &
    el
 
  integer :: &
    no, &                                                                                           !< neighbor offset
    neighbor_el, &                                                                                  ! element number of neighboring material point
    neighbor_ip, &                                                                                  ! integration point of neighboring material point
    neighbor_instance, &                                                                            ! instance of this plasticity of neighboring material point
    c, &                                                                                            ! index of dilsocation character (edge, screw)
    s, &                                                                                            ! slip system index
    dir, &
    n
  real(preal) :: &
    fvsize, &
    nrealneighbors                                                                                  ! number of really existing neighbors
  integer, dimension(2) :: &
    neighbors
  real(preal), dimension(2) :: &
    rhoexcessgradient, &
    rhoexcessgradient_over_rho, &
    rhototal
  real(preal), dimension(3) :: &
    rhoexcessdifferences, &
    normal_latticeconf
  real(preal), dimension(3,3) :: &
    invfe, &                                                                                        !< inverse of elastic deformation gradient
    invfp, &                                                                                        !< inverse of plastic deformation gradient
    connections, &
    invconnections
  real(preal), dimension(3,nIPneighbors) :: &
    connection_latticeconf
  real(preal), dimension(2,param(instance)%sum_N_sl) :: &
    rhoexcess
  real(preal), dimension(param(instance)%sum_N_sl) :: &
    rho_edg_delta, &
    rho_scr_delta
  real(preal), dimension(param(instance)%sum_N_sl,10) :: &
    rho, &
    rho0, &
    rho_neighbor0
  real(preal), dimension(param(instance)%sum_N_sl,param(instance)%sum_N_sl) :: &
    myinteractionmatrix                                                                             ! corrected slip interaction matrix
  real(preal), dimension(param(instance)%sum_N_sl,nIPneighbors) :: &
    rho_edg_delta_neighbor, &
    rho_scr_delta_neighbor
  real(preal), dimension(2,maxval(param%sum_N_sl),nIPneighbors) :: &
    neighbor_rhoexcess, &                                                                           ! excess density at neighboring material point
    neighbor_rhototal                                                                               ! total density at neighboring material point
  real(preal), dimension(3,param(instance)%sum_N_sl,2) :: &
    m                                                                                               ! direction of dislocation motion
 
  associate(prm => param(instance),dst => microstructure(instance), stt => state(instance))
 
  rho = getrho(instance,of,ip,el)
 
  stt%rho_forest(:,of) = matmul(prm%forestProjection_Edge, sum(abs(rho(:,edg)),2)) &
                       + matmul(prm%forestProjection_Screw,sum(abs(rho(:,scr)),2))
 
 
  ! coefficients are corrected for the line tension effect
  ! (see Kubin,Devincre,Hoc; 2008; Modeling dislocation storage rates and mean free paths in face-centered cubic crystals)
  if (any(lattice_structure(material_phaseat(1,el)) == [lattice_bcc_id,lattice_fcc_id])) then
    myinteractionmatrix = prm%interactionSlipSlip &
                        * spread((  1.0_preal - prm%linetensionEffect &
                                   + prm%linetensionEffect &
                                   * log(0.35_preal * prm%burgers * sqrt(max(stt%rho_forest(:,of),prm%significantRho))) &
                                   / log(0.35_preal * prm%burgers * 1e6_preal))** 2.0_preal,2,prm%sum_N_sl)
  else
    myinteractionmatrix = prm%interactionSlipSlip
  endif
 
  dst%tau_pass(:,of) = prm%mu * prm%burgers &
                     * sqrt(matmul(myinteractionmatrix,sum(abs(rho),2)))
 
!*** calculate the dislocation stress of the neighboring excess dislocation densities
!*** zero for material points of local plasticity
 
  !#################################################################################################
  ! ToDo: MD: this is most likely only correct for F_i = I
  !#################################################################################################
 
  rho0 = getrho0(instance,of,ip,el)
  if (.not. phase_localplasticity(material_phaseat(1,el)) .and. prm%shortRangeStressCorrection) then
    invfp = math_inv33(fp)
    invfe = matmul(fp,math_inv33(f))
 
    rho_edg_delta = rho0(:,mob_edg_pos) - rho0(:,mob_edg_neg)
    rho_scr_delta = rho0(:,mob_scr_pos) - rho0(:,mob_scr_neg)
 
    rhoexcess(1,:) = rho_edg_delta
    rhoexcess(2,:) = rho_scr_delta
 
    fvsize = ipvolume(ip,el) ** (1.0_preal/3.0_preal)
 
    !* loop through my neighborhood and get the connection vectors (in lattice frame) and the excess densities
 
    nrealneighbors = 0.0_preal
    neighbor_rhototal = 0.0_preal
    do n = 1,nipneighbors
      neighbor_el = ipneighborhood(1,n,ip,el)
      neighbor_ip = ipneighborhood(2,n,ip,el)
      no = material_phasememberat(1,neighbor_ip,neighbor_el)
      if (neighbor_el > 0 .and. neighbor_ip > 0) then
        neighbor_instance = phase_plasticityinstance(material_phaseat(1,neighbor_el))
        if (neighbor_instance == instance) then
 
            nrealneighbors = nrealneighbors + 1.0_preal
            rho_neighbor0 = getrho0(instance,no,neighbor_ip,neighbor_el)
 
            rho_edg_delta_neighbor(:,n) = rho_neighbor0(:,mob_edg_pos) - rho_neighbor0(:,mob_edg_neg)
            rho_scr_delta_neighbor(:,n) = rho_neighbor0(:,mob_scr_pos) - rho_neighbor0(:,mob_scr_neg)
 
            neighbor_rhototal(1,:,n) = sum(abs(rho_neighbor0(:,edg)),2)
            neighbor_rhototal(2,:,n) = sum(abs(rho_neighbor0(:,scr)),2)
 
            connection_latticeconf(1:3,n) = matmul(invfe, discretization_ipcoords(1:3,neighbor_el+neighbor_ip-1) &
                                          - discretization_ipcoords(1:3,el+neighbor_ip-1))
            normal_latticeconf = matmul(transpose(invfp), ipareanormal(1:3,n,ip,el))
            if (math_inner(normal_latticeconf,connection_latticeconf(1:3,n)) < 0.0_preal) &         ! neighboring connection points in opposite direction to face normal: must be periodic image
              connection_latticeconf(1:3,n) = normal_latticeconf * ipvolume(ip,el)/iparea(n,ip,el)  ! instead take the surface normal scaled with the diameter of the cell
        else
          ! local neighbor or different lattice structure or different constitution instance -> use central values instead
          connection_latticeconf(1:3,n) = 0.0_preal
          rho_edg_delta_neighbor(:,n) = rho_edg_delta
          rho_scr_delta_neighbor(:,n) = rho_scr_delta
        endif
      else
        ! free surface -> use central values instead
        connection_latticeconf(1:3,n) = 0.0_preal
        rho_edg_delta_neighbor(:,n) = rho_edg_delta
        rho_scr_delta_neighbor(:,n) = rho_scr_delta
      endif
    enddo
 
    neighbor_rhoexcess(1,:,:) = rho_edg_delta_neighbor
    neighbor_rhoexcess(2,:,:) = rho_scr_delta_neighbor
 
    !* loop through the slip systems and calculate the dislocation gradient by
    !* 1. interpolation of the excess density in the neighorhood
    !* 2. interpolation of the dead dislocation density in the central volume
    m(1:3,:,1) =  prm%slip_direction
    m(1:3,:,2) = -prm%slip_transverse
 
    do s = 1,prm%sum_N_sl
 
      ! gradient from interpolation of neighboring excess density ...
      do c = 1,2
        do dir = 1,3
          neighbors(1) = 2 * dir - 1
          neighbors(2) = 2 * dir
          connections(dir,1:3) = connection_latticeconf(1:3,neighbors(1)) &
                               - connection_latticeconf(1:3,neighbors(2))
          rhoexcessdifferences(dir) = neighbor_rhoexcess(c,s,neighbors(1)) &
                                    - neighbor_rhoexcess(c,s,neighbors(2))
        enddo
        invconnections = math_inv33(connections)
        if (all(deq0(invconnections))) call io_error(-1,ext_msg='back stress calculation: inversion error')
 
        rhoexcessgradient(c) = math_inner(m(1:3,s,c), matmul(invconnections,rhoexcessdifferences))
      enddo
 
        ! ... plus gradient from deads ...
      rhoexcessgradient(1) = rhoexcessgradient(1) + sum(rho(s,imm_edg)) / fvsize
      rhoexcessgradient(2) = rhoexcessgradient(2) + sum(rho(s,imm_scr)) / fvsize
 
        ! ... normalized with the total density ...
      rhototal(1) = (sum(abs(rho(s,edg))) + sum(neighbor_rhototal(1,s,:))) / (1.0_preal + nrealneighbors)
      rhototal(2) = (sum(abs(rho(s,scr))) + sum(neighbor_rhototal(2,s,:))) / (1.0_preal + nrealneighbors)
 
      rhoexcessgradient_over_rho = 0.0_preal
      where(rhototal > 0.0_preal) rhoexcessgradient_over_rho = rhoexcessgradient / rhototal
 
        ! ... gives the local stress correction when multiplied with a factor
      dst%tau_back(s,of) = - prm%mu * prm%burgers(s) / (2.0_preal * pi) &
                         * (  rhoexcessgradient_over_rho(1) / (1.0_preal - prm%nu) &
                            + rhoexcessgradient_over_rho(2))
    enddo
  endif
 
# 721 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_nonlocal.f90"
 
 end associate
 
end subroutine plastic_nonlocal_dependentstate
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine plastic_nonlocal_lpanditstangent(lp,dlp_dmp, &
                                                   mp,temperature,instance,of,ip,el)
  real(preal), dimension(3,3), intent(out) :: &
    lp
  real(preal), dimension(3,3,3,3), intent(out) :: &
    dlp_dmp
  integer, intent(in) :: &
    instance, &
    of, &
    ip, &                                                                                           !< current integration point
    el
  real(preal), intent(in) :: &
    temperature
 
  real(preal), dimension(3,3), intent(in) :: &
    mp
                                                                                                    
  integer :: &
    ns, &                                                                                           !< short notation for the total number of active slip systems
    i, &
    j, &
    k, &
    l, &
    t, &                                                                                            !< dislocation type
    s
  real(preal), dimension(param(instance)%sum_N_sl,8) :: &
    rhosgl
  real(preal), dimension(param(instance)%sum_N_sl,10) :: &
    rho
  real(preal), dimension(param(instance)%sum_N_sl,4) :: &
    v, &                                                                                            !< velocity
    tauns, &                                                                                        !< resolved shear stress including non Schmid and backstress terms
    dv_dtau, &                                                                                      !< velocity derivative with respect to the shear stress
    dv_dtauns
  real(preal), dimension(param(instance)%sum_N_sl) :: &
    tau, &                                                                                          !< resolved shear stress including backstress terms
    gdottotal
 
  associate(prm => param(instance),dst=>microstructure(instance),stt=>state(instance))
  ns = prm%sum_N_sl
 
  !*** shortcut to state variables
  rho = getrho(instance,of,ip,el)
  rhosgl = rho(:,sgl)
 
  do s = 1,ns
    tau(s) = math_tensordot(mp, prm%Schmid(1:3,1:3,s))
    tauns(s,1) = tau(s)
    tauns(s,2) = tau(s)
    if (tau(s) > 0.0_preal) then
      tauns(s,3) = math_tensordot(mp, +prm%nonSchmid_pos(1:3,1:3,s))
      tauns(s,4) = math_tensordot(mp, -prm%nonSchmid_neg(1:3,1:3,s))
    else
      tauns(s,3) = math_tensordot(mp, +prm%nonSchmid_neg(1:3,1:3,s))
      tauns(s,4) = math_tensordot(mp, -prm%nonSchmid_pos(1:3,1:3,s))
    endif
  enddo
  tauns = tauns + spread(dst%tau_back(:,of),2,4)
  tau   = tau   + dst%tau_back(:,of)
 
  ! edges
  call kinetics(v(:,1), dv_dtau(:,1), dv_dtauns(:,1), &
                tau, tauns(:,1), dst%tau_pass(:,of),1,temperature, instance)
  v(:,2)         = v(:,1)
  dv_dtau(:,2)   = dv_dtau(:,1)
  dv_dtauns(:,2) = dv_dtauns(:,1)
 
  !screws
  if (prm%nonSchmidActive) then
    v(:,3:4)         = spread(v(:,1),2,2)
    dv_dtau(:,3:4)   = spread(dv_dtau(:,1),2,2)
    dv_dtauns(:,3:4) = spread(dv_dtauns(:,1),2,2)
  else
    do t = 3,4
      call kinetics(v(:,t), dv_dtau(:,t), dv_dtauns(:,t), &
                    tau, tauns(:,t), dst%tau_pass(:,of),2,temperature, instance)
    enddo
  endif
 
  stt%v(:,of) = pack(v,.true.)
 
  !*** Bauschinger effect
  forall (s = 1:ns, t = 5:8, rhosgl(s,t) * v(s,t-4) < 0.0_preal) &
    rhosgl(s,t-4) = rhosgl(s,t-4) + abs(rhosgl(s,t))
 
  gdottotal = sum(rhosgl(:,1:4) * v, 2) * prm%burgers
 
  lp = 0.0_preal
  dlp_dmp = 0.0_preal
  do s = 1,ns
    lp = lp + gdottotal(s) * prm%Schmid(1:3,1:3,s)
    forall (i=1:3,j=1:3,k=1:3,l=1:3) &
      dlp_dmp(i,j,k,l) = dlp_dmp(i,j,k,l) &
          + prm%Schmid(i,j,s) * prm%Schmid(k,l,s) &
          * sum(rhosgl(s,1:4) * dv_dtau(s,1:4)) * prm%burgers(s) &
          + prm%Schmid(i,j,s) &
          * ( prm%nonSchmid_pos(k,l,s) * rhosgl(s,3) * dv_dtauns(s,3) &
            - prm%nonSchmid_neg(k,l,s) * rhosgl(s,4) * dv_dtauns(s,4))  * prm%burgers(s)
  enddo
 
  end associate
 
end subroutine plastic_nonlocal_lpanditstangent
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine plastic_nonlocal_deltastate(mp,instance,of,ip,el)
 
  real(preal), dimension(3,3), intent(in) :: &
    mp
  integer, intent(in) :: &
    instance, &                                                                                     ! current instance of this plasticity
    of, &                                                                                           !< offset
    ip, &
    el
 
  integer :: &
    ph, &                                                                                           !< phase
    ns, &                                                                                           ! short notation for the total number of active slip systems
    c, &                                                                                            ! character of dislocation
    t, &                                                                                            ! type of dislocation
    s                                                                                               ! index of my current slip system
  real(preal), dimension(param(instance)%sum_N_sl,10) :: &
    deltarhoremobilization, &                                                                       ! density increment by remobilization
    deltarhodipole2singlestress                                                                     ! density increment by dipole dissociation (by stress change)
  real(preal), dimension(param(instance)%sum_N_sl,10) :: &
    rho                                                                                             ! current  dislocation densities
  real(preal), dimension(param(instance)%sum_N_sl,4) :: &
    v                                                                                               ! dislocation glide velocity
  real(preal), dimension(param(instance)%sum_N_sl) :: &
    tau                                                                                             ! current resolved shear stress
  real(preal), dimension(param(instance)%sum_N_sl,2) :: &
    rhodip, &                                                                                       ! current dipole dislocation densities (screw and edge dipoles)
    dupper, &                                                                                       ! current maximum stable dipole distance for edges and screws
    dupperold, &                                                                                    ! old maximum stable dipole distance for edges and screws
    deltadupper                                                                                     ! change in maximum stable dipole distance for edges and screws
 
   ph = material_phaseat(1,el)
 
   associate(prm => param(instance),dst => microstructure(instance),del => deltastate(instance))
   ns = prm%sum_N_sl
 
  !*** shortcut to state variables
  forall (s = 1:ns, t = 1:4) v(s,t) = plasticstate(ph)%state(iv(s,t,instance),of)
  forall (s = 1:ns, c = 1:2) dupperold(s,c) = plasticstate(ph)%state(id(s,c,instance),of)
 
  rho =  getrho(instance,of,ip,el)
  rhodip = rho(:,dip)
 
  !****************************************************************************
  !*** dislocation remobilization (bauschinger effect)
  where(rho(:,imm) * v < 0.0_preal)
    deltarhoremobilization(:,mob) = abs(rho(:,imm))
    deltarhoremobilization(:,imm) =   - rho(:,imm)
    rho(:,mob) = rho(:,mob) + abs(rho(:,imm))
    rho(:,imm) = 0.0_preal
  elsewhere
    deltarhoremobilization(:,mob) = 0.0_preal
    deltarhoremobilization(:,imm) = 0.0_preal
  endwhere
  deltarhoremobilization(:,dip) = 0.0_preal
 
  !****************************************************************************
  !*** calculate dipole formation and dissociation by stress change
 
  !*** calculate limits for stable dipole height
  do s = 1,prm%sum_N_sl
    tau(s) = math_tensordot(mp, prm%Schmid(1:3,1:3,s)) +dst%tau_back(s,of)
    if (abs(tau(s)) < 1.0e-15_preal) tau(s) = 1.0e-15_preal
  enddo
 
  dupper(:,1) = prm%mu * prm%burgers/(8.0_preal * pi * (1.0_preal - prm%nu) * abs(tau))
  dupper(:,2) = prm%mu * prm%burgers/(4.0_preal * pi * abs(tau))
 
  where(dneq0(sqrt(sum(abs(rho(:,edg)),2)))) &
    dupper(:,1) = min(1.0_preal/sqrt(sum(abs(rho(:,edg)),2)),dupper(:,1))
  where(dneq0(sqrt(sum(abs(rho(:,scr)),2)))) &
    dupper(:,2) = min(1.0_preal/sqrt(sum(abs(rho(:,scr)),2)),dupper(:,2))
 
  dupper = max(dupper,prm%minDipoleHeight)
  deltadupper = dupper - dupperold
 
 
  !*** dissociation by stress increase
  deltarhodipole2singlestress = 0.0_preal
  forall (c=1:2, s=1:ns, deltadupper(s,c) < 0.0_preal .and. &
                                          dneq0(dupperold(s,c) - prm%minDipoleHeight(s,c))) &
    deltarhodipole2singlestress(s,8+c) = rhodip(s,c) * deltadupper(s,c) &
                                       / (dupperold(s,c) - prm%minDipoleHeight(s,c))
 
  forall (t=1:4) deltarhodipole2singlestress(:,t) = -0.5_preal * deltarhodipole2singlestress(:,(t-1)/2+9)
  forall (s = 1:ns, c = 1:2) plasticstate(ph)%state(id(s,c,instance),of) = dupper(s,c)
 
  plasticstate(ph)%deltaState(:,of) = 0.0_preal
  del%rho(:,of) = reshape(deltarhoremobilization + deltarhodipole2singlestress, [10*ns])
 
# 936 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_nonlocal.f90"
 
  end associate
 
end subroutine plastic_nonlocal_deltastate
 
 
!---------------------------------------------------------------------------------------------------
!---------------------------------------------------------------------------------------------------
module subroutine plastic_nonlocal_dotstate(mp, f, fp, temperature,timestep, &
                                            instance,of,ip,el)
 
  real(preal), dimension(3,3), intent(in) :: &
    mp
  real(preal), dimension(3,3,homogenization_maxNgrains,discretization_nIP,discretization_nElem), intent(in) :: &
    f, &                                                                                            !< elastic deformation gradient
    fp
  real(preal), intent(in) :: &
    temperature, &                                                                                  !< temperature
    timestep
  integer, intent(in) :: &
    instance, &
    of, &
    ip, &                                                                                           !< current integration point
    el
 
  integer ::  &
    ph, &
    neighbor_instance, &                                                                            !< instance of my neighbor's plasticity
    ns, &                                                                                           !< short notation for the total number of active slip systems
    c, &                                                                                            !< character of dislocation
    n, &                                                                                            !< index of my current neighbor
    neighbor_el, &                                                                                  !< element number of my neighbor
    neighbor_ip, &                                                                                  !< integration point of my neighbor
    neighbor_n, &                                                                                   !< neighbor index pointing to me when looking from my neighbor
    opposite_neighbor, &                                                                            !< index of my opposite neighbor
    opposite_ip, &                                                                                  !< ip of my opposite neighbor
    opposite_el, &                                                                                  !< element index of my opposite neighbor
    opposite_n, &                                                                                   !< neighbor index pointing to me when looking from my opposite neighbor
    t, &                                                                                            !< type of dislocation
    no,&                                                                                            !< neighbor offset shortcut
    np,&                                                                                            !< neighbor phase shortcut
    topp, &                                                                                         !< type of dislocation with opposite sign to t
    s                                                                                               !< index of my current slip system
  real(pReal), dimension(param(instance)%sum_N_sl,10) :: &
    rho, &
    rho0, &                                                                                         !< dislocation density at beginning of time step
    rhoDot, &                                                                                       !< density evolution
    rhoDotMultiplication, &                                                                         !< density evolution by multiplication
    rhoDotFlux, &                                                                                   !< density evolution by flux
    rhoDotSingle2DipoleGlide, &                                                                     !< density evolution by dipole formation (by glide)
    rhoDotAthermalAnnihilation, &                                                                   !< density evolution by athermal annihilation
    rhoDotThermalAnnihilation                                                                       !< density evolution by thermal annihilation
  real(pReal), dimension(param(instance)%sum_N_sl,8) :: &
    rhoSgl, &                                                                                       !< current single dislocation densities (positive/negative screw and edge without dipoles)
    neighbor_rhoSgl0, &                                                                             !< current single dislocation densities of neighboring ip (positive/negative screw and edge without dipoles)
    my_rhoSgl0                                                                                      !< single dislocation densities of central ip (positive/negative screw and edge without dipoles)
  real(pReal), dimension(param(instance)%sum_N_sl,4) :: &
    v, &                                                                                            !< current dislocation glide velocity
    v0, &
    neighbor_v0, &                                                                                  !< dislocation glide velocity of enighboring ip
    gdot                                                                                            !< shear rates
  real(pReal), dimension(param(instance)%sum_N_sl) :: &
    tau, &                                                                                          !< current resolved shear stress
    vClimb                                                                                          !< climb velocity of edge dipoles
  real(pReal), dimension(param(instance)%sum_N_sl,2) :: &
    rhoDip, &                                                                                       !< current dipole dislocation densities (screw and edge dipoles)
    dLower, &                                                                                       !< minimum stable dipole distance for edges and screws
    dUpper                                                                                          !< current maximum stable dipole distance for edges and screws
  real(pReal), dimension(3,param(instance)%sum_N_sl,4) :: &
    m                                                                                               !< direction of dislocation motion
  real(pReal), dimension(3,3) :: &
    my_F, &                                                                                         !< my total deformation gradient
    neighbor_F, &                                                                                   !< total deformation gradient of my neighbor
    my_Fe, &                                                                                        !< my elastic deformation gradient
    neighbor_Fe, &                                                                                  !< elastic deformation gradient of my neighbor
    Favg                                                                                            !< average total deformation gradient of me and my neighbor
  real(pReal), dimension(3) :: &
    normal_neighbor2me, &                                                                           !< interface normal pointing from my neighbor to me in neighbor's lattice configuration
    normal_neighbor2me_defconf, &                                                                   !< interface normal pointing from my neighbor to me in shared deformed configuration
    normal_me2neighbor, &                                                                           !< interface normal pointing from me to my neighbor in my lattice configuration
    normal_me2neighbor_defconf
  real(preal) :: &
    area, &                                                                                         !< area of the current interface
    transmissivity, &                                                                               !< overall transmissivity of dislocation flux to neighboring material point
    linelength, &                                                                                   !< dislocation line length leaving the current interface
    selfdiffusion
 
  ph = material_phaseat(1,el)
  if (timestep <= 0.0_preal) then
    plasticstate(ph)%dotState = 0.0_preal
    return
  endif
 
  associate(prm => param(instance), &
            dst => microstructure(instance), &
            dot => dotstate(instance), &
            stt => state(instance))
  ns = prm%sum_N_sl
 
  tau = 0.0_preal
  gdot = 0.0_preal
 
  rho  = getrho(instance,of,ip,el)
  rhosgl = rho(:,sgl)
  rhodip = rho(:,dip)
  rho0 = getrho0(instance,of,ip,el)
  my_rhosgl0 = rho0(:,sgl)
 
  forall (s = 1:ns, t = 1:4) v(s,t) = plasticstate(ph)%state(iv(s,t,instance),of)
  gdot = rhosgl(:,1:4) * v * spread(prm%burgers,2,4)
 
# 1056 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_nonlocal.f90"
 
  !****************************************************************************
  !*** limits for stable dipole height
  do s = 1,ns
    tau(s) = math_tensordot(mp, prm%Schmid(1:3,1:3,s)) + dst%tau_back(s,of)
    if (abs(tau(s)) < 1.0e-15_preal) tau(s) = 1.0e-15_preal
  enddo
 
  dlower = prm%minDipoleHeight
  dupper(:,1) = prm%mu * prm%burgers/(8.0_preal * pi * (1.0_preal - prm%nu) * abs(tau))
  dupper(:,2) = prm%mu * prm%burgers/(4.0_preal * pi * abs(tau))
 
  where(dneq0(sqrt(sum(abs(rho(:,edg)),2)))) &
    dupper(:,1) = min(1.0_preal/sqrt(sum(abs(rho(:,edg)),2)),dupper(:,1))
  where(dneq0(sqrt(sum(abs(rho(:,scr)),2)))) &
    dupper(:,2) = min(1.0_preal/sqrt(sum(abs(rho(:,scr)),2)),dupper(:,2))
 
  dupper = max(dupper,dlower)
 
  !****************************************************************************
  !*** dislocation multiplication
  rhodotmultiplication = 0.0_preal
  isbcc: if (lattice_structure(ph) == lattice_bcc_id) then
    forall (s = 1:ns, sum(abs(v(s,1:4))) > 0.0_preal)
      rhodotmultiplication(s,1:2) = sum(abs(gdot(s,3:4))) / prm%burgers(s) &                        ! assuming double-cross-slip of screws to be decisive for multiplication
                                  * sqrt(stt%rho_forest(s,of)) / prm%lambda0(s) ! &                 ! mean free path
                                  ! * 2.0_pReal * sum(abs(v(s,3:4))) / sum(abs(v(s,1:4)))           ! ratio of screw to overall velocity determines edge generation
      rhodotmultiplication(s,3:4) = sum(abs(gdot(s,3:4))) /prm%burgers(s) &                         ! assuming double-cross-slip of screws to be decisive for multiplication
                                  * sqrt(stt%rho_forest(s,of)) / prm%lambda0(s) ! &                 ! mean free path
                                  ! * 2.0_pReal * sum(abs(v(s,1:2))) / sum(abs(v(s,1:4)))           ! ratio of edge to overall velocity determines screw generation
    endforall
 
  else isbcc
    rhodotmultiplication(:,1:4) = spread( &
          (sum(abs(gdot(:,1:2)),2) * prm%fEdgeMultiplication + sum(abs(gdot(:,3:4)),2)) &
        * sqrt(stt%rho_forest(:,of)) / prm%lambda0 / prm%burgers, 2, 4)
  endif isbcc
 
  forall (s = 1:ns, t = 1:4) v0(s,t) = plasticstate(ph)%state0(iv(s,t,instance),of)
 
  !****************************************************************************
  !*** calculate dislocation fluxes (only for nonlocal plasticity)
  rhodotflux = 0.0_preal
  if (.not. phase_localplasticity(material_phaseat(1,el))) then
 
    !*** check CFL (Courant-Friedrichs-Lewy) condition for flux
    if (any( abs(gdot) > 0.0_preal &                                                                ! any active slip system ...
            .and. prm%CFLfactor * abs(v0) * timestep &
                > ipvolume(ip,el) / maxval(iparea(:,ip,el)))) then                                  ! ...with velocity above critical value (we use the reference volume and area for simplicity here)
# 1116 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_nonlocal.f90"
      plasticstate(ph)%dotState = ieee_value(1.0_preal,ieee_quiet_nan)                               ! -> return NaN and, hence, enforce cutback
      return
    endif
 
 
    !*** be aware of the definition of slip_transverse = slip_direction x slip_normal !!!
    !*** opposite sign to our t vector in the (s,t,n) triplet !!!
 
    m(1:3,:,1) =  prm%slip_direction
    m(1:3,:,2) = -prm%slip_direction
    m(1:3,:,3) = -prm%slip_transverse
    m(1:3,:,4) =  prm%slip_transverse
 
    my_f = f(1:3,1:3,1,ip,el)
    my_fe = matmul(my_f, math_inv33(fp(1:3,1:3,1,ip,el)))
 
    neighbors: do n = 1,nipneighbors
 
      neighbor_el = ipneighborhood(1,n,ip,el)
      neighbor_ip = ipneighborhood(2,n,ip,el)
      neighbor_n  = ipneighborhood(3,n,ip,el)
      np = material_phaseat(1,neighbor_el)
      no = material_phasememberat(1,neighbor_ip,neighbor_el)
 
      opposite_neighbor = n + mod(n,2) - mod(n+1,2)
      opposite_el = ipneighborhood(1,opposite_neighbor,ip,el)
      opposite_ip = ipneighborhood(2,opposite_neighbor,ip,el)
      opposite_n  = ipneighborhood(3,opposite_neighbor,ip,el)
 
      if (neighbor_n > 0) then                                                                      ! if neighbor exists, average deformation gradient
        neighbor_instance = phase_plasticityinstance(material_phaseat(1,neighbor_el))
        neighbor_f = f(1:3,1:3,1,neighbor_ip,neighbor_el)
        neighbor_fe = matmul(neighbor_f, math_inv33(fp(1:3,1:3,1,neighbor_ip,neighbor_el)))
        favg = 0.5_preal * (my_f + neighbor_f)
      else                                                                                          ! if no neighbor, take my value as average
        favg = my_f
      endif
 
      neighbor_v0 = 0.0_preal        ! needed for check of sign change in flux density below
 
      !* FLUX FROM MY NEIGHBOR TO ME
      !* This is only considered, if I have a neighbor of nonlocal plasticity
      !* (also nonlocal constitutive law with local properties) that is at least a little bit
      !* compatible.
      !* If it's not at all compatible, no flux is arriving, because everything is dammed in front of
      !* my neighbor's interface.
      !* The entering flux from my neighbor will be distributed on my slip systems according to the
      !* compatibility
      if (neighbor_n > 0) then
      if (phase_plasticity(material_phaseat(1,neighbor_el)) == plasticity_nonlocal_id .and. &
          any(compatibility(:,:,:,n,ip,el) > 0.0_preal)) then
 
        forall (s = 1:ns, t = 1:4)
          neighbor_v0(s,t) =          plasticstate(np)%state0(iv(s,t,neighbor_instance),no)
          neighbor_rhosgl0(s,t) = max(plasticstate(np)%state0(irhou(s,t,neighbor_instance),no),0.0_preal)
        endforall
 
        where (neighbor_rhosgl0 * ipvolume(neighbor_ip,neighbor_el) ** 0.667_preal < prm%significantN &
          .or. neighbor_rhosgl0 < prm%significantRho) &
          neighbor_rhosgl0 = 0.0_preal
        normal_neighbor2me_defconf = math_det33(favg) * matmul(math_inv33(transpose(favg)), &
                                     ipareanormal(1:3,neighbor_n,neighbor_ip,neighbor_el))          ! normal of the interface in (average) deformed configuration (pointing neighbor => me)
        normal_neighbor2me = matmul(transpose(neighbor_fe), normal_neighbor2me_defconf) &
                           / math_det33(neighbor_fe)                                                ! interface normal in the lattice configuration of my neighbor
        area = iparea(neighbor_n,neighbor_ip,neighbor_el) * norm2(normal_neighbor2me)
        normal_neighbor2me = normal_neighbor2me / norm2(normal_neighbor2me)                         ! normalize the surface normal to unit length
        do s = 1,ns
          do t = 1,4
            c = (t + 1) / 2
            topp = t + mod(t,2) - mod(t+1,2)
            if (neighbor_v0(s,t) * math_inner(m(1:3,s,t), normal_neighbor2me) > 0.0_preal &         ! flux from my neighbor to me == entering flux for me
                .and. v0(s,t) * neighbor_v0(s,t) >= 0.0_preal ) then                                ! ... only if no sign change in flux density
              linelength = neighbor_rhosgl0(s,t) * neighbor_v0(s,t) &
                         * math_inner(m(1:3,s,t), normal_neighbor2me) * area                        ! positive line length that wants to enter through this interface
              where (compatibility(c,:,s,n,ip,el) > 0.0_preal) &
                rhodotflux(:,t) = rhodotflux(1:ns,t) &
                                + linelength/ipvolume(ip,el)*compatibility(c,:,s,n,ip,el)**2.0_preal    ! transferring to equally signed mobile dislocation type
              where (compatibility(c,:,s,n,ip,el) < 0.0_preal) &
                rhodotflux(:,topp) = rhodotflux(:,topp) &
                                   + linelength/ipvolume(ip,el)*compatibility(c,:,s,n,ip,el)**2.0_preal ! transferring to opposite signed mobile dislocation type
 
            endif
          enddo
        enddo
      endif; endif
 
 
      !* FLUX FROM ME TO MY NEIGHBOR
      !* This is not considered, if my opposite neighbor has a different constitutive law than nonlocal (still considered for nonlocal law with local properties).
      !* Then, we assume, that the opposite(!) neighbor sends an equal amount of dislocations to me.
      !* So the net flux in the direction of my neighbor is equal to zero:
      !*    leaving flux to neighbor == entering flux from opposite neighbor
      !* In case of reduced transmissivity, part of the leaving flux is stored as dead dislocation density.
      !* That means for an interface of zero transmissivity the leaving flux is fully converted to dead dislocations.
      if (opposite_n > 0) then
      if (phase_plasticity(material_phaseat(1,opposite_el)) == plasticity_nonlocal_id) then
 
        normal_me2neighbor_defconf = math_det33(favg) &
                                   * matmul(math_inv33(transpose(favg)),ipareanormal(1:3,n,ip,el))  ! normal of the interface in (average) deformed configuration (pointing me => neighbor)
        normal_me2neighbor = matmul(transpose(my_fe), normal_me2neighbor_defconf) &
                           / math_det33(my_fe)                                                      ! interface normal in my lattice configuration
        area = iparea(n,ip,el) * norm2(normal_me2neighbor)
        normal_me2neighbor = normal_me2neighbor / norm2(normal_me2neighbor)                         ! normalize the surface normal to unit length
        do s = 1,ns
          do t = 1,4
            c = (t + 1) / 2
            if (v0(s,t) * math_inner(m(1:3,s,t), normal_me2neighbor) > 0.0_preal ) then             ! flux from me to my neighbor == leaving flux for me (might also be a pure flux from my mobile density to dead density if interface not at all transmissive)
              if (v0(s,t) * neighbor_v0(s,t) >= 0.0_preal) then                                     ! no sign change in flux density
                transmissivity = sum(compatibility(c,:,s,n,ip,el)**2.0_preal)                       ! overall transmissivity from this slip system to my neighbor
              else                                                                                  ! sign change in flux density means sign change in stress which does not allow for dislocations to arive at the neighbor
                transmissivity = 0.0_preal
              endif
              linelength = my_rhosgl0(s,t) * v0(s,t) &
                         * math_inner(m(1:3,s,t), normal_me2neighbor) * area                        ! positive line length of mobiles that wants to leave through this interface
              rhodotflux(s,t) = rhodotflux(s,t) - linelength / ipvolume(ip,el)                      ! subtract dislocation flux from current type
              rhodotflux(s,t+4) = rhodotflux(s,t+4) &
                                + linelength / ipvolume(ip,el) * (1.0_preal - transmissivity) &
                                * sign(1.0_preal, v0(s,t))                                          ! dislocation flux that is not able to leave through interface (because of low transmissivity) will remain as immobile single density at the material point
            endif
          enddo
        enddo
      endif; endif
 
    enddo neighbors
  endif
 
 
 
  !****************************************************************************
  !*** calculate dipole formation and annihilation
 
  !*** formation by glide
  do c = 1,2
    rhodotsingle2dipoleglide(:,2*c-1) = -2.0_preal * dupper(:,c) / prm%burgers &
                                                   * (      rhosgl(:,2*c-1)  * abs(gdot(:,2*c)) &   ! negative mobile --> positive mobile
                                                      +     rhosgl(:,2*c)    * abs(gdot(:,2*c-1)) & ! positive mobile --> negative mobile
                                                      + abs(rhosgl(:,2*c+4)) * abs(gdot(:,2*c-1)))  ! positive mobile --> negative immobile
 
    rhodotsingle2dipoleglide(:,2*c) = -2.0_preal * dupper(:,c) / prm%burgers &
                                                 * (      rhosgl(:,2*c-1)  * abs(gdot(:,2*c)) &     ! negative mobile --> positive mobile
                                                    +     rhosgl(:,2*c)    * abs(gdot(:,2*c-1)) &   ! positive mobile --> negative mobile
                                                    + abs(rhosgl(:,2*c+3)) * abs(gdot(:,2*c)))      ! negative mobile --> positive immobile
 
    rhodotsingle2dipoleglide(:,2*c+3) = -2.0_preal * dupper(:,c) / prm%burgers &
                                                   * rhosgl(:,2*c+3) * abs(gdot(:,2*c))             ! negative mobile --> positive immobile
 
    rhodotsingle2dipoleglide(:,2*c+4) = -2.0_preal * dupper(:,c) / prm%burgers &
                                                   * rhosgl(:,2*c+4) * abs(gdot(:,2*c-1))           ! positive mobile --> negative immobile
 
    rhodotsingle2dipoleglide(:,c+8) = abs(rhodotsingle2dipoleglide(:,2*c+3)) &
                                    + abs(rhodotsingle2dipoleglide(:,2*c+4)) &
                                    - rhodotsingle2dipoleglide(:,2*c-1) &
                                    - rhodotsingle2dipoleglide(:,2*c)
  enddo
 
 
  !*** athermal annihilation
  rhodotathermalannihilation = 0.0_preal
  forall (c=1:2) &
    rhodotathermalannihilation(:,c+8) = -2.0_preal * dlower(:,c) / prm%burgers &
       * (  2.0_preal * (rhosgl(:,2*c-1) * abs(gdot(:,2*c)) + rhosgl(:,2*c) * abs(gdot(:,2*c-1))) &             ! was single hitting single
          + 2.0_preal * (abs(rhosgl(:,2*c+3)) * abs(gdot(:,2*c)) + abs(rhosgl(:,2*c+4)) * abs(gdot(:,2*c-1))) & ! was single hitting immobile single or was immobile single hit by single
          + rhodip(:,c) * (abs(gdot(:,2*c-1)) + abs(gdot(:,2*c))))                                              ! single knocks dipole constituent
 
  ! annihilated screw dipoles leave edge jogs behind on the colinear system
  if (lattice_structure(ph) == lattice_fcc_id) &
    forall (s = 1:ns, prm%colinearSystem(s) > 0) &
      rhodotathermalannihilation(prm%colinearSystem(s),1:2) = - rhodotathermalannihilation(s,10) &
        * 0.25_preal * sqrt(stt%rho_forest(s,of)) * (dupper(s,2) + dlower(s,2)) * prm%edgeJogFactor
 
 
  !*** thermally activated annihilation of edge dipoles by climb
  rhodotthermalannihilation = 0.0_preal
  selfdiffusion = prm%Dsd0 * exp(-prm%selfDiffusionEnergy / (kb * temperature))
  vclimb = prm%atomicVolume * selfdiffusion * prm%mu &
         / ( kb * temperature  * pi * (1.0_preal-prm%nu) * (dupper(:,1) + dlower(:,1)))
  forall (s = 1:ns, dupper(s,1) > dlower(s,1)) &
    rhodotthermalannihilation(s,9) = max(- 4.0_preal * rhodip(s,1) * vclimb(s) / (dupper(s,1) - dlower(s,1)), &
                                         - rhodip(s,1) / timestep - rhodotathermalannihilation(s,9) &
                                                                  - rhodotsingle2dipoleglide(s,9))    ! make sure that we do not annihilate more dipoles than we have
 
  rhodot = rhodotflux &
         + rhodotmultiplication &
         + rhodotsingle2dipoleglide &
         + rhodotathermalannihilation &
         + rhodotthermalannihilation
 
# 1325 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/constitutive_plastic_nonlocal.f90"
 
 
  if (    any(rho(:,mob) + rhodot(:,1:4)  * timestep < -prm%atol_rho) &
     .or. any(rho(:,dip) + rhodot(:,9:10) * timestep < -prm%atol_rho)) then
 
 
 
 
 
 
    plasticstate(ph)%dotState = ieee_value(1.0_preal,ieee_quiet_nan)
  else
    dot%rho(:,of) = pack(rhodot,.true.)
    dot%gamma(:,of) = sum(gdot,2)
  endif
 
  end associate
 
end subroutine plastic_nonlocal_dotstate
 
 
!--------------------------------------------------------------------------------------------------
! plane normals and signed cosine of the angle between the slip directions. Only the largest values
! that sum up to a total of 1 are considered, all others are set to zero.
!--------------------------------------------------------------------------------------------------
module subroutine plastic_nonlocal_updatecompatibility(orientation,instance,i,e)
 
  type(rotation), dimension(1,discretization_nIP,discretization_nElem), intent(in) :: &
    orientation                                                                                     ! crystal orientation
  integer, intent(in) :: &
    instance, &
    i, &
    e
 
  integer :: &
    n, &                                                                                            ! neighbor index
    neighbor_e, &                                                                                   ! element index of my neighbor
    neighbor_i, &                                                                                   ! integration point index of my neighbor
    ph, &
    neighbor_phase, &
    ns, &                                                                                           ! number of active slip systems
    s1, &                                                                                           ! slip system index (me)
    s2                                                                                              ! slip system index (my neighbor)
  real(preal), dimension(2,param(instance)%sum_N_sl,param(instance)%sum_N_sl,nIPneighbors) :: &
    my_compatibility                                                                                ! my_compatibility for current element and ip
  real(preal) :: &
    my_compatibilitysum, &
    thresholdvalue, &
    nthresholdvalues
  logical, dimension(param(instance)%sum_N_sl) :: &
    belowthreshold
  type(rotation) :: mis
 
  ph = material_phaseat(1,e)
 
  associate(prm => param(instance))
  ns = prm%sum_N_sl
 
  !*** start out fully compatible
  my_compatibility = 0.0_preal
  forall(s1 = 1:ns) my_compatibility(:,s1,s1,:) = 1.0_preal
 
  neighbors: do n = 1,nipneighbors
    neighbor_e = ipneighborhood(1,n,i,e)
    neighbor_i = ipneighborhood(2,n,i,e)
 
    neighbor_phase = material_phaseat(1,neighbor_e)
 
    if (neighbor_e <= 0 .or. neighbor_i <= 0) then
      !* FREE SURFACE
      !* Set surface transmissivity to the value specified in the material.config
      forall(s1 = 1:ns) my_compatibility(:,s1,s1,n) = sqrt(prm%surfaceTransmissivity)
    elseif (neighbor_phase /= ph) then
      !* PHASE BOUNDARY
      !* If we encounter a different nonlocal phase at the neighbor,
      !* we consider this to be a real "physical" phase boundary, so completely incompatible.
      !* If one of the two phases has a local plasticity law,
      !* we do not consider this to be a phase boundary, so completely compatible.
      if (.not. phase_localplasticity(neighbor_phase) .and. .not. phase_localplasticity(ph)) &
        forall(s1 = 1:ns) my_compatibility(:,s1,s1,n) = 0.0_preal
    elseif (prm%grainboundaryTransmissivity >= 0.0_preal) then
      !* GRAIN BOUNDARY !
      !* fixed transmissivity for adjacent ips with different texture (only if explicitly given in material.config)
      if (material_texture(1,i,e) /= material_texture(1,neighbor_i,neighbor_e) .and. &
          (.not. phase_localplasticity(neighbor_phase))) &
        forall(s1 = 1:ns) my_compatibility(:,s1,s1,n) = sqrt(prm%grainboundaryTransmissivity)
    else
      !* GRAIN BOUNDARY ?
      !* Compatibility defined by relative orientation of slip systems:
      !* The my_compatibility value is defined as the product of the slip normal projection and the slip direction projection.
      !* Its sign is always positive for screws, for edges it has the same sign as the slip normal projection.
      !* Since the sum for each slip system can easily exceed one (which would result in a transmissivity larger than one),
      !* only values above or equal to a certain threshold value are considered. This threshold value is chosen, such that
      !* the number of compatible slip systems is minimized with the sum of the original compatibility values exceeding one.
      !* Finally the smallest compatibility value is decreased until the sum is exactly equal to one.
      !* All values below the threshold are set to zero.
      mis = orientation(1,i,e)%misorientation(orientation(1,neighbor_i,neighbor_e))
      myslipsystems: do s1 = 1,ns
        neighborslipsystems: do s2 = 1,ns
          my_compatibility(1,s2,s1,n) =     math_inner(prm%slip_normal(1:3,s1), &
                                                       mis%rotate(prm%slip_normal(1:3,s2))) &
                                      * abs(math_inner(prm%slip_direction(1:3,s1), &
                                                       mis%rotate(prm%slip_direction(1:3,s2))))
          my_compatibility(2,s2,s1,n) = abs(math_inner(prm%slip_normal(1:3,s1), &
                                                       mis%rotate(prm%slip_normal(1:3,s2)))) &
                                      * abs(math_inner(prm%slip_direction(1:3,s1), &
                                                       mis%rotate(prm%slip_direction(1:3,s2))))
        enddo neighborslipsystems
 
        my_compatibilitysum = 0.0_preal
        belowthreshold = .true.
        do while (my_compatibilitysum < 1.0_preal .and. any(belowthreshold))
          thresholdvalue = maxval(my_compatibility(2,:,s1,n), belowthreshold)                       ! screws always positive
          nthresholdvalues = real(count(my_compatibility(2,:,s1,n) >= thresholdvalue),preal)
          where (my_compatibility(2,:,s1,n) >= thresholdvalue) belowthreshold = .false.
          if (my_compatibilitysum + thresholdvalue * nthresholdvalues > 1.0_preal) &
            where (abs(my_compatibility(:,:,s1,n)) >= thresholdvalue) &
              my_compatibility(:,:,s1,n) = sign((1.0_preal - my_compatibilitysum)/nthresholdvalues,&
                                                 my_compatibility(:,:,s1,n))
          my_compatibilitysum = my_compatibilitysum + nthresholdvalues * thresholdvalue
        enddo
 
        where(belowthreshold) my_compatibility(1,:,s1,n) = 0.0_preal
        where(belowthreshold) my_compatibility(2,:,s1,n) = 0.0_preal
 
      enddo myslipsystems
    endif
 
  enddo neighbors
 
  compatibility(:,:,:,:,i,e) = my_compatibility
 
  end associate
 
end subroutine plastic_nonlocal_updatecompatibility
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine plastic_nonlocal_results(instance,group)
 
  integer,         intent(in) :: instance
  character(len=*),intent(in) :: group
 
  integer :: o
 
  associate(prm => param(instance),dst => microstructure(instance),stt=>state(instance))
  outputsloop: do o = 1,size(prm%output)
    select case(trim(prm%output(o)))
      case('rho_sgl_mob_edg_pos')
        if(prm%sum_N_sl>0) call results_writedataset(group,stt%rho_sgl_mob_edg_pos, 'rho_sgl_mob_edg_pos', &
                                                     'positive mobile edge density','1/m²')
      case('rho_sgl_imm_edg_pos')
        if(prm%sum_N_sl>0) call results_writedataset(group,stt%rho_sgl_imm_edg_pos, 'rho_sgl_imm_edg_pos',&
                                                     'positive immobile edge density','1/m²')
      case('rho_sgl_mob_edg_neg')
        if(prm%sum_N_sl>0) call results_writedataset(group,stt%rho_sgl_mob_edg_neg, 'rho_sgl_mob_edg_neg',&
                                                     'negative mobile edge density','1/m²')
      case('rho_sgl_imm_edg_neg')
        if(prm%sum_N_sl>0) call results_writedataset(group,stt%rho_sgl_imm_edg_neg, 'rho_sgl_imm_edg_neg',&
                                                     'negative immobile edge density','1/m²')
      case('rho_dip_edg')
        if(prm%sum_N_sl>0) call results_writedataset(group,stt%rho_dip_edg, 'rho_dip_edg',&
                                                     'edge dipole density','1/m²')
      case('rho_sgl_mob_scr_pos')
        if(prm%sum_N_sl>0) call results_writedataset(group,stt%rho_sgl_mob_scr_pos, 'rho_sgl_mob_scr_pos',&
                                                     'positive mobile screw density','1/m²')
      case('rho_sgl_imm_scr_pos')
        if(prm%sum_N_sl>0) call results_writedataset(group,stt%rho_sgl_imm_scr_pos, 'rho_sgl_imm_scr_pos',&
                                                     'positive immobile screw density','1/m²')
      case('rho_sgl_mob_scr_neg')
        if(prm%sum_N_sl>0) call results_writedataset(group,stt%rho_sgl_mob_scr_neg, 'rho_sgl_mob_scr_neg',&
                                                     'negative mobile screw density','1/m²')
      case('rho_sgl_imm_scr_neg')
        if(prm%sum_N_sl>0) call results_writedataset(group,stt%rho_sgl_imm_scr_neg, 'rho_sgl_imm_scr_neg',&
                                                     'negative immobile screw density','1/m²')
      case('rho_dip_scr')
        if(prm%sum_N_sl>0) call results_writedataset(group,stt%rho_dip_scr, 'rho_dip_scr',&
                                                     'screw dipole density','1/m²')
      case('rho_forest')
        if(prm%sum_N_sl>0) call results_writedataset(group,stt%rho_forest, 'rho_forest',&
                                                     'forest density','1/m²')
      case('v_edg_pos')
        if(prm%sum_N_sl>0) call results_writedataset(group,stt%v_edg_pos, 'v_edg_pos',&
                                                     'positive edge velocity','m/s')
      case('v_edg_neg')
        if(prm%sum_N_sl>0) call results_writedataset(group,stt%v_edg_neg, 'v_edg_neg',&
                                                     'negative edge velocity','m/s')
      case('v_scr_pos')
        if(prm%sum_N_sl>0) call results_writedataset(group,stt%v_scr_pos, 'v_scr_pos',&
                                                     'positive srew velocity','m/s')
      case('v_scr_neg')
        if(prm%sum_N_sl>0) call results_writedataset(group,stt%v_scr_neg, 'v_scr_neg',&
                                                     'negative screw velocity','m/s')
      case('gamma')
        if(prm%sum_N_sl>0) call results_writedataset(group,stt%gamma,'gamma',&
                                                     'plastic shear','1')
      case('tau_pass')
        if(prm%sum_N_sl>0) call results_writedataset(group,dst%tau_pass,'tau_pass',&
                                                     'passing stress for slip','Pa')
    end select
  enddo outputsloop
  end associate
 
end subroutine plastic_nonlocal_results
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine stateinit(ini,phase,NipcMyPhase)
 
  type(tinitialparameters) :: &
    ini
  integer,intent(in) :: &
    phase, &
    NipcMyPhase
  integer :: &
    e, &
    i, &
    f, &
    from, &
    upto, &
    s, &
    instance, &
    phasemember
  real(pReal), dimension(2) :: &
    noise, &
    rnd
  real(pReal) :: &
    meanDensity, &
    totalVolume, &
    densityBinning, &
    minimumIpVolume
  real(pReal), dimension(NipcMyPhase) :: &
    volume
 
  instance = phase_plasticityinstance(phase)
  associate(stt => state(instance))
 
  if (ini%rhoSglRandom > 0.0_preal) then ! randomly distribute dislocation segments on random slip system and of random type in the volume
    do e = 1,discretization_nelem
      do i = 1,discretization_nip
        if (material_phaseat(1,e) == phase) volume(material_phasememberat(1,i,e)) = ipvolume(i,e)
      enddo
    enddo
    totalvolume     = sum(volume)
    minimumipvolume = minval(volume)
    densitybinning  = ini%rhoSglRandomBinning / minimumipvolume ** (2.0_preal / 3.0_preal)
 
    ! fill random material points with dislocation segments until the desired overall density is reached
    meandensity = 0.0_preal
    do while(meandensity < ini%rhoSglRandom)
      call random_number(rnd)
      phasemember = nint(rnd(1)*real(nipcmyphase,preal) + 0.5_preal)
      s           = nint(rnd(2)*real(sum(ini%N_sl),preal)*4.0_preal + 0.5_preal)
      meandensity = meandensity + densitybinning * volume(phasemember) / totalvolume
      stt%rhoSglMobile(s,phasemember) = densitybinning
    enddo
  else                                ! homogeneous distribution with noise
    do e = 1, nipcmyphase
      do f = 1,size(ini%N_sl,1)
        from = 1 + sum(ini%N_sl(1:f-1))
        upto = sum(ini%N_sl(1:f))
        do s = from,upto
          noise = [math_samplegaussvar(0.0_preal, ini%rhoSglScatter), &
                   math_samplegaussvar(0.0_preal, ini%rhoSglScatter)]
          stt%rho_sgl_mob_edg_pos(s,e) = ini%rhoSglEdgePos0(f)  + noise(1)
          stt%rho_sgl_mob_edg_neg(s,e) = ini%rhoSglEdgeNeg0(f)  + noise(1)
          stt%rho_sgl_mob_scr_pos(s,e) = ini%rhoSglScrewPos0(f) + noise(2)
          stt%rho_sgl_mob_scr_neg(s,e) = ini%rhoSglScrewNeg0(f) + noise(2)
        enddo
        stt%rho_dip_edg(from:upto,e)   = ini%rhoDipEdge0(f)
        stt%rho_dip_scr(from:upto,e)   = ini%rhoDipScrew0(f)
      enddo
    enddo
  endif
 
  end associate
 
end subroutine stateinit
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine kinetics(v, dv_dtau, dv_dtauNS, tau, tauNS, tauThreshold, c, Temperature, instance)
 
  integer, intent(in) :: &
    c, &                                                                                            !< dislocation character (1:edge, 2:screw)
    instance
  real(pReal), intent(in) :: &
    Temperature
  real(pReal), dimension(param(instance)%sum_N_sl), intent(in) :: &
    tau, &                                                                                          !< resolved external shear stress (without non Schmid effects)
    tauNS, &                                                                                        !< resolved external shear stress (including non Schmid effects)
    tauThreshold
  real(pReal), dimension(param(instance)%sum_N_sl), intent(out) ::  &
    v, &                                                                                            !< velocity
    dv_dtau, &                                                                                      !< velocity derivative with respect to resolved shear stress (without non Schmid contributions)
    dv_dtauNS
 
  integer :: &
    ns, &                                                                                           !< short notation for the total number of active slip systems
    s
  real(pReal) :: &
    tauRel_P, &
    tauRel_S, &
    tauEff, &                                                                                       !< effective shear stress
    tPeierls, &                                                                                     !< waiting time in front of a peierls barriers
    tSolidSolution, &                                                                               !< waiting time in front of a solid solution obstacle
    vViscous, &                                                                                     !< viscous glide velocity
    dtPeierls_dtau, &                                                                               !< derivative with respect to resolved shear stress
    dtSolidSolution_dtau, &                                                                         !< derivative with respect to resolved shear stress
    meanfreepath_S, &                                                                               !< mean free travel distance for dislocations between two solid solution obstacles
    meanfreepath_P, &                                                                               !< mean free travel distance for dislocations between two Peierls barriers
    jumpWidth_P, &                                                                                  !< depth of activated area
    jumpWidth_S, &                                                                                  !< depth of activated area
    activationLength_P, &                                                                           !< length of activated dislocation line
    activationLength_S, &                                                                           !< length of activated dislocation line
    activationVolume_P, &                                                                           !< volume that needs to be activated to overcome barrier
    activationVolume_S, &                                                                           !< volume that needs to be activated to overcome barrier
    activationEnergy_P, &                                                                           !< energy that is needed to overcome barrier
    activationEnergy_S, &                                                                           !< energy that is needed to overcome barrier
    criticalStress_P, &                                                                             !< maximum obstacle strength
    criticalStress_S, &                                                                             !< maximum obstacle strength
    mobility
 
  associate(prm => param(instance))
  ns = prm%sum_N_sl
  v = 0.0_preal
  dv_dtau = 0.0_preal
  dv_dtauns = 0.0_preal
 
  do s = 1,ns
    if (abs(tau(s)) > tauthreshold(s)) then
 
      !* Peierls contribution
      !* Effective stress includes non Schmid constributions
      !* The derivative only gives absolute values; the correct sign is taken care of in the formula for the derivative of the velocity
      taueff = max(0.0_preal, abs(tauns(s)) - tauthreshold(s))                                      ! ensure that the effective stress is positive
      meanfreepath_p = prm%burgers(s)
      jumpwidth_p = prm%burgers(s)
      activationlength_p = prm%doublekinkwidth *prm%burgers(s)
      activationvolume_p = activationlength_p * jumpwidth_p * prm%burgers(s)
      criticalstress_p = prm%peierlsStress(s,c)
      activationenergy_p = criticalstress_p * activationvolume_p
      taurel_p = min(1.0_preal, taueff / criticalstress_p)                                          ! ensure that the activation probability cannot become greater than one
      tpeierls = 1.0_preal / prm%fattack &
               * exp(activationenergy_p / (kb * temperature) &
                     * (1.0_preal - taurel_p**prm%p)**prm%q)
      if (taueff < criticalstress_p) then
        dtpeierls_dtau = tpeierls * prm%p * prm%q * activationvolume_p / (kb * temperature) &
                       * (1.0_preal - taurel_p**prm%p)**(prm%q-1.0_preal) * taurel_p**(prm%p-1.0_preal)
      else
        dtpeierls_dtau = 0.0_preal
      endif
 
      !* Contribution from solid solution strengthening
      !* The derivative only gives absolute values; the correct sign is taken care of in the formula for the derivative of the velocity
      taueff = abs(tau(s)) - tauthreshold(s)
      meanfreepath_s = prm%burgers(s) / sqrt(prm%solidSolutionConcentration)
      jumpwidth_s = prm%solidSolutionSize * prm%burgers(s)
      activationlength_s = prm%burgers(s) / sqrt(prm%solidSolutionConcentration)
      activationvolume_s = activationlength_s * jumpwidth_s * prm%burgers(s)
      activationenergy_s = prm%solidSolutionEnergy
      criticalstress_s = activationenergy_s / activationvolume_s
      taurel_s = min(1.0_preal, taueff / criticalstress_s)                                          ! ensure that the activation probability cannot become greater than one
      tsolidsolution = 1.0_preal /  prm%fattack &
                     * exp(activationenergy_s / (kb * temperature)* (1.0_preal - taurel_s**prm%p)**prm%q)
      if (taueff < criticalstress_s) then
        dtsolidsolution_dtau = tsolidsolution * prm%p * prm%q * activationvolume_s / (kb * temperature) &
                             * (1.0_preal - taurel_s**prm%p)**(prm%q-1.0_preal)* taurel_s**(prm%p-1.0_preal)
      else
        dtsolidsolution_dtau = 0.0_preal
      endif
 
      !* viscous glide velocity
      taueff = abs(tau(s)) - tauthreshold(s)
      mobility = prm%burgers(s) / prm%viscosity
      vviscous = mobility * taueff
 
      !* Mean velocity results from waiting time at peierls barriers and solid solution obstacles with respective meanfreepath of
      !* free flight at glide velocity in between.
      !* adopt sign from resolved stress
      v(s) = sign(1.0_preal,tau(s)) &
           / (tpeierls / meanfreepath_p + tsolidsolution / meanfreepath_s + 1.0_preal / vviscous)
      dv_dtau(s)   = v(s)**2.0_preal * (dtsolidsolution_dtau / meanfreepath_s + mobility /vviscous**2.0_preal)
      dv_dtauns(s) = v(s)**2.0_preal * dtpeierls_dtau / meanfreepath_p
    endif
  enddo
 
  end associate
 
end subroutine kinetics
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function getrho(instance,of,ip,el)
 
  integer, intent(in) :: instance, of,ip,el
  real(preal), dimension(param(instance)%sum_N_sl,10) :: getrho
 
  associate(prm => param(instance))
 
  getrho = reshape(state(instance)%rho(:,of),[prm%sum_N_sl,10])
 
  ! ensure positive densities (not for imm, they have a sign)
  getrho(:,mob) = max(getrho(:,mob),0.0_preal)
  getrho(:,dip) = max(getrho(:,dip),0.0_preal)
 
  where(abs(getrho) < max(prm%significantN/ipvolume(ip,el)**(2.0_preal/3.0_preal),prm%significantRho)) &
    getrho = 0.0_preal
 
  end associate
 
end function getrho
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function getrho0(instance,of,ip,el)
 
  integer, intent(in) :: instance, of,ip,el
  real(preal), dimension(param(instance)%sum_N_sl,10) :: getrho0
 
  associate(prm => param(instance))
 
  getrho0 = reshape(state0(instance)%rho(:,of),[prm%sum_N_sl,10])
 
  ! ensure positive densities (not for imm, they have a sign)
  getrho0(:,mob) = max(getrho0(:,mob),0.0_preal)
  getrho0(:,dip) = max(getrho0(:,dip),0.0_preal)
 
  where(abs(getrho0) < max(prm%significantN/ipvolume(ip,el)**(2.0_preal/3.0_preal),prm%significantRho)) &
    getrho0 = 0.0_preal
 
  end associate
 
end function getrho0
 
end submodule plastic_nonlocal
# 44 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/crystallite.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
 
module crystallite
  use prec
  use io
  use hdf5_utilities
  use damask_interface
  use config
  use debug
  use numerics
  use rotations
  use math
  use fesolving
  use material
  use constitutive
  use discretization
  use lattice
  use results
 
  implicit none
  private
 
  real(preal),               dimension(:,:,:),        allocatable, public :: &
    crystallite_dt
  real(preal),               dimension(:,:,:),        allocatable :: &
    crystallite_subdt, &                                                                            !< substepped time increment of each grain
    crystallite_subfrac, &                                                                          !< already calculated fraction of increment
    crystallite_substep
  type(rotation),            dimension(:,:,:),        allocatable :: &
    crystallite_orientation
  real(preal),               dimension(:,:,:,:,:),    allocatable, public, protected :: &
    crystallite_fe, &                                                                               !< current "elastic" def grad (end of converged time step)
    crystallite_p, &                                                                                !< 1st Piola-Kirchhoff stress per grain
    crystallite_s0, &                                                                               !< 2nd Piola-Kirchhoff stress vector at start of FE inc
    crystallite_fp0, &                                                                              !< plastic def grad at start of FE inc
    crystallite_fi0, &                                                                              !< intermediate def grad at start of FE inc
    crystallite_f0, &                                                                               !< def grad at start of FE inc
    crystallite_lp0, &                                                                              !< plastic velocitiy grad at start of FE inc
    crystallite_li0
  real(preal),               dimension(:,:,:,:,:),    allocatable, public :: &
    crystallite_s, &                                                                                !< current 2nd Piola-Kirchhoff stress vector (end of converged time step)
    crystallite_partioneds0, &                                                                      !< 2nd Piola-Kirchhoff stress vector at start of homog inc
    crystallite_fp, &                                                                               !< current plastic def grad (end of converged time step)
    crystallite_partionedfp0,&                                                                      !< plastic def grad at start of homog inc
    crystallite_fi, &                                                                               !< current intermediate def grad (end of converged time step)
    crystallite_partionedfi0,&                                                                      !< intermediate def grad at start of homog inc
    crystallite_partionedf,  &                                                                      !< def grad to be reached at end of homog inc
    crystallite_partionedf0, &                                                                      !< def grad at start of homog inc
    crystallite_lp, &                                                                               !< current plastic velocitiy grad (end of converged time step)
    crystallite_partionedlp0, &                                                                     !< plastic velocity grad at start of homog inc
    crystallite_li, &                                                                               !< current intermediate velocitiy grad (end of converged time step)
    crystallite_partionedli0
  real(preal),                dimension(:,:,:,:,:),    allocatable :: &
    crystallite_subfp0,&                                                                            !< plastic def grad at start of crystallite inc
    crystallite_subfi0,&                                                                            !< intermediate def grad at start of crystallite inc
    crystallite_subf,  &                                                                            !< def grad to be reached at end of crystallite inc
    crystallite_subf0, &                                                                            !< def grad at start of crystallite inc
    crystallite_sublp0,&                                                                            !< plastic velocity grad at start of crystallite inc
    crystallite_subli0
  real(preal),                dimension(:,:,:,:,:,:,:), allocatable, public, protected :: &
    crystallite_dpdf
  logical,                    dimension(:,:,:),         allocatable, public :: &
    crystallite_requested
  logical,                    dimension(:,:,:),         allocatable :: &
    crystallite_converged, &                                                                        !< convergence flag
    crystallite_todo, &                                                                             !< flag to indicate need for further computation
    crystallite_localplasticity
 
  type :: toutput                                                                                   
    character(len=pStringLen), allocatable, dimension(:) :: &
      label
  end type toutput
  type(toutput), allocatable, dimension(:) :: output_constituent
 
  type :: tnumerics
    integer :: &
      ijacolpresiduum, &                                                                            !< frequency of Jacobian update of residuum in Lp
      nstate, &                                                                                     !< state loop limit
      nstress
    real(preal) :: &
      substepmincryst, &                                                                            !< minimum (relative) size of sub-step allowed during cutback
      substepsizecryst, &                                                                           !< size of first substep when cutback
      substepsizelp, &                                                                              !< size of first substep when cutback in Lp calculation
      substepsizeli, &                                                                              !< size of first substep when cutback in Li calculation
      stepincreasecryst, &                                                                          !< increase of next substep size when previous substep converged
      rtol_crystallitestate, &                                                                      !< relative tolerance in state loop
      rtol_crystallitestress, &                                                                     !< relative tolerance in stress loop
      atol_crystallitestress
  end type tnumerics
 
  type(tnumerics) :: num                                                                            ! numerics parameters. Better name?
 
  procedure(), pointer :: integratestate
 
  public :: &
    crystallite_init, &
    crystallite_stress, &
    crystallite_stresstangent, &
    crystallite_orientations, &
    crystallite_push33toref, &
    crystallite_results, &
    crystallite_restartwrite, &
    crystallite_restartread, &
    crystallite_forward
 
contains
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine crystallite_init
 
  logical, dimension(discretization_nIP,discretization_nElem) :: devNull
  integer :: &
    c, &                                                                                            !< counter in integration point component loop
    i, &                                                                                            !< counter in integration point loop
    e, &                                                                                            !< counter in element loop
    cMax, &                                                                                         !< maximum number of  integration point components
    iMax, &                                                                                         !< maximum number of integration points
    eMax, &                                                                                         !< maximum number of elements
    myNcomponents
 
  write(6,'(/,a)')   ' <<<+-  crystallite init  -+>>>'
 
  cmax = homogenization_maxngrains
  imax = discretization_nip
  emax = discretization_nelem
 
  allocate(crystallite_partionedf(3,3,cmax,imax,emax),source=0.0_preal)
 
  allocate(crystallite_s0, &
           crystallite_f0, crystallite_fi0,crystallite_fp0, &
                           crystallite_li0,crystallite_lp0, &
           crystallite_partioneds0, &
           crystallite_partionedf0,crystallite_partionedfp0,crystallite_partionedfi0, &
                                   crystallite_partionedlp0,crystallite_partionedli0, &
           crystallite_s,crystallite_p, &
           crystallite_fe,crystallite_fi,crystallite_fp, &
                          crystallite_li,crystallite_lp, &
           crystallite_subf,crystallite_subf0, &
           crystallite_subfp0,crystallite_subfi0, &
           crystallite_subli0,crystallite_sublp0, &
           source = crystallite_partionedf)
 
  allocate(crystallite_dpdf(3,3,3,3,cmax,imax,emax),source=0.0_preal)
 
  allocate(crystallite_dt(cmax,imax,emax),source=0.0_preal)
  allocate(crystallite_subdt,crystallite_subfrac,crystallite_substep, &
           source = crystallite_dt)
 
  allocate(crystallite_orientation(cmax,imax,emax))
 
  allocate(crystallite_localplasticity(cmax,imax,emax),       source=.true.)
  allocate(crystallite_requested(cmax,imax,emax),             source=.false.)
  allocate(crystallite_todo(cmax,imax,emax),                  source=.false.)
  allocate(crystallite_converged(cmax,imax,emax),             source=.true.)
 
  num%subStepMinCryst        = config_numerics%getFloat('substepmincryst',       defaultval=1.0e-3_preal)
  num%subStepSizeCryst       = config_numerics%getFloat('substepsizecryst',      defaultval=0.25_preal)
  num%stepIncreaseCryst      = config_numerics%getFloat('stepincreasecryst',     defaultval=1.5_preal)
 
  num%subStepSizeLp          = config_numerics%getFloat('substepsizelp',         defaultval=0.5_preal)
  num%subStepSizeLi          = config_numerics%getFloat('substepsizeli',         defaultval=0.5_preal)
 
  num%rtol_crystalliteState  = config_numerics%getFloat('rtol_crystallitestate', defaultval=1.0e-6_preal)
  num%rtol_crystalliteStress = config_numerics%getFloat('rtol_crystallitestress',defaultval=1.0e-6_preal)
  num%atol_crystalliteStress = config_numerics%getFloat('atol_crystallitestress',defaultval=1.0e-8_preal)
 
  num%iJacoLpresiduum        = config_numerics%getInt  ('ijacolpresiduum',       defaultval=1)
 
  num%nState                 = config_numerics%getInt  ('nstate',                defaultval=20)
  num%nStress                = config_numerics%getInt  ('nstress',               defaultval=40)
 
  if(num%subStepMinCryst   <= 0.0_preal)      call io_error(301,ext_msg='subStepMinCryst')
  if(num%subStepSizeCryst  <= 0.0_preal)      call io_error(301,ext_msg='subStepSizeCryst')
  if(num%stepIncreaseCryst <= 0.0_preal)      call io_error(301,ext_msg='stepIncreaseCryst')
 
  if(num%subStepSizeLp <= 0.0_preal)          call io_error(301,ext_msg='subStepSizeLp')
  if(num%subStepSizeLi <= 0.0_preal)          call io_error(301,ext_msg='subStepSizeLi')
 
  if(num%rtol_crystalliteState  <= 0.0_preal) call io_error(301,ext_msg='rtol_crystalliteState')
  if(num%rtol_crystalliteStress <= 0.0_preal) call io_error(301,ext_msg='rtol_crystalliteStress')
  if(num%atol_crystalliteStress <= 0.0_preal) call io_error(301,ext_msg='atol_crystalliteStress')
 
  if(num%iJacoLpresiduum < 1)                 call io_error(301,ext_msg='iJacoLpresiduum')
 
  if(num%nState < 1)                          call io_error(301,ext_msg='nState')
  if(num%nStress< 1)                          call io_error(301,ext_msg='nStress')
 
  select case(numerics_integrator)
    case(1)
      integratestate => integratestatefpi
    case(2)
      integratestate => integratestateeuler
    case(3)
      integratestate => integratestateadaptiveeuler
    case(4)
      integratestate => integratestaterk4
    case(5)
      integratestate => integratestaterkck45
  end select
 
  allocate(output_constituent(size(config_phase)))
  do c = 1, size(config_phase)
 
    allocate(output_constituent(c)%label(1))
    output_constituent(c)%label(1)= 'GfortranBug86277'
    output_constituent(c)%label  = config_phase(c)%getStrings('(output)',defaultval=output_constituent(c)%label )
    if (output_constituent(c)%label (1) == 'GfortranBug86277') output_constituent(c)%label  = [character(len=pStringLen)::]
 
 
 
  enddo
 
  call config_deallocate('material.config/phase')
 
!--------------------------------------------------------------------------------------------------
! initialize
 !$OMP PARALLEL DO PRIVATE(myNcomponents,i,c)
  do e = fesolving_execelem(1),fesolving_execelem(2)
    myncomponents = homogenization_ngrains(material_homogenizationat(e))
    do i = fesolving_execip(1), fesolving_execip(2); do c = 1, myncomponents
      crystallite_fp0(1:3,1:3,c,i,e) = material_orientation0(c,i,e)%asMatrix()                      ! plastic def gradient reflects init orientation
      crystallite_fp0(1:3,1:3,c,i,e) = crystallite_fp0(1:3,1:3,c,i,e) &
                                     / math_det33(crystallite_fp0(1:3,1:3,c,i,e))**(1.0_preal/3.0_preal)
      crystallite_fi0(1:3,1:3,c,i,e) = constitutive_initialfi(c,i,e)
      crystallite_f0(1:3,1:3,c,i,e)  = math_i3
      crystallite_localplasticity(c,i,e) = phase_localplasticity(material_phaseat(c,e))
      crystallite_fe(1:3,1:3,c,i,e)  = math_inv33(matmul(crystallite_fi0(1:3,1:3,c,i,e), &
                                                         crystallite_fp0(1:3,1:3,c,i,e)))           ! assuming that euler angles are given in internal strain free configuration
      crystallite_fp(1:3,1:3,c,i,e)  = crystallite_fp0(1:3,1:3,c,i,e)
      crystallite_fi(1:3,1:3,c,i,e)  = crystallite_fi0(1:3,1:3,c,i,e)
      crystallite_requested(c,i,e) = .true.
    enddo; enddo
  enddo
  !$OMP END PARALLEL DO
 
  if(any(.not. crystallite_localplasticity) .and. .not. usepingpong) call io_error(601)             ! exit if nonlocal but no ping-pong ToDo: Why not check earlier? or in nonlocal?
 
  crystallite_partionedfp0 = crystallite_fp0
  crystallite_partionedfi0 = crystallite_fi0
  crystallite_partionedf0  = crystallite_f0
  crystallite_partionedf   = crystallite_f0
 
  call crystallite_orientations()
 
  !$OMP PARALLEL DO
  do e = fesolving_execelem(1),fesolving_execelem(2)
    do i = fesolving_execip(1),fesolving_execip(2)
      do c = 1,homogenization_ngrains(material_homogenizationat(e))
        call constitutive_dependentstate(crystallite_partionedf0(1:3,1:3,c,i,e), &
                                         crystallite_partionedfp0(1:3,1:3,c,i,e), &
                                         c,i,e)                                                     ! update dependent state variables to be consistent with basic states
     enddo
    enddo
  enddo
  !$OMP END PARALLEL DO
 
  devnull = crystallite_stress()
  call crystallite_stresstangent
 
# 283 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/crystallite.f90"
 
end subroutine crystallite_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function crystallite_stress(dummyArgumentToPreventInternalCompilerErrorWithGCC)
 
  logical, dimension(discretization_nIP,discretization_nElem) :: crystallite_stress
  real(preal), intent(in), optional :: &
    dummyargumenttopreventinternalcompilererrorwithgcc
  real(preal) :: &
    formersubstep
  integer :: &
    niterationcrystallite, &                                                                        ! number of iterations in crystallite loop
    c, &                                                                                            !< counter in integration point component loop
    i, &                                                                                            !< counter in integration point loop
    e, &                                                                                            !< counter in element loop
    startip, endip, &
    s
 
# 325 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/crystallite.f90"
 
!--------------------------------------------------------------------------------------------------
! initialize to starting condition
  crystallite_substep = 0.0_preal
  !$OMP PARALLEL DO
  elementlooping1: do e = fesolving_execelem(1),fesolving_execelem(2)
    do i = fesolving_execip(1),fesolving_execip(2); do c = 1,homogenization_ngrains(material_homogenizationat(e))
      homogenizationrequestscalculation: if (crystallite_requested(c,i,e)) then
        plasticstate(material_phaseat(c,e))%subState0(      :,material_phasememberat(c,i,e)) = &
        plasticstate(material_phaseat(c,e))%partionedState0(:,material_phasememberat(c,i,e))
 
        do s = 1, phase_nsources(material_phaseat(c,e))
          sourcestate(material_phaseat(c,e))%p(s)%subState0(      :,material_phasememberat(c,i,e)) = &
          sourcestate(material_phaseat(c,e))%p(s)%partionedState0(:,material_phasememberat(c,i,e))
        enddo
        crystallite_subfp0(1:3,1:3,c,i,e) = crystallite_partionedfp0(1:3,1:3,c,i,e)
        crystallite_sublp0(1:3,1:3,c,i,e) = crystallite_partionedlp0(1:3,1:3,c,i,e)
        crystallite_subfi0(1:3,1:3,c,i,e) = crystallite_partionedfi0(1:3,1:3,c,i,e)
        crystallite_subli0(1:3,1:3,c,i,e) = crystallite_partionedli0(1:3,1:3,c,i,e)
        crystallite_subf0(1:3,1:3,c,i,e)  = crystallite_partionedf0(1:3,1:3,c,i,e)
        crystallite_subfrac(c,i,e) = 0.0_preal
        crystallite_substep(c,i,e) = 1.0_preal/num%subStepSizeCryst
        crystallite_todo(c,i,e) = .true.
        crystallite_converged(c,i,e) = .false.                                                      ! pretend failed step of 1/subStepSizeCryst
      endif homogenizationrequestscalculation
    enddo; enddo
  enddo elementlooping1
  !$OMP END PARALLEL DO
 
  singlerun: if (fesolving_execelem(1) == fesolving_execelem(2) .and. &
                 fesolving_execip(1) == fesolving_execip(2)) then
    startip = fesolving_execip(1)
    endip   = startip
  else singlerun
    startip = 1
    endip   = discretization_nip
  endif singlerun
 
  niterationcrystallite = 0
  cutbacklooping: do while (any(crystallite_todo(:,startip:endip,fesolving_execelem(1):fesolving_execelem(2))))
    niterationcrystallite = niterationcrystallite + 1
 
 
 
 
 
    !$OMP PARALLEL DO PRIVATE(formerSubStep)
    elementlooping3: do e = fesolving_execelem(1),fesolving_execelem(2)
      do i = fesolving_execip(1),fesolving_execip(2)
        do c = 1,homogenization_ngrains(material_homogenizationat(e))
!--------------------------------------------------------------------------------------------------
!  wind forward
          if (crystallite_converged(c,i,e)) then
            formersubstep = crystallite_substep(c,i,e)
            crystallite_subfrac(c,i,e) = crystallite_subfrac(c,i,e) + crystallite_substep(c,i,e)
            crystallite_substep(c,i,e) = min(1.0_preal - crystallite_subfrac(c,i,e), &
                                             num%stepIncreaseCryst * crystallite_substep(c,i,e))
 
            crystallite_todo(c,i,e) = crystallite_substep(c,i,e) > 0.0_preal                        ! still time left to integrate on?
            if (crystallite_todo(c,i,e)) then
              crystallite_subf0(1:3,1:3,c,i,e) = crystallite_subf(1:3,1:3,c,i,e)
              crystallite_sublp0(1:3,1:3,c,i,e) = crystallite_lp(1:3,1:3,c,i,e)
              crystallite_subli0(1:3,1:3,c,i,e) = crystallite_li(1:3,1:3,c,i,e)
              crystallite_subfp0(1:3,1:3,c,i,e) = crystallite_fp(1:3,1:3,c,i,e)
              crystallite_subfi0(1:3,1:3,c,i,e) = crystallite_fi(1:3,1:3,c,i,e)
              !if abbrevation, make c and p private in omp
              plasticstate(    material_phaseat(c,e))%subState0(:,material_phasememberat(c,i,e)) &
                = plasticstate(material_phaseat(c,e))%state(    :,material_phasememberat(c,i,e))
              do s = 1, phase_nsources(material_phaseat(c,e))
                sourcestate(    material_phaseat(c,e))%p(s)%subState0(:,material_phasememberat(c,i,e)) &
                  = sourcestate(material_phaseat(c,e))%p(s)%state(    :,material_phasememberat(c,i,e))
              enddo
            endif
 
!--------------------------------------------------------------------------------------------------
!  cut back (reduced time and restore)
          else
            crystallite_substep(c,i,e)       = num%subStepSizeCryst * crystallite_substep(c,i,e)
            crystallite_fp(1:3,1:3,c,i,e) =            crystallite_subfp0(1:3,1:3,c,i,e)
            crystallite_fi(1:3,1:3,c,i,e) =            crystallite_subfi0(1:3,1:3,c,i,e)
            crystallite_s(1:3,1:3,c,i,e) =            crystallite_s0(1:3,1:3,c,i,e)
            if (crystallite_substep(c,i,e) < 1.0_preal) then                                        ! actual (not initial) cutback
              crystallite_lp(1:3,1:3,c,i,e) =            crystallite_sublp0(1:3,1:3,c,i,e)
              crystallite_li(1:3,1:3,c,i,e) =            crystallite_subli0(1:3,1:3,c,i,e)
            endif
            plasticstate(material_phaseat(c,e))%state(    :,material_phasememberat(c,i,e)) &
              = plasticstate(material_phaseat(c,e))%subState0(:,material_phasememberat(c,i,e))
            do s = 1, phase_nsources(material_phaseat(c,e))
              sourcestate(    material_phaseat(c,e))%p(s)%state(    :,material_phasememberat(c,i,e)) &
                = sourcestate(material_phaseat(c,e))%p(s)%subState0(:,material_phasememberat(c,i,e))
            enddo
 
                                                                                                    ! cant restore dotState here, since not yet calculated in first cutback after initialization
            crystallite_todo(c,i,e) = crystallite_substep(c,i,e) > num%subStepMinCryst              ! still on track or already done (beyond repair)
          endif
 
!--------------------------------------------------------------------------------------------------
!  prepare for integration
          if (crystallite_todo(c,i,e)) then
            crystallite_subf(1:3,1:3,c,i,e) = crystallite_subf0(1:3,1:3,c,i,e) &
                                            + crystallite_substep(c,i,e) *( crystallite_partionedf(1:3,1:3,c,i,e) &
                                                                           -crystallite_partionedf0(1:3,1:3,c,i,e))
            crystallite_fe(1:3,1:3,c,i,e) = matmul(matmul(crystallite_subf(1:3,1:3,c,i,e), &
                                                          math_inv33(crystallite_fp(1:3,1:3,c,i,e))), &
                                                   math_inv33(crystallite_fi(1:3,1:3,c,i,e)))
            crystallite_subdt(c,i,e) = crystallite_substep(c,i,e) * crystallite_dt(c,i,e)
            crystallite_converged(c,i,e) = .false.
          endif
 
        enddo
      enddo
    enddo elementlooping3
    !$OMP END PARALLEL DO
 
!--------------------------------------------------------------------------------------------------
!  integrate --- requires fully defined state array (basic + dependent state)
    if (any(crystallite_todo)) call integratestate                                                  ! TODO: unroll into proper elementloop to avoid N^2 for single point evaluation
    where(.not. crystallite_converged .and. crystallite_substep > num%subStepMinCryst) &            ! do not try non-converged but fully cutbacked any further
      crystallite_todo = .true.                                                                     ! TODO: again unroll this into proper elementloop to avoid N^2 for single point evaluation
 
 
  enddo cutbacklooping
 
! return whether converged or not
  crystallite_stress = .false.
  elementlooping5: do e = fesolving_execelem(1),fesolving_execelem(2)
    do i = fesolving_execip(1),fesolving_execip(2)
      crystallite_stress(i,e) = all(crystallite_converged(:,i,e))
    enddo
  enddo elementlooping5
 
end function crystallite_stress
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine crystallite_stresstangent
 
  integer :: &
    c, &                                                                                            !< counter in integration point component loop
    i, &                                                                                            !< counter in integration point loop
    e, &                                                                                            !< counter in element loop
    o, &
    p
 
  real(pReal), dimension(3,3)     ::   devNull, &
                                       invSubFp0,invSubFi0,invFp,invFi, &
                                       temp_33_1, temp_33_2, temp_33_3, temp_33_4
  real(pReal), dimension(3,3,3,3) ::   dSdFe, &
                                       dSdF, &
                                       dSdFi, &
                                       dLidS, &                                                     ! tangent in lattice configuration
                                       dLidFi, &
                                       dLpdS, &
                                       dLpdFi, &
                                       dFidS, &
                                       dFpinvdF, &
                                       rhs_3333, &
                                       lhs_3333, &
                                       temp_3333
  real(pReal), dimension(9,9)::        temp_99
  logical :: error
 
  !$OMP PARALLEL DO PRIVATE(dSdF,dSdFe,dSdFi,dLpdS,dLpdFi,dFpinvdF,dLidS,dLidFi,dFidS,o,p, &
  !$OMP                     invSubFp0,invSubFi0,invFp,invFi, &
  !$OMP                     rhs_3333,lhs_3333,temp_99,temp_33_1,temp_33_2,temp_33_3,temp_33_4,temp_3333,error)
  elementlooping: do e = fesolving_execelem(1),fesolving_execelem(2)
    do i = fesolving_execip(1),fesolving_execip(2)
      do c = 1,homogenization_ngrains(material_homogenizationat(e))
 
        call constitutive_sanditstangents(devnull,dsdfe,dsdfi, &
                                         crystallite_fe(1:3,1:3,c,i,e), &
                                         crystallite_fi(1:3,1:3,c,i,e),c,i,e)
        call constitutive_lianditstangents(devnull,dlids,dlidfi, &
                                           crystallite_s(1:3,1:3,c,i,e), &
                                           crystallite_fi(1:3,1:3,c,i,e), &
                                           c,i,e)
 
        invfp = math_inv33(crystallite_fp(1:3,1:3,c,i,e))
        invfi = math_inv33(crystallite_fi(1:3,1:3,c,i,e))
        invsubfp0 = math_inv33(crystallite_subfp0(1:3,1:3,c,i,e))
        invsubfi0 = math_inv33(crystallite_subfi0(1:3,1:3,c,i,e))
 
        if (sum(abs(dlids)) < tol_math_check) then
          dfids = 0.0_preal
        else
          lhs_3333 = 0.0_preal; rhs_3333 = 0.0_preal
          do o=1,3; do p=1,3
            lhs_3333(1:3,1:3,o,p) = lhs_3333(1:3,1:3,o,p) &
                                  + crystallite_subdt(c,i,e)*matmul(invsubfi0,dlidfi(1:3,1:3,o,p))
            lhs_3333(1:3,o,1:3,p) = lhs_3333(1:3,o,1:3,p) &
                                  + invfi*invfi(p,o)
            rhs_3333(1:3,1:3,o,p) = rhs_3333(1:3,1:3,o,p) &
                                  - crystallite_subdt(c,i,e)*matmul(invsubfi0,dlids(1:3,1:3,o,p))
          enddo; enddo
          call math_invert(temp_99,error,math_3333to99(lhs_3333))
          if (error) then
            call io_warning(warning_id=600,el=e,ip=i,g=c, &
                            ext_msg='inversion error in analytic tangent calculation')
            dfids = 0.0_preal
          else
            dfids = math_mul3333xx3333(math_99to3333(temp_99),rhs_3333)
          endif
          dlids = math_mul3333xx3333(dlidfi,dfids) + dlids
        endif
 
        call constitutive_lpanditstangents(devnull,dlpds,dlpdfi, &
                                           crystallite_s(1:3,1:3,c,i,e), &
                                           crystallite_fi(1:3,1:3,c,i,e),c,i,e)                     ! call constitutive law to calculate Lp tangent in lattice configuration
        dlpds = math_mul3333xx3333(dlpdfi,dfids) + dlpds
 
!--------------------------------------------------------------------------------------------------
! calculate dSdF
        temp_33_1 = transpose(matmul(invfp,invfi))
        temp_33_2 = matmul(crystallite_subf(1:3,1:3,c,i,e),invsubfp0)
        temp_33_3 = matmul(matmul(crystallite_subf(1:3,1:3,c,i,e),invfp), invsubfi0)
 
        do o=1,3; do p=1,3
          rhs_3333(p,o,1:3,1:3)  = matmul(dsdfe(p,o,1:3,1:3),temp_33_1)
          temp_3333(1:3,1:3,p,o) = matmul(matmul(temp_33_2,dlpds(1:3,1:3,p,o)), invfi) &
                                 + matmul(temp_33_3,dlids(1:3,1:3,p,o))
        enddo; enddo
        lhs_3333 = crystallite_subdt(c,i,e)*math_mul3333xx3333(dsdfe,temp_3333) &
                 + math_mul3333xx3333(dsdfi,dfids)
 
        call math_invert(temp_99,error,math_identity2nd(9)+math_3333to99(lhs_3333))
        if (error) then
          call io_warning(warning_id=600,el=e,ip=i,g=c, &
                          ext_msg='inversion error in analytic tangent calculation')
          dsdf = rhs_3333
        else
          dsdf = math_mul3333xx3333(math_99to3333(temp_99),rhs_3333)
        endif
 
!--------------------------------------------------------------------------------------------------
! calculate dFpinvdF
        temp_3333 = math_mul3333xx3333(dlpds,dsdf)
        do o=1,3; do p=1,3
          dfpinvdf(1:3,1:3,p,o) = -crystallite_subdt(c,i,e) &
                                * matmul(invsubfp0, matmul(temp_3333(1:3,1:3,p,o),invfi))
        enddo; enddo
 
!--------------------------------------------------------------------------------------------------
! assemble dPdF
        temp_33_1 = matmul(crystallite_s(1:3,1:3,c,i,e),transpose(invfp))
        temp_33_2 = matmul(invfp,temp_33_1)
        temp_33_3 = matmul(crystallite_subf(1:3,1:3,c,i,e),invfp)
        temp_33_4 = matmul(temp_33_3,crystallite_s(1:3,1:3,c,i,e))
 
        crystallite_dpdf(1:3,1:3,1:3,1:3,c,i,e) = 0.0_preal
        do p=1,3
          crystallite_dpdf(p,1:3,p,1:3,c,i,e) = transpose(temp_33_2)
        enddo
        do o=1,3; do p=1,3
          crystallite_dpdf(1:3,1:3,p,o,c,i,e) = crystallite_dpdf(1:3,1:3,p,o,c,i,e) &
                                              + matmul(matmul(crystallite_subf(1:3,1:3,c,i,e), &
                                                       dfpinvdf(1:3,1:3,p,o)),temp_33_1) &
                                              + matmul(matmul(temp_33_3,dsdf(1:3,1:3,p,o)), &
                                                       transpose(invfp)) &
                                              + matmul(temp_33_4,transpose(dfpinvdf(1:3,1:3,p,o)))
        enddo; enddo
 
    enddo; enddo
  enddo elementlooping
  !$OMP END PARALLEL DO
 
end subroutine crystallite_stresstangent
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine crystallite_orientations
 
  integer &
    c, &                                                                                            !< counter in integration point component loop
    i, &                                                                                            !< counter in integration point loop
    e
 
  !$OMP PARALLEL DO
  do e = fesolving_execelem(1),fesolving_execelem(2)
    do i = fesolving_execip(1),fesolving_execip(2)
      do c = 1,homogenization_ngrains(material_homogenizationat(e))
        call crystallite_orientation(c,i,e)%fromMatrix(transpose(math_rotationalpart(crystallite_fe(1:3,1:3,c,i,e))))
  enddo; enddo; enddo
  !$OMP END PARALLEL DO
 
  nonlocalpresent: if (any(plasticstate%nonLocal)) then
    !$OMP PARALLEL DO
    do e = fesolving_execelem(1),fesolving_execelem(2)
      do i = fesolving_execip(1),fesolving_execip(2)
        if (plasticstate(material_phaseat(1,e))%nonLocal) &
          call plastic_nonlocal_updatecompatibility(crystallite_orientation, &
                                                    phase_plasticityinstance(material_phaseat(i,e)),i,e)
    enddo; enddo
    !$OMP END PARALLEL DO
  endif nonlocalpresent
 
end subroutine crystallite_orientations
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function crystallite_push33toref(ipc,ip,el, tensor33)
 
  real(preal), dimension(3,3) :: crystallite_push33toref
  real(preal), dimension(3,3), intent(in) :: tensor33
  real(preal), dimension(3,3)             :: t
  integer, intent(in):: &
    el, &
    ip, &
    ipc
 
  t = matmul(material_orientation0(ipc,ip,el)%asMatrix(), &                                         ! ToDo: initial orientation correct?
             transpose(math_inv33(crystallite_subf(1:3,1:3,ipc,ip,el))))
  crystallite_push33toref = matmul(transpose(t),matmul(tensor33,t))
 
end function crystallite_push33toref
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine crystallite_results
 
  integer :: p,o
  real(pReal),    allocatable, dimension(:,:,:) :: selected_tensors
  type(rotation), allocatable, dimension(:)     :: selected_rotations
  character(len=pStringLen)                     :: group,structureLabel
 
  do p=1,size(config_name_phase)
    group = trim('current/constituent')//'/'//trim(config_name_phase(p))//'/generic'
 
    call results_closegroup(results_addgroup(group))
 
    do o = 1, size(output_constituent(p)%label)
      select case (output_constituent(p)%label(o))
        case('f')
          selected_tensors = select_tensors(crystallite_partionedf,p)
          call results_writedataset(group,selected_tensors,'F',&
                                   'deformation gradient','1')
        case('fe')
          selected_tensors = select_tensors(crystallite_fe,p)
          call results_writedataset(group,selected_tensors,'Fe',&
                                   'elastic deformation gradient','1')
        case('fp')
          selected_tensors = select_tensors(crystallite_fp,p)
          call results_writedataset(group,selected_tensors,'Fp',&
                                   'plastic deformation gradient','1')
        case('fi')
          selected_tensors = select_tensors(crystallite_fi,p)
          call results_writedataset(group,selected_tensors,'Fi',&
                                   'inelastic deformation gradient','1')
        case('lp')
          selected_tensors = select_tensors(crystallite_lp,p)
          call results_writedataset(group,selected_tensors,'Lp',&
                                   'plastic velocity gradient','1/s')
        case('li')
          selected_tensors = select_tensors(crystallite_li,p)
          call results_writedataset(group,selected_tensors,'Li',&
                                   'inelastic velocity gradient','1/s')
        case('p')
          selected_tensors = select_tensors(crystallite_p,p)
          call results_writedataset(group,selected_tensors,'P',&
                                   'First Piola-Kirchoff stress','Pa')
        case('s')
          selected_tensors = select_tensors(crystallite_s,p)
          call results_writedataset(group,selected_tensors,'S',&
                                   'Second Piola-Kirchoff stress','Pa')
        case('orientation')
          select case(lattice_structure(p))
            case(lattice_iso_id)
              structurelabel = 'iso'
            case(lattice_fcc_id)
              structurelabel = 'fcc'
            case(lattice_bcc_id)
              structurelabel = 'bcc'
            case(lattice_bct_id)
              structurelabel = 'bct'
            case(lattice_hex_id)
              structurelabel = 'hex'
            case(lattice_ort_id)
              structurelabel = 'ort'
          end select
          selected_rotations = select_rotations(crystallite_orientation,p)
          call results_writedataset(group,selected_rotations,'orientation',&
                                   'crystal orientation as quaternion',structurelabel)
      end select
    enddo
  enddo
 
  contains
 
  !------------------------------------------------------------------------------------------------
  !------------------------------------------------------------------------------------------------
  function select_tensors(dataset,instance)
 
    integer, intent(in) :: instance
    real(preal), dimension(:,:,:,:,:), intent(in) :: dataset
    real(preal), allocatable, dimension(:,:,:) :: select_tensors
    integer :: e,i,c,j
 
    allocate(select_tensors(3,3,count(material_phaseat==instance)*discretization_nip))
 
    j=0
    do e = 1, size(material_phaseat,2)
      do i = 1, discretization_nip
        do c = 1, size(material_phaseat,1)                                                          !ToDo: this needs to be changed for varying Ngrains
          if (material_phaseat(c,e) == instance) then
            j = j + 1
            select_tensors(1:3,1:3,j) = dataset(1:3,1:3,c,i,e)
          endif
        enddo
      enddo
    enddo
 
  end function select_tensors
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
  function select_rotations(dataset,instance)
 
    integer, intent(in) :: instance
    type(rotation), dimension(:,:,:), intent(in) :: dataset
    type(rotation), allocatable, dimension(:) :: select_rotations
    integer :: e,i,c,j
 
    allocate(select_rotations(count(material_phaseat==instance)*homogenization_maxngrains*discretization_nip))
 
    j=0
    do e = 1, size(material_phaseat,2)
      do i = 1, discretization_nip
        do c = 1, size(material_phaseat,1)                                                          !ToDo: this needs to be changed for varying Ngrains
           if (material_phaseat(c,e) == instance) then
             j = j + 1
             select_rotations(j) = dataset(c,i,e)
           endif
        enddo
      enddo
   enddo
 
 end function select_rotations
 
end subroutine crystallite_results
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
logical function integratestress(ipc,ip,el,timeFraction)
 
  integer, intent(in)::         el, &                                                               ! element index
                                      ip, &                                                         ! integration point index
                                      ipc                                                           ! grain index
  real(preal), optional, intent(in) :: timefraction                                                 ! fraction of timestep
 
  real(preal), dimension(3,3)::       f, &                                                          ! deformation gradient at end of timestep
                                      fp_new, &                                                     ! plastic deformation gradient at end of timestep
                                      invfp_new, &                                                  ! inverse of Fp_new
                                      invfp_current, &                                              ! inverse of Fp_current
                                      lpguess, &                                                    ! current guess for plastic velocity gradient
                                      lpguess_old, &                                                ! known last good guess for plastic velocity gradient
                                      lp_constitutive, &                                            ! plastic velocity gradient resulting from constitutive law
                                      residuumlp, &                                                 ! current residuum of plastic velocity gradient
                                      residuumlp_old, &                                             ! last residuum of plastic velocity gradient
                                      deltalp, &                                                    ! direction of next guess
                                      fi_new, &                                                     ! gradient of intermediate deformation stages
                                      invfi_new, &
                                      invfi_current, &                                              ! inverse of Fi_current
                                      liguess, &                                                    ! current guess for intermediate velocity gradient
                                      liguess_old, &                                                ! known last good guess for intermediate velocity gradient
                                      li_constitutive, &                                            ! intermediate velocity gradient resulting from constitutive law
                                      residuumli, &                                                 ! current residuum of intermediate velocity gradient
                                      residuumli_old, &                                             ! last residuum of intermediate velocity gradient
                                      deltali, &                                                    ! direction of next guess
                                      fe, &                                                         ! elastic deformation gradient
                                      fe_new, &
                                      s, &                                                          ! 2nd Piola-Kirchhoff Stress in plastic (lattice) configuration
                                      a, &
                                      b, &
                                      temp_33
  real(preal), dimension(9) ::        temp_9                                                        ! needed for matrix inversion by LAPACK
  integer,     dimension(9) ::        devnull_9                                                     ! needed for matrix inversion by LAPACK
  real(preal), dimension(9,9) ::      drlp_dlp, &                                                   ! partial derivative of residuum (Jacobian for Newton-Raphson scheme)
                                      drli_dli                                                      ! partial derivative of residuumI (Jacobian for Newton-Raphson scheme)
  real(preal), dimension(3,3,3,3)::   ds_dfe, &                                                     ! partial derivative of 2nd Piola-Kirchhoff stress
                                      ds_dfi, &
                                      dfe_dlp, &                                                    ! partial derivative of elastic deformation gradient
                                      dfe_dli, &
                                      dfi_dli, &
                                      dlp_dfi, &
                                      dli_dfi, &
                                      dlp_ds, &
                                      dli_ds
  real(preal)                         steplengthlp, &
                                      steplengthli, &
                                      dt, &                                                         ! time increment
                                      atol_lp, &
                                      atol_li, &
                                      devnull
  integer                             niterationstresslp, &                                         ! number of stress integrations
                                      niterationstressli, &                                         ! number of inner stress integrations
                                      ierr, &                                                       ! error indicator for LAPACK
                                      o, &
                                      p, &
                                      jacocounterlp, &
                                      jacocounterli                                                 ! counters to check for Jacobian update
  logical :: error
  external :: &
    dgesv
 
  integratestress = .false.
 
  if (present(timefraction)) then
    dt = crystallite_subdt(ipc,ip,el) * timefraction
    f  = crystallite_subf0(1:3,1:3,ipc,ip,el) &
       + (crystallite_subf(1:3,1:3,ipc,ip,el) - crystallite_subf0(1:3,1:3,ipc,ip,el)) * timefraction
  else
    dt = crystallite_subdt(ipc,ip,el)
    f  = crystallite_subf(1:3,1:3,ipc,ip,el)
  endif
 
  lpguess = crystallite_lp(1:3,1:3,ipc,ip,el)                                                       ! take as first guess
  liguess = crystallite_li(1:3,1:3,ipc,ip,el)                                                       ! take as first guess
 
  call math_invert33(invfp_current,devnull,error,crystallite_subfp0(1:3,1:3,ipc,ip,el))
  if (error) return ! error
  call math_invert33(invfi_current,devnull,error,crystallite_subfi0(1:3,1:3,ipc,ip,el))
  if (error) return ! error
 
  a = matmul(f,invfp_current)                                                                       ! intermediate tensor needed later to calculate dFe_dLp
 
  jacocounterli  = 0
  steplengthli   = 1.0_preal
  residuumli_old = 0.0_preal
  liguess_old    = liguess
 
  niterationstressli = 0
  liloop: do
    niterationstressli = niterationstressli + 1
    if (niterationstressli>num%nStress) return ! error
 
    invfi_new = matmul(invfi_current,math_i3 - dt*liguess)
    fi_new    = math_inv33(invfi_new)
 
    jacocounterlp  = 0
    steplengthlp   = 1.0_preal
    residuumlp_old = 0.0_preal
    lpguess_old    = lpguess
 
    niterationstresslp = 0
    lploop: do
      niterationstresslp = niterationstresslp + 1
      if (niterationstresslp>num%nStress) return ! error
 
      b  = math_i3 - dt*lpguess
      fe = matmul(matmul(a,b), invfi_new)
      call constitutive_sanditstangents(s, ds_dfe, ds_dfi, &
                                        fe, fi_new, ipc, ip, el)
 
      call constitutive_lpanditstangents(lp_constitutive, dlp_ds, dlp_dfi, &
                                         s, fi_new, ipc, ip, el)
 
      !* update current residuum and check for convergence of loop
      atol_lp = max(num%rtol_crystalliteStress * max(norm2(lpguess),norm2(lp_constitutive)), &      ! absolute tolerance from largest acceptable relative error
                    num%atol_crystalliteStress)                                                     ! minimum lower cutoff
      residuumlp = lpguess - lp_constitutive
 
      if (any(ieee_is_nan(residuumlp))) then
        return ! error
      elseif (norm2(residuumlp) < atol_lp) then                                                     ! converged if below absolute tolerance
        exit lploop
      elseif (niterationstresslp == 1 .or. norm2(residuumlp) < norm2(residuumlp_old)) then          ! not converged, but improved norm of residuum (always proceed in first iteration)...
        residuumlp_old = residuumlp                                                                 ! ...remember old values and...
        lpguess_old    = lpguess
        steplengthlp   = 1.0_preal                                                                  ! ...proceed with normal step length (calculate new search direction)
      else                                                                                          ! not converged and residuum not improved...
        steplengthlp = num%subStepSizeLp * steplengthlp                                             ! ...try with smaller step length in same direction
        lpguess      = lpguess_old &
                     + deltalp * steplengthlp
        cycle lploop
      endif
 
     !* calculate Jacobian for correction term
      if (mod(jacocounterlp, num%iJacoLpresiduum) == 0) then
        jacocounterlp = jacocounterlp + 1
 
        do o=1,3; do p=1,3
          dfe_dlp(o,1:3,p,1:3) = a(o,p)*transpose(invfi_new)                                        ! dFe_dLp(i,j,k,l) = -dt * A(i,k) invFi(l,j)
        enddo; enddo
        dfe_dlp  = - dt * dfe_dlp
        drlp_dlp = math_identity2nd(9) &
                 - math_3333to99(math_mul3333xx3333(math_mul3333xx3333(dlp_ds,ds_dfe),dfe_dlp))
        temp_9 = math_33to9(residuumlp)
        call dgesv(9,1,drlp_dlp,9,devnull_9,temp_9,9,ierr)                                          ! solve dRLp/dLp * delta Lp = -res for delta Lp
        if (ierr /= 0) return ! error
        deltalp = - math_9to33(temp_9)
      endif
 
      lpguess = lpguess &
              + deltalp * steplengthlp
    enddo lploop
 
    call constitutive_lianditstangents(li_constitutive, dli_ds, dli_dfi, &
                                       s, fi_new, ipc, ip, el)
 
    !* update current residuum and check for convergence of loop
    atol_li = max(num%rtol_crystalliteStress * max(norm2(liguess),norm2(li_constitutive)), &        ! absolute tolerance from largest acceptable relative error
                  num%atol_crystalliteStress)                                                       ! minimum lower cutoff
    residuumli = liguess - li_constitutive
    if (any(ieee_is_nan(residuumli))) then
      return ! error
    elseif (norm2(residuumli) < atol_li) then                                                       ! converged if below absolute tolerance
      exit liloop
    elseif (niterationstressli == 1 .or. norm2(residuumli) < norm2(residuumli_old)) then            ! not converged, but improved norm of residuum (always proceed in first iteration)...
      residuumli_old = residuumli                                                                   ! ...remember old values and...
      liguess_old    = liguess
      steplengthli   = 1.0_preal                                                                    ! ...proceed with normal step length (calculate new search direction)
    else                                                                                            ! not converged and residuum not improved...
      steplengthli = num%subStepSizeLi * steplengthli                                               ! ...try with smaller step length in same direction
      liguess      = liguess_old &
                   + deltali * steplengthli
      cycle liloop
    endif
 
    !* calculate Jacobian for correction term
    if (mod(jacocounterli, num%iJacoLpresiduum) == 0) then
      jacocounterli = jacocounterli + 1
 
      temp_33 = matmul(matmul(a,b),invfi_current)
      do o=1,3; do p=1,3
        dfe_dli(1:3,o,1:3,p) = -dt*math_i3(o,p)*temp_33                                             ! dFe_dLp(i,j,k,l) = -dt * A(i,k) invFi(l,j)
        dfi_dli(1:3,o,1:3,p) = -dt*math_i3(o,p)*invfi_current
      enddo; enddo
      do o=1,3; do p=1,3
        dfi_dli(1:3,1:3,o,p) = matmul(matmul(fi_new,dfi_dli(1:3,1:3,o,p)),fi_new)
      enddo; enddo
      drli_dli  = math_identity2nd(9) &
                - math_3333to99(math_mul3333xx3333(dli_ds,  math_mul3333xx3333(ds_dfe, dfe_dli) &
                                                          + math_mul3333xx3333(ds_dfi, dfi_dli)))  &
                - math_3333to99(math_mul3333xx3333(dli_dfi, dfi_dli))
      temp_9 = math_33to9(residuumli)
      call dgesv(9,1,drli_dli,9,devnull_9,temp_9,9,ierr)                                            ! solve dRLi/dLp * delta Li = -res for delta Li
      if (ierr /= 0) return ! error
      deltali = - math_9to33(temp_9)
    endif
 
    liguess = liguess &
            + deltali * steplengthli
  enddo liloop
 
  invfp_new = matmul(invfp_current,b)
  call math_invert33(fp_new,devnull,error,invfp_new)
  if (error) return ! error
  fp_new = fp_new / math_det33(fp_new)**(1.0_preal/3.0_preal)                                       ! regularize
  fe_new = matmul(matmul(f,invfp_new),invfi_new)
 
  integratestress = .true.
  crystallite_p(1:3,1:3,ipc,ip,el) = matmul(matmul(f,invfp_new),matmul(s,transpose(invfp_new)))
  crystallite_s(1:3,1:3,ipc,ip,el) = s
  crystallite_lp(1:3,1:3,ipc,ip,el) = lpguess
  crystallite_li(1:3,1:3,ipc,ip,el) = liguess
  crystallite_fp(1:3,1:3,ipc,ip,el) = fp_new
  crystallite_fi(1:3,1:3,ipc,ip,el) = fi_new
  crystallite_fe(1:3,1:3,ipc,ip,el) = fe_new
 
end function integratestress
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine integratestatefpi
 
  integer :: &
    NiterationState, &                                                                              !< number of iterations in state loop
    e, &                                                                                            !< element index in element loop
    i, &                                                                                            !< integration point index in ip loop
    g, &                                                                                            !< grain index in grain loop
    p, &
    c, &
    s, &
    sizeDotState
  real(pReal) :: &
    zeta
  real(pReal), dimension(constitutive_plasticity_maxSizeDotState) :: &
    residuum_plastic                                                                                ! residuum for plastic state
  real(pReal), dimension(constitutive_source_maxSizeDotState) :: &
    residuum_source                                                                                 ! residuum for source state
  logical :: &
    nonlocalBroken
 
  nonlocalbroken = .false.
  !$OMP PARALLEL DO PRIVATE(sizeDotState,residuum_plastic,residuum_source,zeta,p,c)
  do e = fesolving_execelem(1),fesolving_execelem(2)
    do i = fesolving_execip(1),fesolving_execip(2)
      do g = 1,homogenization_ngrains(material_homogenizationat(e))
        if(crystallite_todo(g,i,e) .and. (.not. nonlocalbroken .or. crystallite_localplasticity(g,i,e)) ) then
 
          p = material_phaseat(g,e); c = material_phasememberat(g,i,e)
 
          call constitutive_collectdotstate(crystallite_s(1:3,1:3,g,i,e), &
                                            crystallite_partionedf0, &
                                            crystallite_fi(1:3,1:3,g,i,e), &
                                            crystallite_partionedfp0, &
                                            crystallite_subdt(g,i,e), g,i,e)
          crystallite_todo(g,i,e) = all(.not. ieee_is_nan(plasticstate(p)%dotState(:,c)))
          do s = 1, phase_nsources(p)
            crystallite_todo(g,i,e) = crystallite_todo(g,i,e) .and. all(.not. ieee_is_nan(sourcestate(p)%p(s)%dotState(:,c)))
          enddo
          if(.not. (crystallite_todo(g,i,e) .or. crystallite_localplasticity(g,i,e))) &
            nonlocalbroken = .true.
          if(.not. crystallite_todo(g,i,e)) cycle
 
          sizedotstate = plasticstate(p)%sizeDotState
          plasticstate(p)%state(1:sizedotstate,c) = plasticstate(p)%subState0(1:sizedotstate,c) &
                                                  + plasticstate(p)%dotState (1:sizedotstate,c) &
                                                    * crystallite_subdt(g,i,e)
          do s = 1, phase_nsources(p)
            sizedotstate = sourcestate(p)%p(s)%sizeDotState
            sourcestate(p)%p(s)%state(1:sizedotstate,c) = sourcestate(p)%p(s)%subState0(1:sizedotstate,c) &
                                                        + sourcestate(p)%p(s)%dotState (1:sizedotstate,c) &
                                                          * crystallite_subdt(g,i,e)
          enddo
 
          iteration: do niterationstate = 1, num%nState
 
            plasticstate(p)%previousDotState2(:,c) = merge(plasticstate(p)%previousDotState(:,c),&
                                                           0.0_preal,&
                                                           niterationstate > 1)
            plasticstate(p)%previousDotState (:,c) = plasticstate(p)%dotState(:,c)
            do s = 1, phase_nsources(p)
              sourcestate(p)%p(s)%previousDotState2(:,c) = merge(sourcestate(p)%p(s)%previousDotState(:,c),&
                                                                 0.0_preal, &
                                                                 niterationstate > 1)
              sourcestate(p)%p(s)%previousDotState (:,c) = sourcestate(p)%p(s)%dotState(:,c)
            enddo
 
            call constitutive_dependentstate(crystallite_partionedf(1:3,1:3,g,i,e), &
                                             crystallite_fp(1:3,1:3,g,i,e), &
                                             g, i, e)
 
            crystallite_todo(g,i,e) = integratestress(g,i,e)
            if(.not. (crystallite_todo(g,i,e) .or. crystallite_localplasticity(g,i,e))) &
              nonlocalbroken = .true.
            if(.not. crystallite_todo(g,i,e)) exit iteration
 
            call constitutive_collectdotstate(crystallite_s(1:3,1:3,g,i,e), &
                                              crystallite_partionedf0, &
                                              crystallite_fi(1:3,1:3,g,i,e), &
                                              crystallite_partionedfp0, &
                                              crystallite_subdt(g,i,e), g,i,e)
            crystallite_todo(g,i,e) = all(.not. ieee_is_nan(plasticstate(p)%dotState(:,c)))
            do s = 1, phase_nsources(p)
              crystallite_todo(g,i,e) = crystallite_todo(g,i,e) .and. all(.not. ieee_is_nan(sourcestate(p)%p(s)%dotState(:,c)))
            enddo
            if(.not. (crystallite_todo(g,i,e) .or. crystallite_localplasticity(g,i,e))) &
              nonlocalbroken = .true.
            if(.not. crystallite_todo(g,i,e)) exit iteration
 
            sizedotstate = plasticstate(p)%sizeDotState
            zeta = damper(plasticstate(p)%dotState         (:,c), &
                          plasticstate(p)%previousDotState (:,c), &
                          plasticstate(p)%previousDotState2(:,c))
            plasticstate(p)%dotState(:,c) = plasticstate(p)%dotState(:,c) * zeta &
                                          + plasticstate(p)%previousDotState(:,c) * (1.0_preal - zeta)
            residuum_plastic(1:sizedotstate) = plasticstate(p)%state    (1:sizedotstate,c) &
                                             - plasticstate(p)%subState0(1:sizedotstate,c)  &
                                             - plasticstate(p)%dotState (1:sizedotstate,c)  &
                                               * crystallite_subdt(g,i,e)
            plasticstate(p)%state(1:sizedotstate,c) = plasticstate(p)%state(1:sizedotstate,c) &
                                                    - residuum_plastic(1:sizedotstate)
            crystallite_converged(g,i,e) = converged(residuum_plastic(1:sizedotstate), &
                                                     plasticstate(p)%state(1:sizedotstate,c), &
                                                     plasticstate(p)%atol(1:sizedotstate))
            do s = 1, phase_nsources(p)
              sizedotstate  = sourcestate(p)%p(s)%sizeDotState
              zeta = damper(sourcestate(p)%p(s)%dotState         (:,c), &
                            sourcestate(p)%p(s)%previousDotState (:,c), &
                            sourcestate(p)%p(s)%previousDotState2(:,c))
              sourcestate(p)%p(s)%dotState(:,c) = sourcestate(p)%p(s)%dotState(:,c) * zeta &
                                                + sourcestate(p)%p(s)%previousDotState(:,c)* (1.0_preal - zeta)
              residuum_source(1:sizedotstate) = sourcestate(p)%p(s)%state    (1:sizedotstate,c)  &
                                              - sourcestate(p)%p(s)%subState0(1:sizedotstate,c)  &
                                              - sourcestate(p)%p(s)%dotState (1:sizedotstate,c)  &
                                                * crystallite_subdt(g,i,e)
              sourcestate(p)%p(s)%state(1:sizedotstate,c) = sourcestate(p)%p(s)%state(1:sizedotstate,c) &
                                                          - residuum_source(1:sizedotstate)
              crystallite_converged(g,i,e) = &
              crystallite_converged(g,i,e) .and. converged(residuum_source(1:sizedotstate), &
                                                           sourcestate(p)%p(s)%state(1:sizedotstate,c), &
                                                           sourcestate(p)%p(s)%atol(1:sizedotstate))
            enddo
 
            if(crystallite_converged(g,i,e)) then
              crystallite_todo(g,i,e) = statejump(g,i,e)
              if(.not. (crystallite_todo(g,i,e) .or. crystallite_localplasticity(g,i,e))) &
                nonlocalbroken = .true.
              exit iteration
            endif
 
          enddo iteration
 
        endif
  enddo; enddo; enddo
  !$OMP END PARALLEL DO
 
  if(nonlocalbroken) where(.not. crystallite_localplasticity) crystallite_todo = .false.
  if (any(plasticstate(:)%nonlocal)) call nonlocalconvergencecheck
 
  contains
 
  !--------------------------------------------------------------------------------------------------
  !--------------------------------------------------------------------------------------------------
  real(pReal) pure function damper(current,previous,previous2)
 
  real(preal), dimension(:), intent(in) ::&
    current, previous, previous2
 
  real(preal) :: dot_prod12, dot_prod22
 
  dot_prod12 = dot_product(current  - previous,  previous - previous2)
  dot_prod22 = dot_product(previous - previous2, previous - previous2)
  if ((dot_product(current,previous) < 0.0_preal .or. dot_prod12 < 0.0_preal) .and. dot_prod22 > 0.0_preal) then
    damper = 0.75_preal + 0.25_preal * tanh(2.0_preal + 4.0_preal * dot_prod12 / dot_prod22)
  else
    damper = 1.0_preal
  endif
 
  end function damper
 
end subroutine integratestatefpi
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine integratestateeuler
 
  integer :: &
    e, &                                                                                            !< element index in element loop
    i, &                                                                                            !< integration point index in ip loop
    g, &                                                                                            !< grain index in grain loop
    p, &
    c, &
    s, &
    sizeDotState
  logical :: &
    nonlocalBroken
 
  nonlocalbroken = .false.
  !$OMP PARALLEL DO PRIVATE (sizeDotState,p,c)
  do e = fesolving_execelem(1),fesolving_execelem(2)
    do i = fesolving_execip(1),fesolving_execip(2)
      do g = 1,homogenization_ngrains(material_homogenizationat(e))
        if(crystallite_todo(g,i,e) .and. (.not. nonlocalbroken .or. crystallite_localplasticity(g,i,e)) ) then
 
          p = material_phaseat(g,e); c = material_phasememberat(g,i,e)
 
          call constitutive_collectdotstate(crystallite_s(1:3,1:3,g,i,e), &
                                            crystallite_partionedf0, &
                                            crystallite_fi(1:3,1:3,g,i,e), &
                                            crystallite_partionedfp0, &
                                            crystallite_subdt(g,i,e), g,i,e)
          crystallite_todo(g,i,e) = all(.not. ieee_is_nan(plasticstate(p)%dotState(:,c)))
          do s = 1, phase_nsources(p)
            crystallite_todo(g,i,e) = crystallite_todo(g,i,e) .and. all(.not. ieee_is_nan(sourcestate(p)%p(s)%dotState(:,c)))
          enddo
          if(.not. (crystallite_todo(g,i,e) .or. crystallite_localplasticity(g,i,e))) &
            nonlocalbroken = .true.
          if(.not. crystallite_todo(g,i,e)) cycle
 
          sizedotstate = plasticstate(p)%sizeDotState
          plasticstate(p)%state(1:sizedotstate,c) = plasticstate(p)%subState0(1:sizedotstate,c) &
                                                  + plasticstate(p)%dotState (1:sizedotstate,c) &
                                                    * crystallite_subdt(g,i,e)
          do s = 1, phase_nsources(p)
            sizedotstate = sourcestate(p)%p(s)%sizeDotState
            sourcestate(p)%p(s)%state(1:sizedotstate,c) = sourcestate(p)%p(s)%subState0(1:sizedotstate,c) &
                                                        + sourcestate(p)%p(s)%dotState (1:sizedotstate,c) &
                                                          * crystallite_subdt(g,i,e)
          enddo
 
          crystallite_todo(g,i,e) = statejump(g,i,e)
          if(.not. (crystallite_todo(g,i,e) .or. crystallite_localplasticity(g,i,e))) &
            nonlocalbroken = .true.
          if(.not. crystallite_todo(g,i,e)) cycle
 
          call constitutive_dependentstate(crystallite_partionedf(1:3,1:3,g,i,e), &
                                           crystallite_fp(1:3,1:3,g,i,e), &
                                           g, i, e)
 
          crystallite_todo(g,i,e) = integratestress(g,i,e)
          if(.not. (crystallite_todo(g,i,e) .or. crystallite_localplasticity(g,i,e))) &
            nonlocalbroken = .true.
 
          crystallite_converged(g,i,e) = crystallite_todo(g,i,e)
 
        endif
  enddo; enddo; enddo
  !$OMP END PARALLEL DO
 
  if(nonlocalbroken) where(.not. crystallite_localplasticity) crystallite_todo = .false.
  if (any(plasticstate(:)%nonlocal)) call nonlocalconvergencecheck
 
end subroutine integratestateeuler
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine integratestateadaptiveeuler
 
  integer :: &
    e, &                                                                                             ! element index in element loop
    i, &                                                                                             ! integration point index in ip loop
    g, &                                                                                             ! grain index in grain loop
    p, &
    c, &
    s, &
    sizeDotState
  logical :: &
    nonlocalBroken
 
  real(pReal), dimension(constitutive_plasticity_maxSizeDotState,            &
                         homogenization_maxNgrains,discretization_nIP,discretization_nElem) :: &
    residuum_plastic
  real(pReal), dimension(constitutive_source_maxSizeDotState,&
                         maxval(phase_Nsources), &
                         homogenization_maxNgrains,discretization_nIP,discretization_nElem) :: &
    residuum_source
 
 
  nonlocalbroken = .false.
  !$OMP PARALLEL DO PRIVATE(sizeDotState,p,c)
  do e = fesolving_execelem(1),fesolving_execelem(2)
    do i = fesolving_execip(1),fesolving_execip(2)
      do g = 1,homogenization_ngrains(material_homogenizationat(e))
        if(crystallite_todo(g,i,e) .and. (.not. nonlocalbroken .or. crystallite_localplasticity(g,i,e)) ) then
 
          p = material_phaseat(g,e); c = material_phasememberat(g,i,e)
 
          call constitutive_collectdotstate(crystallite_s(1:3,1:3,g,i,e), &
                                            crystallite_partionedf0, &
                                            crystallite_fi(1:3,1:3,g,i,e), &
                                            crystallite_partionedfp0, &
                                            crystallite_subdt(g,i,e), g,i,e)
          crystallite_todo(g,i,e) = all(.not. ieee_is_nan(plasticstate(p)%dotState(:,c)))
          do s = 1, phase_nsources(p)
            crystallite_todo(g,i,e) = crystallite_todo(g,i,e) .and. all(.not. ieee_is_nan(sourcestate(p)%p(s)%dotState(:,c)))
          enddo
          if(.not. (crystallite_todo(g,i,e) .or. crystallite_localplasticity(g,i,e))) &
            nonlocalbroken = .true.
          if(.not. crystallite_todo(g,i,e)) cycle
 
          sizedotstate = plasticstate(p)%sizeDotState
 
          residuum_plastic(1:sizedotstate,g,i,e) = plasticstate(p)%dotstate(1:sizedotstate,c) &
                                                 * (- 0.5_preal * crystallite_subdt(g,i,e))
          plasticstate(p)%state(1:sizedotstate,c) = plasticstate(p)%subState0(1:sizedotstate,c) &
                                                  + plasticstate(p)%dotstate(1:sizedotstate,c) * crystallite_subdt(g,i,e)
          do s = 1, phase_nsources(p)
            sizedotstate = sourcestate(p)%p(s)%sizeDotState
 
            residuum_source(1:sizedotstate,s,g,i,e) = sourcestate(p)%p(s)%dotstate(1:sizedotstate,c) &
                                                    * (- 0.5_preal * crystallite_subdt(g,i,e))
            sourcestate(p)%p(s)%state(1:sizedotstate,c) = sourcestate(p)%p(s)%subState0(1:sizedotstate,c) &
                                                        + sourcestate(p)%p(s)%dotstate(1:sizedotstate,c) * crystallite_subdt(g,i,e)
          enddo
 
          crystallite_todo(g,i,e) = statejump(g,i,e)
          if(.not. (crystallite_todo(g,i,e) .or. crystallite_localplasticity(g,i,e))) &
            nonlocalbroken = .true.
          if(.not. crystallite_todo(g,i,e)) cycle
 
          call constitutive_dependentstate(crystallite_partionedf(1:3,1:3,g,i,e), &
                                           crystallite_fp(1:3,1:3,g,i,e), &
                                           g, i, e)
 
          crystallite_todo(g,i,e) = integratestress(g,i,e)
          if(.not. (crystallite_todo(g,i,e) .or. crystallite_localplasticity(g,i,e))) &
            nonlocalbroken = .true.
          if(.not. crystallite_todo(g,i,e)) cycle
 
          call constitutive_collectdotstate(crystallite_s(1:3,1:3,g,i,e), &
                                            crystallite_partionedf0, &
                                            crystallite_fi(1:3,1:3,g,i,e), &
                                            crystallite_partionedfp0, &
                                            crystallite_subdt(g,i,e), g,i,e)
          crystallite_todo(g,i,e) = all(.not. ieee_is_nan(plasticstate(p)%dotState(:,c)))
          do s = 1, phase_nsources(p)
            crystallite_todo(g,i,e) = crystallite_todo(g,i,e) .and. all(.not. ieee_is_nan(sourcestate(p)%p(s)%dotState(:,c)))
          enddo
          if(.not. (crystallite_todo(g,i,e) .or. crystallite_localplasticity(g,i,e))) &
            nonlocalbroken = .true.
          if(.not. crystallite_todo(g,i,e)) cycle
 
 
          sizedotstate = plasticstate(p)%sizeDotState
 
          residuum_plastic(1:sizedotstate,g,i,e) = residuum_plastic(1:sizedotstate,g,i,e) &
                                                 + 0.5_preal * plasticstate(p)%dotState(:,c) * crystallite_subdt(g,i,e)
 
          crystallite_converged(g,i,e) = converged(residuum_plastic(1:sizedotstate,g,i,e), &
                                                   plasticstate(p)%state(1:sizedotstate,c), &
                                                   plasticstate(p)%atol(1:sizedotstate))
 
          do s = 1, phase_nsources(p)
            sizedotstate = sourcestate(p)%p(s)%sizeDotState
 
            residuum_source(1:sizedotstate,s,g,i,e) = &
            residuum_source(1:sizedotstate,s,g,i,e) + 0.5_preal * sourcestate(p)%p(s)%dotState(:,c) * crystallite_subdt(g,i,e)
 
            crystallite_converged(g,i,e) = &
            crystallite_converged(g,i,e) .and. converged(residuum_source(1:sizedotstate,s,g,i,e), &
                                                         sourcestate(p)%p(s)%state(1:sizedotstate,c), &
                                                         sourcestate(p)%p(s)%atol(1:sizedotstate))
           enddo
 
        endif
  enddo; enddo; enddo
  !$OMP END PARALLEL DO
 
  if (any(plasticstate(:)%nonlocal)) call nonlocalconvergencecheck
 
end subroutine integratestateadaptiveeuler
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine integratestaterk4
 
 real(pReal), dimension(3,3), parameter :: &
  A = reshape([&
      0.5_preal, 0.0_preal, 0.0_preal, &
      0.0_preal, 0.5_preal, 0.0_preal, &
      0.0_preal, 0.0_preal, 1.0_preal], &
      [3,3])
 real(pReal), dimension(3), parameter :: &
   CC = [0.5_preal, 0.5_preal, 1.0_preal]                                   ! factor giving the fraction of the original timestep used for Runge Kutta Integration
 real(pReal), dimension(4), parameter :: &
   B = [1.0_preal/6.0_preal, 1.0_preal/3.0_preal, 1.0_preal/3.0_preal, 1.0_preal/6.0_preal]                                   ! weight of slope used for Runge Kutta integration (final weight divided by 6)
 
  integer :: &
    e, &                                                                                            ! element index in element loop
    i, &                                                                                            ! integration point index in ip loop
    g, &                                                                                            ! grain index in grain loop
    stage, &                                                                                        ! stage index in integration stage loop
    n, &
    p, &
    c, &
    s, &
    sizeDotState
  logical :: &
    nonlocalBroken
 
  nonlocalbroken = .false.
  !$OMP PARALLEL DO PRIVATE(sizeDotState,p,c)
  do e = fesolving_execelem(1),fesolving_execelem(2)
    do i = fesolving_execip(1),fesolving_execip(2)
      do g = 1,homogenization_ngrains(material_homogenizationat(e))
        if(crystallite_todo(g,i,e) .and. (.not. nonlocalbroken .or. crystallite_localplasticity(g,i,e)) ) then
 
          p = material_phaseat(g,e); c = material_phasememberat(g,i,e)
 
          call constitutive_collectdotstate(crystallite_s(1:3,1:3,g,i,e), &
                                            crystallite_partionedf0, &
                                            crystallite_fi(1:3,1:3,g,i,e), &
                                            crystallite_partionedfp0, &
                                            crystallite_subdt(g,i,e), g,i,e)
          crystallite_todo(g,i,e) = all(.not. ieee_is_nan(plasticstate(p)%dotState(:,c)))
          do s = 1, phase_nsources(p)
            crystallite_todo(g,i,e) = crystallite_todo(g,i,e) .and. all(.not. ieee_is_nan(sourcestate(p)%p(s)%dotState(:,c)))
          enddo
          if(.not. (crystallite_todo(g,i,e) .or. crystallite_localplasticity(g,i,e))) &
            nonlocalbroken = .true.
          if(.not. crystallite_todo(g,i,e)) cycle
 
          do stage = 1,3
 
            plasticstate(p)%RK4dotState(stage,:,c) = plasticstate(p)%dotState(:,c)
            plasticstate(p)%dotState(:,c) = a(1,stage) * plasticstate(p)%RK4dotState(1,:,c)
            do s = 1, phase_nsources(p)
              sourcestate(p)%p(s)%RK4dotState(stage,:,c) = sourcestate(p)%p(s)%dotState(:,c)
              sourcestate(p)%p(s)%dotState(:,c) = a(1,stage) * sourcestate(p)%p(s)%RK4dotState(1,:,c)
            enddo
 
            do n = 2, stage
              plasticstate(p)%dotState(:,c) = plasticstate(p)%dotState(:,c) &
                                            + a(n,stage) * plasticstate(p)%RK4dotState(n,:,c)
              do s = 1, phase_nsources(p)
                sourcestate(p)%p(s)%dotState(:,c) = sourcestate(p)%p(s)%dotState(:,c) &
                                                  + a(n,stage) * sourcestate(p)%p(s)%RK4dotState(n,:,c)
              enddo
            enddo
 
            sizedotstate = plasticstate(p)%sizeDotState
            plasticstate(p)%state(1:sizedotstate,c) = plasticstate(p)%subState0(1:sizedotstate,c) &
                                                    + plasticstate(p)%dotState (1:sizedotstate,c) &
                                                      * crystallite_subdt(g,i,e)
            do s = 1, phase_nsources(p)
              sizedotstate = sourcestate(p)%p(s)%sizeDotState
              sourcestate(p)%p(s)%state(1:sizedotstate,c) = sourcestate(p)%p(s)%subState0(1:sizedotstate,c) &
                                                          + sourcestate(p)%p(s)%dotState (1:sizedotstate,c) &
                                                            * crystallite_subdt(g,i,e)
            enddo
 
            call constitutive_dependentstate(crystallite_partionedf(1:3,1:3,g,i,e), &
                                             crystallite_fp(1:3,1:3,g,i,e), &
                                             g, i, e)
 
            crystallite_todo(g,i,e) = integratestress(g,i,e,cc(stage))
            if(.not. (crystallite_todo(g,i,e) .or. crystallite_localplasticity(g,i,e))) &
              nonlocalbroken = .true.
            if(.not. crystallite_todo(g,i,e)) exit
 
            call constitutive_collectdotstate(crystallite_s(1:3,1:3,g,i,e), &
                                              crystallite_partionedf0, &
                                              crystallite_fi(1:3,1:3,g,i,e), &
                                              crystallite_partionedfp0, &
                                              crystallite_subdt(g,i,e)*cc(stage), g,i,e)
            crystallite_todo(g,i,e) = all(.not. ieee_is_nan(plasticstate(p)%dotState(:,c)))
            do s = 1, phase_nsources(p)
              crystallite_todo(g,i,e) = crystallite_todo(g,i,e) .and. all(.not. ieee_is_nan(sourcestate(p)%p(s)%dotState(:,c)))
            enddo
            if(.not. (crystallite_todo(g,i,e) .or. crystallite_localplasticity(g,i,e))) &
              nonlocalbroken = .true.
            if(.not. crystallite_todo(g,i,e)) exit
 
          enddo
 
          if(.not. crystallite_todo(g,i,e)) cycle
 
          sizedotstate = plasticstate(p)%sizeDotState
 
          plasticstate(p)%RK4dotState(4,:,c) = plasticstate(p)%dotState(:,c)
 
          plasticstate(p)%dotState(:,c) =  matmul(b,plasticstate(p)%RK4dotState(1:4,1:sizedotstate,c))
          plasticstate(p)%state(1:sizedotstate,c) = plasticstate(p)%subState0(1:sizedotstate,c) &
                                                  + plasticstate(p)%dotState (1:sizedotstate,c) &
                                                    * crystallite_subdt(g,i,e)
 
          do s = 1, phase_nsources(p)
            sizedotstate = sourcestate(p)%p(s)%sizeDotState
 
            sourcestate(p)%p(s)%RK4dotState(4,:,c) = sourcestate(p)%p(s)%dotState(:,c)
 
            sourcestate(p)%p(s)%dotState(:,c)  = matmul(b,sourcestate(p)%p(s)%RK4dotState(1:4,1:sizedotstate,c))
            sourcestate(p)%p(s)%state(1:sizedotstate,c) = sourcestate(p)%p(s)%subState0(1:sizedotstate,c) &
                                                        + sourcestate(p)%p(s)%dotState (1:sizedotstate,c) &
                                                          * crystallite_subdt(g,i,e)
          enddo
 
          crystallite_todo(g,i,e) = statejump(g,i,e)
          if(.not. (crystallite_todo(g,i,e) .or. crystallite_localplasticity(g,i,e))) &
            nonlocalbroken = .true.
          if(.not. crystallite_todo(g,i,e)) cycle
 
          call constitutive_dependentstate(crystallite_partionedf(1:3,1:3,g,i,e), &
                                           crystallite_fp(1:3,1:3,g,i,e), &
                                           g, i, e)
 
          if(.not. (crystallite_todo(g,i,e) .or. crystallite_localplasticity(g,i,e))) &
            nonlocalbroken = .true.
          if(.not. crystallite_todo(g,i,e)) cycle
 
          crystallite_todo(g,i,e) = integratestress(g,i,e)
          if(.not. (crystallite_todo(g,i,e) .or. crystallite_localplasticity(g,i,e))) &
            nonlocalbroken = .true.
          crystallite_converged(g,i,e) = crystallite_todo(g,i,e)                                    ! consider converged if not broken
 
        endif
  enddo; enddo; enddo
  !$OMP END PARALLEL DO
 
  if(nonlocalbroken) where(.not. crystallite_localplasticity) crystallite_todo = .false.
  if (any(plasticstate(:)%nonlocal)) call nonlocalconvergencecheck
 
end subroutine integratestaterk4
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine integratestaterkck45
 
  real(pReal), dimension(5,5), parameter :: &
    A = reshape([&
      .2_preal, .075_preal,   .3_preal, -11.0_preal/54.0_preal,  1631.0_preal/55296.0_preal, &
      .0_preal, .225_preal,  -.9_preal,   2.5_preal,              175.0_preal/512.0_preal, &
      .0_preal,   .0_preal,  1.2_preal, -70.0_preal/27.0_preal,   575.0_preal/13824.0_preal, &
      .0_preal,   .0_preal,   .0_preal,  35.0_preal/27.0_preal, 44275.0_preal/110592.0_preal, &
      .0_preal,   .0_preal,   .0_preal,    .0_preal,              253.0_preal/4096.0_preal], &
      [5,5], order=[2,1])                                                                           
 
  real(pReal), dimension(6), parameter :: &
    B = &
      [37.0_preal/378.0_preal, .0_preal, 250.0_preal/621.0_preal, &
      125.0_preal/594.0_preal, .0_preal, 512.0_preal/1771.0_preal], &                               
    db = b - &
      [2825.0_preal/27648.0_preal,    .0_preal,                18575.0_preal/48384.0_preal,&
      13525.0_preal/55296.0_preal, 277.0_preal/14336.0_preal,      0.25_preal]                      
 
  real(pReal), dimension(5), parameter :: &
    CC = [0.2_preal, 0.3_preal, 0.6_preal, 1.0_preal, 0.875_preal]                                  
 
  integer :: &
    e, &                                                                                            ! element index in element loop
    i, &                                                                                            ! integration point index in ip loop
    g, &                                                                                            ! grain index in grain loop
    stage, &                                                                                        ! stage index in integration stage loop
    n, &
    p, &
    c, &
    s, &
    sizeDotState
  logical :: &
    nonlocalBroken
 
  real(pReal), dimension(constitutive_plasticity_maxSizeDotState,            &
                         homogenization_maxNgrains,discretization_nIP,discretization_nElem) :: &
    residuum_plastic
  real(pReal), dimension(constitutive_source_maxSizeDotState, &
                         maxval(phase_Nsources), &
                         homogenization_maxNgrains,discretization_nIP,discretization_nElem) :: &
    residuum_source
 
 
  nonlocalbroken = .false.
  !$OMP PARALLEL DO PRIVATE(sizeDotState,p,c)
  do e = fesolving_execelem(1),fesolving_execelem(2)
    do i = fesolving_execip(1),fesolving_execip(2)
      do g = 1,homogenization_ngrains(material_homogenizationat(e))
        if(crystallite_todo(g,i,e) .and. (.not. nonlocalbroken .or. crystallite_localplasticity(g,i,e)) ) then
 
          p = material_phaseat(g,e); c = material_phasememberat(g,i,e)
 
          call constitutive_collectdotstate(crystallite_s(1:3,1:3,g,i,e), &
                                            crystallite_partionedf0, &
                                            crystallite_fi(1:3,1:3,g,i,e), &
                                            crystallite_partionedfp0, &
                                            crystallite_subdt(g,i,e), g,i,e)
          crystallite_todo(g,i,e) = all(.not. ieee_is_nan(plasticstate(p)%dotState(:,c)))
          do s = 1, phase_nsources(p)
            crystallite_todo(g,i,e) = crystallite_todo(g,i,e) .and. all(.not. ieee_is_nan(sourcestate(p)%p(s)%dotState(:,c)))
          enddo
          if(.not. (crystallite_todo(g,i,e) .or. crystallite_localplasticity(g,i,e))) &
            nonlocalbroken = .true.
          if(.not. crystallite_todo(g,i,e)) cycle
 
          do stage = 1,5
 
            plasticstate(p)%RKCK45dotState(stage,:,c) = plasticstate(p)%dotState(:,c)
            plasticstate(p)%dotState(:,c) = a(1,stage) * plasticstate(p)%RKCK45dotState(1,:,c)
            do s = 1, phase_nsources(p)
              sourcestate(p)%p(s)%RKCK45dotState(stage,:,c) = sourcestate(p)%p(s)%dotState(:,c)
              sourcestate(p)%p(s)%dotState(:,c) = a(1,stage) * sourcestate(p)%p(s)%RKCK45dotState(1,:,c)
            enddo
 
            do n = 2, stage
              plasticstate(p)%dotState(:,c) = plasticstate(p)%dotState(:,c) &
                                            + a(n,stage) * plasticstate(p)%RKCK45dotState(n,:,c)
              do s = 1, phase_nsources(p)
                sourcestate(p)%p(s)%dotState(:,c) = sourcestate(p)%p(s)%dotState(:,c) &
                                                  + a(n,stage) * sourcestate(p)%p(s)%RKCK45dotState(n,:,c)
              enddo
            enddo
 
            sizedotstate = plasticstate(p)%sizeDotState
            plasticstate(p)%state(1:sizedotstate,c) = plasticstate(p)%subState0(1:sizedotstate,c) &
                                                    + plasticstate(p)%dotState (1:sizedotstate,c) &
                                                      * crystallite_subdt(g,i,e)
            do s = 1, phase_nsources(p)
              sizedotstate = sourcestate(p)%p(s)%sizeDotState
              sourcestate(p)%p(s)%state(1:sizedotstate,c) = sourcestate(p)%p(s)%subState0(1:sizedotstate,c) &
                                                          + sourcestate(p)%p(s)%dotState (1:sizedotstate,c) &
                                                            * crystallite_subdt(g,i,e)
            enddo
 
            call constitutive_dependentstate(crystallite_partionedf(1:3,1:3,g,i,e), &
                                             crystallite_fp(1:3,1:3,g,i,e), &
                                             g, i, e)
 
            crystallite_todo(g,i,e) = integratestress(g,i,e,cc(stage))
            if(.not. (crystallite_todo(g,i,e) .or. crystallite_localplasticity(g,i,e))) &
              nonlocalbroken = .true.
            if(.not. crystallite_todo(g,i,e)) exit
 
            call constitutive_collectdotstate(crystallite_s(1:3,1:3,g,i,e), &
                                              crystallite_partionedf0, &
                                              crystallite_fi(1:3,1:3,g,i,e), &
                                              crystallite_partionedfp0, &
                                              crystallite_subdt(g,i,e)*cc(stage), g,i,e)
            crystallite_todo(g,i,e) = all(.not. ieee_is_nan(plasticstate(p)%dotState(:,c)))
            do s = 1, phase_nsources(p)
              crystallite_todo(g,i,e) = crystallite_todo(g,i,e) .and. all(.not. ieee_is_nan(sourcestate(p)%p(s)%dotState(:,c)))
            enddo
            if(.not. (crystallite_todo(g,i,e) .or. crystallite_localplasticity(g,i,e))) &
              nonlocalbroken = .true.
            if(.not. crystallite_todo(g,i,e)) exit
 
          enddo
 
          if(.not. crystallite_todo(g,i,e)) cycle
 
          sizedotstate = plasticstate(p)%sizeDotState
 
          plasticstate(p)%RKCK45dotState(6,:,c) = plasticstate(p)%dotState(:,c)
          residuum_plastic(1:sizedotstate,g,i,e) = matmul(db,plasticstate(p)%RKCK45dotState(1:6,1:sizedotstate,c)) &
                                                   * crystallite_subdt(g,i,e)
          plasticstate(p)%dotState(:,c) =  matmul(b,plasticstate(p)%RKCK45dotState(1:6,1:sizedotstate,c))
          plasticstate(p)%state(1:sizedotstate,c) = plasticstate(p)%subState0(1:sizedotstate,c) &
                                                  + plasticstate(p)%dotState (1:sizedotstate,c) &
                                                    * crystallite_subdt(g,i,e)
          crystallite_todo(g,i,e) = converged(residuum_plastic(1:sizedotstate,g,i,e), &
                                              plasticstate(p)%state(1:sizedotstate,c), &
                                              plasticstate(p)%atol(1:sizedotstate))
 
          do s = 1, phase_nsources(p)
            sizedotstate = sourcestate(p)%p(s)%sizeDotState
 
            sourcestate(p)%p(s)%RKCK45dotState(6,:,c) = sourcestate(p)%p(s)%dotState(:,c)
            residuum_source(1:sizedotstate,s,g,i,e) = matmul(db,sourcestate(p)%p(s)%RKCK45dotState(1:6,1:sizedotstate,c)) &
                                                      * crystallite_subdt(g,i,e)
            sourcestate(p)%p(s)%dotState(:,c)  = matmul(b,sourcestate(p)%p(s)%RKCK45dotState(1:6,1:sizedotstate,c))
            sourcestate(p)%p(s)%state(1:sizedotstate,c) = sourcestate(p)%p(s)%subState0(1:sizedotstate,c) &
                                                        + sourcestate(p)%p(s)%dotState (1:sizedotstate,c) &
                                                          * crystallite_subdt(g,i,e)
            crystallite_todo(g,i,e) = crystallite_todo(g,i,e) .and. &
                                      converged(residuum_source(1:sizedotstate,s,g,i,e), &
                                                sourcestate(p)%p(s)%state(1:sizedotstate,c), &
                                                sourcestate(p)%p(s)%atol(1:sizedotstate))
          enddo
          if(.not. (crystallite_todo(g,i,e) .or. crystallite_localplasticity(g,i,e))) &
            nonlocalbroken = .true.
          if(.not. crystallite_todo(g,i,e)) cycle
 
          crystallite_todo(g,i,e) = statejump(g,i,e)
          if(.not. (crystallite_todo(g,i,e) .or. crystallite_localplasticity(g,i,e))) &
            nonlocalbroken = .true.
          if(.not. crystallite_todo(g,i,e)) cycle
 
          call constitutive_dependentstate(crystallite_partionedf(1:3,1:3,g,i,e), &
                                           crystallite_fp(1:3,1:3,g,i,e), &
                                           g, i, e)
 
          crystallite_todo(g,i,e) = integratestress(g,i,e)
          if(.not. (crystallite_todo(g,i,e) .or. crystallite_localplasticity(g,i,e))) &
            nonlocalbroken = .true.
          crystallite_converged(g,i,e) = crystallite_todo(g,i,e)                                    ! consider converged if not broken
 
        endif
  enddo; enddo; enddo
  !$OMP END PARALLEL DO
 
  if(nonlocalbroken) where(.not. crystallite_localplasticity) crystallite_todo = .false.
  if (any(plasticstate(:)%nonlocal)) call nonlocalconvergencecheck
 
end subroutine integratestaterkck45
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine nonlocalconvergencecheck
 
 if (any(.not. crystallite_converged .and. .not. crystallite_localplasticity)) &                    ! any non-local not yet converged (or broken)...
   where( .not. crystallite_localplasticity) crystallite_converged = .false.
 
end subroutine nonlocalconvergencecheck
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
logical pure function converged(residuum,state,atol)
 
  real(pReal), intent(in), dimension(:) ::&
    residuum, state, atol
  real(pReal) :: &
    rTol
 
  rtol = num%rTol_crystalliteState
 
  converged = all(abs(residuum) <= max(atol, rtol*abs(state)))
 
end function converged
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
logical function statejump(ipc,ip,el)
 
  integer, intent(in):: &
    el, &                       ! element index
    ip, &                       ! integration point index
    ipc                         ! grain index
 
  integer :: &
    c, &
    p, &
    mysource, &
    myoffset, &
    mysize
 
  c = material_phasememberat(ipc,ip,el)
  p = material_phaseat(ipc,el)
 
  call constitutive_collectdeltastate(crystallite_s(1:3,1:3,ipc,ip,el), &
                                      crystallite_fe(1:3,1:3,ipc,ip,el), &
                                      crystallite_fi(1:3,1:3,ipc,ip,el), &
                                      ipc,ip,el)
 
  myoffset = plasticstate(p)%offsetDeltaState
  mysize   = plasticstate(p)%sizeDeltaState
 
  if( any(ieee_is_nan(plasticstate(p)%deltaState(1:mysize,c)))) then
    statejump = .false.
    return
  endif
 
  plasticstate(p)%state(myoffset + 1:myoffset + mysize,c) = &
  plasticstate(p)%state(myoffset + 1:myoffset + mysize,c) + plasticstate(p)%deltaState(1:mysize,c)
 
  do mysource = 1, phase_nsources(p)
    myoffset = sourcestate(p)%p(mysource)%offsetDeltaState
    mysize   = sourcestate(p)%p(mysource)%sizeDeltaState
    if (any(ieee_is_nan(sourcestate(p)%p(mysource)%deltaState(1:mysize,c)))) then
      statejump = .false.
      return
    endif
    sourcestate(p)%p(mysource)%state(myoffset + 1: myoffset + mysize,c) = &
    sourcestate(p)%p(mysource)%state(myoffset + 1: myoffset + mysize,c) + sourcestate(p)%p(mysource)%deltaState(1:mysize,c)
  enddo
 
  statejump = .true.
 
end function statejump
 
 
!--------------------------------------------------------------------------------------------------
! ToDo: Merge data into one file for MPI, move state to constitutive and homogenization, respectively
!--------------------------------------------------------------------------------------------------
subroutine crystallite_restartwrite
 
  integer :: i
  integer(HID_T) :: filehandle, grouphandle
  character(len=pStringLen) :: filename, datasetname
 
  write(6,'(a)') ' writing field and constitutive data required for restart to file';flush(6)
 
  write(filename,'(a,i0,a)') trim(getsolverjobname())//'_',worldrank,'.hdf5'
  filehandle = hdf5_openfile(filename,'a')
 
  call hdf5_write(filehandle,crystallite_partionedf,'F')
  call hdf5_write(filehandle,crystallite_fp,        'Fp')
  call hdf5_write(filehandle,crystallite_fi,        'Fi')
  call hdf5_write(filehandle,crystallite_lp,        'Lp')
  call hdf5_write(filehandle,crystallite_li,        'Li')
  call hdf5_write(filehandle,crystallite_s,         'S')
 
  grouphandle = hdf5_addgroup(filehandle,'constituent')
  do i = 1,size(phase_plasticity)
    write(datasetname,'(i0,a)') i,'_omega_plastic'
    call hdf5_write(grouphandle,plasticstate(i)%state,datasetname)
  enddo
  call hdf5_closegroup(grouphandle)
 
  grouphandle = hdf5_addgroup(filehandle,'materialpoint')
  do i = 1, material_nhomogenization
    write(datasetname,'(i0,a)') i,'_omega_homogenization'
    call hdf5_write(grouphandle,homogstate(i)%state,datasetname)
  enddo
  call hdf5_closegroup(grouphandle)
 
  call hdf5_closefile(filehandle)
 
end subroutine crystallite_restartwrite
 
 
!--------------------------------------------------------------------------------------------------
! ToDo: Merge data into one file for MPI, move state to constitutive and homogenization, respectively
!--------------------------------------------------------------------------------------------------
subroutine crystallite_restartread
 
  integer :: i
  integer(HID_T) :: fileHandle, groupHandle
  character(len=pStringLen) :: fileName, datasetName
 
  write(6,'(/,a,i0,a)') ' reading restart information of increment from file'
 
  write(filename,'(a,i0,a)') trim(getsolverjobname())//'_',worldrank,'.hdf5'
  filehandle = hdf5_openfile(filename)
 
  call hdf5_read(filehandle,crystallite_f0, 'F')
  call hdf5_read(filehandle,crystallite_fp0,'Fp')
  call hdf5_read(filehandle,crystallite_fi0,'Fi')
  call hdf5_read(filehandle,crystallite_lp0,'Lp')
  call hdf5_read(filehandle,crystallite_li0,'Li')
  call hdf5_read(filehandle,crystallite_s0, 'S')
 
  grouphandle = hdf5_opengroup(filehandle,'constituent')
  do i = 1,size(phase_plasticity)
    write(datasetname,'(i0,a)') i,'_omega_plastic'
    call hdf5_read(grouphandle,plasticstate(i)%state0,datasetname)
  enddo
  call hdf5_closegroup(grouphandle)
 
  grouphandle = hdf5_opengroup(filehandle,'materialpoint')
  do i = 1, material_nhomogenization
    write(datasetname,'(i0,a)') i,'_omega_homogenization'
    call hdf5_read(grouphandle,homogstate(i)%state0,datasetname)
  enddo
  call hdf5_closegroup(grouphandle)
 
  call hdf5_closefile(filehandle)
 
end subroutine crystallite_restartread
 
 
!--------------------------------------------------------------------------------------------------
! ToDo: Any guessing for the current states possible?
!--------------------------------------------------------------------------------------------------
subroutine crystallite_forward
 
  integer :: i, j
 
  crystallite_f0  = crystallite_partionedf
  crystallite_fp0 = crystallite_fp
  crystallite_lp0 = crystallite_lp
  crystallite_fi0 = crystallite_fi
  crystallite_li0 = crystallite_li
  crystallite_s0  = crystallite_s
 
  do i = 1, size(plasticstate)
    plasticstate(i)%state0 = plasticstate(i)%state
  enddo
  do i = 1, size(sourcestate)
    do j = 1,phase_nsources(i)
      sourcestate(i)%p(j)%state0 = sourcestate(i)%p(j)%state
  enddo; enddo
  do i = 1, material_nhomogenization
    homogstate(i)%state0 = homogstate(i)%state
    thermalstate(i)%state0 = thermalstate(i)%state
    damagestate(i)%state0 = damagestate(i)%state
  enddo
 
end subroutine crystallite_forward
 
end module crystallite
# 45 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/thermal_isothermal.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module thermal_isothermal
  use config
  use material
 
  implicit none
  public
  
contains
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine thermal_isothermal_init
 
  integer :: h,NofMyHomog
 
  write(6,'(/,a)')   ' <<<+-  thermal_'//thermal_isothermal_label//' init  -+>>>'; flush(6)
 
  do h = 1, size(config_homogenization)
    if (thermal_type(h) /= thermal_isothermal_id) cycle
 
    nofmyhomog = count(material_homogenizationat == h)
    thermalstate(h)%sizeState = 0
    allocate(thermalstate(h)%state0   (0,nofmyhomog))
    allocate(thermalstate(h)%subState0(0,nofmyhomog))
    allocate(thermalstate(h)%state    (0,nofmyhomog))
      
    deallocate(temperature(h)%p)
    allocate  (temperature(h)%p(1), source=thermal_initialt(h))
    deallocate(temperaturerate(h)%p)
    allocate  (temperaturerate(h)%p(1))
 
  enddo
 
end subroutine thermal_isothermal_init
 
end module thermal_isothermal
# 46 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/thermal_adiabatic.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module thermal_adiabatic
  use prec
  use config
  use numerics
  use material
  use results
  use source_thermal_dissipation
  use source_thermal_externalheat
  use crystallite
  use lattice
 
  implicit none
  private
 
  type :: tparameters
    character(len=pStringLen), allocatable, dimension(:) :: &
      output
  end type tparameters
  
  type(tparameters),             dimension(:), allocatable :: &
    param
 
  public :: &
    thermal_adiabatic_init, &
    thermal_adiabatic_updatestate, &
    thermal_adiabatic_getsourceanditstangent, &
    thermal_adiabatic_getspecificheat, &
    thermal_adiabatic_getmassdensity, &
    thermal_adiabatic_results
 
contains
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine thermal_adiabatic_init
 
  integer :: maxninstance,h,nofmyhomog   
 
  write(6,'(/,a)') ' <<<+-  thermal_'//thermal_adiabatic_label//' init  -+>>>'; flush(6)
  
  maxninstance = count(thermal_type == thermal_adiabatic_id)
  if (maxninstance == 0) return
  
  allocate(param(maxninstance))
  
  do h = 1, size(thermal_type)
    if (thermal_type(h) /= thermal_adiabatic_id) cycle
    associate(prm => param(thermal_typeinstance(h)),config => config_homogenization(h))
              
    prm%output = config%getStrings('(output)',defaultval=emptystringarray)
 
    nofmyhomog=count(material_homogenizationat==h)
    thermalstate(h)%sizeState = 1
    allocate(thermalstate(h)%state0   (1,nofmyhomog), source=thermal_initialt(h))
    allocate(thermalstate(h)%subState0(1,nofmyhomog), source=thermal_initialt(h))
    allocate(thermalstate(h)%state    (1,nofmyhomog), source=thermal_initialt(h))
 
    thermalmapping(h)%p => material_homogenizationmemberat
    deallocate(temperature(h)%p)
    temperature(h)%p => thermalstate(h)%state(1,:)
    deallocate(temperaturerate(h)%p)
    allocate  (temperaturerate(h)%p(nofmyhomog), source=0.0_preal)
  
    end associate
  enddo
 
end subroutine thermal_adiabatic_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function thermal_adiabatic_updatestate(subdt, ip, el)
  
  integer,     intent(in) :: &
    ip, &                                                                                           !< integration point number
    el
  real(preal), intent(in) :: &
    subdt
 
  logical, dimension(2)  :: &
    thermal_adiabatic_updatestate
  integer :: &
    homog, &
    offset
  real(preal) :: &
    t, tdot, dtdot_dt  
 
  homog  = material_homogenizationat(el)
  offset = material_homogenizationmemberat(ip,el)
  
  t = thermalstate(homog)%subState0(1,offset)
  call thermal_adiabatic_getsourceanditstangent(tdot, dtdot_dt, t, ip, el)
  t = t + subdt*tdot/(thermal_adiabatic_getspecificheat(ip,el)*thermal_adiabatic_getmassdensity(ip,el))
  
  thermal_adiabatic_updatestate = [     abs(t - thermalstate(homog)%state(1,offset)) &
                                     <= err_thermal_tolabs &
                                   .or. abs(t - thermalstate(homog)%state(1,offset)) &
                                     <= err_thermal_tolrel*abs(thermalstate(homog)%state(1,offset)), &
                                   .true.]
 
  temperature(homog)%p(thermalmapping(homog)%p(ip,el)) = t  
  temperaturerate(homog)%p(thermalmapping(homog)%p(ip,el)) = &
    (thermalstate(homog)%state(1,offset) - thermalstate(homog)%subState0(1,offset))/(subdt+tiny(0.0_preal))
  
end function thermal_adiabatic_updatestate
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine thermal_adiabatic_getsourceanditstangent(Tdot, dTdot_dT, T, ip, el)
 
  integer,     intent(in) :: &
    ip, &                                                                                           !< integration point number
    el
  real(preal), intent(in) :: &
    t
  real(preal), intent(out) :: &
    tdot, dtdot_dt
 
  real(preal) :: &
    my_tdot, my_dtdot_dt
  integer :: &
    phase, &
    homog, &
    instance, &
    grain, &
    source, &
    constituent
    
  homog  = material_homogenizationat(el)
  instance = thermal_typeinstance(homog)
   
  tdot = 0.0_preal
  dtdot_dt = 0.0_preal
  do grain = 1, homogenization_ngrains(homog)
    phase = material_phaseat(grain,el)
    constituent = material_phasememberat(grain,ip,el)
    do source = 1, phase_nsources(phase)
      select case(phase_source(source,phase))                                                   
        case (source_thermal_dissipation_id)
         call source_thermal_dissipation_getrateanditstangent(my_tdot, my_dtdot_dt, &
                                                              crystallite_s(1:3,1:3,grain,ip,el), &
                                                              crystallite_lp(1:3,1:3,grain,ip,el), &
                                                              phase)
 
        case (source_thermal_externalheat_id)
         call source_thermal_externalheat_getrateanditstangent(my_tdot, my_dtdot_dt, &
                                                               phase, constituent)
 
        case default
         my_tdot = 0.0_preal
         my_dtdot_dt = 0.0_preal
      end select
      tdot = tdot + my_tdot
      dtdot_dt = dtdot_dt + my_dtdot_dt
    enddo  
  enddo
  
  tdot = tdot/real(homogenization_ngrains(homog),preal)
  dtdot_dt = dtdot_dt/real(homogenization_ngrains(homog),preal)
 
end subroutine thermal_adiabatic_getsourceanditstangent
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function thermal_adiabatic_getspecificheat(ip,el)
 
  integer, intent(in) :: &
    ip, &                                                                                           !< integration point number
    el
  
  real(preal) :: &
    thermal_adiabatic_getspecificheat
  integer :: &
    grain
   
  thermal_adiabatic_getspecificheat = 0.0_preal
  
  do grain = 1, homogenization_ngrains(material_homogenizationat(el))
    thermal_adiabatic_getspecificheat = thermal_adiabatic_getspecificheat & 
                                      + lattice_specificheat(material_phaseat(grain,el))
  enddo
 
  thermal_adiabatic_getspecificheat = thermal_adiabatic_getspecificheat &
                                    / real(homogenization_ngrains(material_homogenizationat(el)),preal)
  
end function thermal_adiabatic_getspecificheat
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function thermal_adiabatic_getmassdensity(ip,el)
    
  integer, intent(in) :: &
    ip, &                                                                                           !< integration point number
    el
  real(preal) :: &
    thermal_adiabatic_getmassdensity
  integer :: &
    grain
   
  thermal_adiabatic_getmassdensity = 0.0_preal
 
  do grain = 1, homogenization_ngrains(material_homogenizationat(el))
    thermal_adiabatic_getmassdensity = thermal_adiabatic_getmassdensity &
                                     + lattice_massdensity(material_phaseat(grain,el))
  enddo
 
  thermal_adiabatic_getmassdensity = thermal_adiabatic_getmassdensity &
                                   / real(homogenization_ngrains(material_homogenizationat(el)),preal)
 
end function thermal_adiabatic_getmassdensity
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine thermal_adiabatic_results(homog,group)
 
  integer,          intent(in) :: homog
  character(len=*), intent(in) :: group
 
  integer :: o
  
  associate(prm => param(damage_typeinstance(homog)))
  outputsloop: do o = 1,size(prm%output)
    select case(trim(prm%output(o)))
      case('temperature')                                                                           ! ToDo: should be 'T'
        call results_writedataset(group,temperature(homog)%p,'T',&
                                  'temperature','K')
    end select
  enddo outputsloop
  end associate
 
end subroutine thermal_adiabatic_results
 
end module thermal_adiabatic
# 47 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/thermal_conduction.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module thermal_conduction
  use prec
  use material
  use config
  use lattice
  use results
  use crystallite
  use source_thermal_dissipation
  use source_thermal_externalheat
 
  implicit none
  private
 
  type :: tparameters
    character(len=pStringLen), allocatable, dimension(:) :: &
      output
  end type tparameters
 
  type(tparameters),             dimension(:), allocatable :: &
    param
 
  public :: &
    thermal_conduction_init, &
    thermal_conduction_getsourceanditstangent, &
    thermal_conduction_getconductivity, &
    thermal_conduction_getspecificheat, &
    thermal_conduction_getmassdensity, &
    thermal_conduction_puttemperatureanditsrate, &
    thermal_conduction_results
 
contains
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine thermal_conduction_init
 
  integer :: ninstance,nofmyhomog,h
 
  write(6,'(/,a)') ' <<<+-  thermal_'//thermal_conduction_label//' init  -+>>>'; flush(6)
 
  ninstance = count(thermal_type == thermal_conduction_id)
  allocate(param(ninstance))
 
  do h = 1, size(config_homogenization)
    if (thermal_type(h) /= thermal_conduction_id) cycle
    associate(prm => param(thermal_typeinstance(h)),config => config_homogenization(h))
 
    prm%output = config%getStrings('(output)',defaultval=emptystringarray)
 
    nofmyhomog=count(material_homogenizationat==h)
    thermalstate(h)%sizeState = 0
    allocate(thermalstate(h)%state0   (0,nofmyhomog))
    allocate(thermalstate(h)%subState0(0,nofmyhomog))
    allocate(thermalstate(h)%state    (0,nofmyhomog))
 
    thermalmapping(h)%p => material_homogenizationmemberat
    deallocate(temperature(h)%p)
    allocate  (temperature(h)%p(nofmyhomog), source=thermal_initialt(h))
    deallocate(temperaturerate(h)%p)
    allocate  (temperaturerate(h)%p(nofmyhomog), source=0.0_preal)
 
    end associate
  enddo
 
end subroutine thermal_conduction_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine thermal_conduction_getsourceanditstangent(Tdot, dTdot_dT, T, ip, el)
 
  integer, intent(in) :: &
    ip, &                                                                                           !< integration point number
    el
  real(preal), intent(in) :: &
    t
  real(preal), intent(out) :: &
    tdot, dtdot_dt
  real(preal) :: &
    my_tdot, my_dtdot_dt
  integer :: &
    phase, &
    homog, &
    offset, &
    instance, &
    grain, &
    source, &
    constituent
 
  homog  = material_homogenizationat(el)
  offset = material_homogenizationmemberat(ip,el)
  instance = thermal_typeinstance(homog)
 
  tdot = 0.0_preal
  dtdot_dt = 0.0_preal
  do grain = 1, homogenization_ngrains(homog)
    phase = material_phaseat(grain,el)
    constituent = material_phasememberat(grain,ip,el)
    do source = 1, phase_nsources(phase)
      select case(phase_source(source,phase))
        case (source_thermal_dissipation_id)
          call source_thermal_dissipation_getrateanditstangent(my_tdot, my_dtdot_dt, &
                                                               crystallite_s(1:3,1:3,grain,ip,el), &
                                                               crystallite_lp(1:3,1:3,grain,ip,el), &
                                                               phase)
 
        case (source_thermal_externalheat_id)
          call source_thermal_externalheat_getrateanditstangent(my_tdot, my_dtdot_dt, &
                                                                phase, constituent)
        case default
         my_tdot = 0.0_preal
         my_dtdot_dt = 0.0_preal
 
      end select
      tdot = tdot + my_tdot
      dtdot_dt = dtdot_dt + my_dtdot_dt
    enddo
  enddo
 
  tdot = tdot/real(homogenization_ngrains(homog),preal)
  dtdot_dt = dtdot_dt/real(homogenization_ngrains(homog),preal)
 
end subroutine thermal_conduction_getsourceanditstangent
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function thermal_conduction_getconductivity(ip,el)
 
  integer, intent(in) :: &
    ip, &                                                                                           !< integration point number
    el
  real(preal), dimension(3,3) :: &
    thermal_conduction_getconductivity
  integer :: &
    grain
 
 
  thermal_conduction_getconductivity = 0.0_preal
  do grain = 1, homogenization_ngrains(material_homogenizationat(el))
    thermal_conduction_getconductivity = thermal_conduction_getconductivity + &
     crystallite_push33toref(grain,ip,el,lattice_thermalconductivity(:,:,material_phaseat(grain,el)))
  enddo
 
  thermal_conduction_getconductivity = thermal_conduction_getconductivity &
                                     / real(homogenization_ngrains(material_homogenizationat(el)),preal)
 
end function thermal_conduction_getconductivity
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function thermal_conduction_getspecificheat(ip,el)
 
  integer, intent(in) :: &
    ip, &                                                                                           !< integration point number
    el
  real(preal) :: &
    thermal_conduction_getspecificheat
  integer :: &
    grain
 
  thermal_conduction_getspecificheat = 0.0_preal
 
  do grain = 1, homogenization_ngrains(material_homogenizationat(el))
    thermal_conduction_getspecificheat = thermal_conduction_getspecificheat &
                                       + lattice_specificheat(material_phaseat(grain,el))
  enddo
 
  thermal_conduction_getspecificheat = thermal_conduction_getspecificheat &
                                     / real(homogenization_ngrains(material_homogenizationat(el)),preal)
 
end function thermal_conduction_getspecificheat
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function thermal_conduction_getmassdensity(ip,el)
 
  integer, intent(in) :: &
    ip, &                                                                                           !< integration point number
    el
  real(preal) :: &
    thermal_conduction_getmassdensity
  integer :: &
    grain
 
  thermal_conduction_getmassdensity = 0.0_preal
 
 
  do grain = 1, homogenization_ngrains(material_homogenizationat(el))
    thermal_conduction_getmassdensity = thermal_conduction_getmassdensity &
                                      + lattice_massdensity(material_phaseat(grain,el))
  enddo
 
  thermal_conduction_getmassdensity = thermal_conduction_getmassdensity &
                                    / real(homogenization_ngrains(material_homogenizationat(el)),preal)
 
end function thermal_conduction_getmassdensity
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine thermal_conduction_puttemperatureanditsrate(T,Tdot,ip,el)
 
  integer, intent(in) :: &
    ip, &                                                                                           !< integration point number
    el
  real(preal),   intent(in) :: &
    t, &
    tdot
  integer :: &
    homog, &
    offset
 
  homog  = material_homogenizationat(el)
  offset = thermalmapping(homog)%p(ip,el)
  temperature(homog)%p(offset) = t
  temperaturerate(homog)%p(offset) = tdot
 
end subroutine thermal_conduction_puttemperatureanditsrate
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine thermal_conduction_results(homog,group)
 
  integer,          intent(in) :: homog
  character(len=*), intent(in) :: group
 
  integer :: o
 
  associate(prm => param(damage_typeinstance(homog)))
  outputsloop: do o = 1,size(prm%output)
    select case(trim(prm%output(o)))
      case('temperature')                                                                           ! ToDo: should be 'T'
        call results_writedataset(group,temperature(homog)%p,'T',&
                                  'temperature','K')
    end select
  enddo outputsloop
  end associate
 
end subroutine thermal_conduction_results
 
end module thermal_conduction
# 48 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/damage_none.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module damage_none
  use config
  use material
 
  implicit none
  public
 
contains
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine damage_none_init
 
  integer :: h,NofMyHomog
 
  write(6,'(/,a)') ' <<<+-  damage_'//damage_none_label//' init  -+>>>'; flush(6)
 
  do h = 1, size(config_homogenization)
    if (damage_type(h) /= damage_none_id) cycle
 
    nofmyhomog = count(material_homogenizationat == h)
    damagestate(h)%sizeState = 0
    allocate(damagestate(h)%state0   (0,nofmyhomog))
    allocate(damagestate(h)%subState0(0,nofmyhomog))
    allocate(damagestate(h)%state    (0,nofmyhomog))
 
    deallocate(damage(h)%p)
    allocate  (damage(h)%p(1), source=damage_initialphi(h))
 
  enddo
 
end subroutine damage_none_init
 
end module damage_none
# 49 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/damage_local.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module damage_local
  use prec
  use material
  use config
  use numerics
  use source_damage_isobrittle
  use source_damage_isoductile
  use source_damage_anisobrittle
  use source_damage_anisoductile
  use results
 
  implicit none
  private
 
  type :: tparameters
    character(len=pStringLen), allocatable, dimension(:) :: &
      output
  end type tparameters
 
  type(tparameters),             dimension(:),   allocatable :: &
    param
 
  public :: &
    damage_local_init, &
    damage_local_updatestate, &
    damage_local_results
 
contains
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine damage_local_init
 
  integer :: ninstance,nofmyhomog,h
 
  write(6,'(/,a)') ' <<<+-  damage_'//damage_local_label//' init  -+>>>'; flush(6)
 
  ninstance = count(damage_type == damage_local_id)
  allocate(param(ninstance))
 
  do h = 1, size(config_homogenization)
    if (damage_type(h) /= damage_local_id) cycle
    associate(prm => param(damage_typeinstance(h)),config => config_homogenization(h))
 
    prm%output = config%getStrings('(output)',defaultval=emptystringarray)
 
    nofmyhomog = count(material_homogenizationat == h)
    damagestate(h)%sizeState = 1
    allocate(damagestate(h)%state0   (1,nofmyhomog), source=damage_initialphi(h))
    allocate(damagestate(h)%subState0(1,nofmyhomog), source=damage_initialphi(h))
    allocate(damagestate(h)%state    (1,nofmyhomog), source=damage_initialphi(h))
 
    nullify(damagemapping(h)%p)
    damagemapping(h)%p => material_homogenizationmemberat
    deallocate(damage(h)%p)
    damage(h)%p => damagestate(h)%state(1,:)
 
    end associate
  enddo
 
end subroutine damage_local_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function damage_local_updatestate(subdt, ip, el)
 
  integer, intent(in) :: &
    ip, &                                                                                           !< integration point number
    el
  real(preal),   intent(in) :: &
    subdt
  logical,    dimension(2)  :: &
    damage_local_updatestate
  integer :: &
    homog, &
    offset
  real(preal) :: &
    phi, phidot, dphidot_dphi
 
  homog  = material_homogenizationat(el)
  offset = material_homogenizationmemberat(ip,el)
  phi = damagestate(homog)%subState0(1,offset)
  call damage_local_getsourceanditstangent(phidot, dphidot_dphi, phi, ip, el)
  phi = max(residualstiffness,min(1.0_preal,phi + subdt*phidot))
 
  damage_local_updatestate = [     abs(phi - damagestate(homog)%state(1,offset)) &
                                <= err_damage_tolabs &
                              .or. abs(phi - damagestate(homog)%state(1,offset)) &
                                <= err_damage_tolrel*abs(damagestate(homog)%state(1,offset)), &
                              .true.]
 
  damagestate(homog)%state(1,offset) = phi
 
end function damage_local_updatestate
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine damage_local_getsourceanditstangent(phiDot, dPhiDot_dPhi, phi, ip, el)
 
  integer, intent(in) :: &
    ip, &                                                                                           !< integration point number
    el
  real(preal),   intent(in) :: &
    phi
  integer :: &
    phase, &
    grain, &
    source, &
    constituent
  real(pReal) :: &
    phiDot, dPhiDot_dPhi, localphiDot, dLocalphiDot_dPhi
 
  phidot = 0.0_preal
  dphidot_dphi = 0.0_preal
  do grain = 1, homogenization_ngrains(material_homogenizationat(el))
    phase = material_phaseat(grain,el)
    constituent = material_phasememberat(grain,ip,el)
    do source = 1, phase_nsources(phase)
      select case(phase_source(source,phase))
        case (source_damage_isobrittle_id)
         call source_damage_isobrittle_getrateanditstangent  (localphidot, dlocalphidot_dphi, phi, phase, constituent)
 
        case (source_damage_isoductile_id)
         call source_damage_isoductile_getrateanditstangent  (localphidot, dlocalphidot_dphi, phi, phase, constituent)
 
        case (source_damage_anisobrittle_id)
         call source_damage_anisobrittle_getrateanditstangent(localphidot, dlocalphidot_dphi, phi, phase, constituent)
 
        case (source_damage_anisoductile_id)
         call source_damage_anisoductile_getrateanditstangent(localphidot, dlocalphidot_dphi, phi, phase, constituent)
 
        case default
         localphidot = 0.0_preal
         dlocalphidot_dphi = 0.0_preal
 
      end select
      phidot = phidot + localphidot
      dphidot_dphi = dphidot_dphi + dlocalphidot_dphi
    enddo
  enddo
 
  phidot = phidot/real(homogenization_ngrains(material_homogenizationat(el)),preal)
  dphidot_dphi = dphidot_dphi/real(homogenization_ngrains(material_homogenizationat(el)),preal)
 
end subroutine damage_local_getsourceanditstangent
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine damage_local_results(homog,group)
 
  integer,          intent(in) :: homog
  character(len=*), intent(in) :: group
 
  integer :: o
 
  associate(prm => param(damage_typeinstance(homog)))
  outputsloop: do o = 1,size(prm%output)
    select case(prm%output(o))
      case ('damage')
        call results_writedataset(group,damage(homog)%p,'phi',&
                                  'damage indicator','-')
    end select
  enddo outputsloop
  end associate
 
end subroutine damage_local_results
 
 
end module damage_local
# 50 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/damage_nonlocal.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module damage_nonlocal
  use prec
  use material
  use config
  use numerics
  use crystallite
  use lattice
  use source_damage_isobrittle
  use source_damage_isoductile
  use source_damage_anisobrittle
  use source_damage_anisoductile
  use results
 
  implicit none
  private
 
  type :: tparameters
    character(len=pStringLen), allocatable, dimension(:) :: &
      output
  end type tparameters
 
  type(tparameters),             dimension(:), allocatable :: &
    param
 
  public :: &
    damage_nonlocal_init, &
    damage_nonlocal_getsourceanditstangent, &
    damage_nonlocal_getdiffusion, &
    damage_nonlocal_getmobility, &
    damage_nonlocal_putnonlocaldamage, &
    damage_nonlocal_results
 
contains
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine damage_nonlocal_init
 
  integer :: ninstance,nofmyhomog,h
 
  write(6,'(/,a)') ' <<<+-  damage_'//damage_nonlocal_label//' init  -+>>>'; flush(6)
 
  ninstance = count(damage_type == damage_nonlocal_id)
  allocate(param(ninstance))
 
  do h = 1, size(config_homogenization)
    if (damage_type(h) /= damage_nonlocal_id) cycle
    associate(prm => param(damage_typeinstance(h)),config => config_homogenization(h))
 
    prm%output = config%getStrings('(output)',defaultval=emptystringarray)
 
    nofmyhomog = count(material_homogenizationat == h)
    damagestate(h)%sizeState = 1
    allocate(damagestate(h)%state0   (1,nofmyhomog), source=damage_initialphi(h))
    allocate(damagestate(h)%subState0(1,nofmyhomog), source=damage_initialphi(h))
    allocate(damagestate(h)%state    (1,nofmyhomog), source=damage_initialphi(h))
 
    nullify(damagemapping(h)%p)
    damagemapping(h)%p => material_homogenizationmemberat
    deallocate(damage(h)%p)
    damage(h)%p => damagestate(h)%state(1,:)
 
    end associate
  enddo
 
end subroutine damage_nonlocal_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine damage_nonlocal_getsourceanditstangent(phiDot, dPhiDot_dPhi, phi, ip, el)
 
  integer, intent(in) :: &
    ip, &                                                                                           !< integration point number
    el
  real(preal),   intent(in) :: &
    phi
  integer :: &
    phase, &
    grain, &
    source, &
    constituent
  real(preal) :: &
    phidot, dphidot_dphi, localphidot, dlocalphidot_dphi
 
  phidot = 0.0_preal
  dphidot_dphi = 0.0_preal
  do grain = 1, homogenization_ngrains(material_homogenizationat(el))
    phase = material_phaseat(grain,el)
    constituent = material_phasememberat(grain,ip,el)
    do source = 1, phase_nsources(phase)
      select case(phase_source(source,phase))
        case (source_damage_isobrittle_id)
         call source_damage_isobrittle_getrateanditstangent  (localphidot, dlocalphidot_dphi, phi, phase, constituent)
 
        case (source_damage_isoductile_id)
         call source_damage_isoductile_getrateanditstangent  (localphidot, dlocalphidot_dphi, phi, phase, constituent)
 
        case (source_damage_anisobrittle_id)
         call source_damage_anisobrittle_getrateanditstangent(localphidot, dlocalphidot_dphi, phi, phase, constituent)
 
        case (source_damage_anisoductile_id)
         call source_damage_anisoductile_getrateanditstangent(localphidot, dlocalphidot_dphi, phi, phase, constituent)
 
        case default
         localphidot = 0.0_preal
         dlocalphidot_dphi = 0.0_preal
 
      end select
      phidot = phidot + localphidot
      dphidot_dphi = dphidot_dphi + dlocalphidot_dphi
    enddo
  enddo
 
  phidot = phidot/real(homogenization_ngrains(material_homogenizationat(el)),preal)
  dphidot_dphi = dphidot_dphi/real(homogenization_ngrains(material_homogenizationat(el)),preal)
 
end subroutine damage_nonlocal_getsourceanditstangent
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function damage_nonlocal_getdiffusion(ip,el)
 
  integer, intent(in) :: &
    ip, &                                                                                           !< integration point number
    el
  real(preal), dimension(3,3) :: &
    damage_nonlocal_getdiffusion
  integer :: &
    homog, &
    grain
 
  homog  = material_homogenizationat(el)
  damage_nonlocal_getdiffusion = 0.0_preal
  do grain = 1, homogenization_ngrains(homog)
    damage_nonlocal_getdiffusion = damage_nonlocal_getdiffusion + &
      crystallite_push33toref(grain,ip,el,lattice_damagediffusion(1:3,1:3,material_phaseat(grain,el)))
  enddo
 
  damage_nonlocal_getdiffusion = &
    charlength**2*damage_nonlocal_getdiffusion/real(homogenization_ngrains(homog),preal)
 
end function damage_nonlocal_getdiffusion
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
real(pReal) function damage_nonlocal_getmobility(ip,el)
 
  integer, intent(in) :: &
    ip, &                                                                                           !< integration point number
    el
  integer :: &
    ipc
 
  damage_nonlocal_getmobility = 0.0_preal
 
  do ipc = 1, homogenization_ngrains(material_homogenizationat(el))
    damage_nonlocal_getmobility = damage_nonlocal_getmobility + lattice_damagemobility(material_phaseat(ipc,el))
  enddo
 
  damage_nonlocal_getmobility = damage_nonlocal_getmobility/&
                                real(homogenization_ngrains(material_homogenizationat(el)),preal)
 
end function damage_nonlocal_getmobility
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine damage_nonlocal_putnonlocaldamage(phi,ip,el)
 
  integer, intent(in) :: &
    ip, &                                                                                           !< integration point number
    el
  real(preal),   intent(in) :: &
    phi
  integer :: &
    homog, &
    offset
 
  homog  = material_homogenizationat(el)
  offset = damagemapping(homog)%p(ip,el)
  damage(homog)%p(offset) = phi
 
end subroutine damage_nonlocal_putnonlocaldamage
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine damage_nonlocal_results(homog,group)
 
  integer,          intent(in) :: homog
  character(len=*), intent(in) :: group
 
  integer :: o
 
  associate(prm => param(damage_typeinstance(homog)))
  outputsloop: do o = 1,size(prm%output)
    select case(prm%output(o))
      case ('damage')
        call results_writedataset(group,damage(homog)%p,'phi',&
                                  'damage indicator','-')
    end select
  enddo outputsloop
  end associate
 
end subroutine damage_nonlocal_results
 
end module damage_nonlocal
# 51 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/homogenization.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module homogenization
  use prec
  use io
  use config
  use debug
  use math
  use material
  use numerics
  use constitutive
  use crystallite
  use fesolving
  use discretization
  use thermal_isothermal
  use thermal_adiabatic
  use thermal_conduction
  use damage_none
  use damage_local
  use damage_nonlocal
  use results
 
  implicit none
  private
 
!--------------------------------------------------------------------------------------------------
! General variables for the homogenization at a  material point
  real(pReal),   dimension(:,:,:,:),   allocatable, public :: &
    materialpoint_F0, &                                                                             !< def grad of IP at start of FE increment
    materialpoint_F, &                                                                              !< def grad of IP to be reached at end of FE increment
    materialpoint_P
  real(pReal),   dimension(:,:,:,:,:,:), allocatable, public ::  &
    materialpoint_dPdF
 
  real(preal),   dimension(:,:,:,:),     allocatable :: &
    materialpoint_subf0, &                                                                          !< def grad of IP at beginning of homogenization increment
    materialpoint_subf
  real(preal),   dimension(:,:),         allocatable :: &
    materialpoint_subfrac, &
    materialpoint_substep, &
    materialpoint_subdt
  logical,       dimension(:,:),         allocatable :: &
    materialpoint_requested, &
    materialpoint_converged
  logical,       dimension(:,:,:),       allocatable :: &
    materialpoint_doneandhappy
 
  type :: tnumerics
    integer :: &
      nmpstate
    real(preal) :: &
      substepminhomog, &                                                                            !< minimum (relative) size of sub-step allowed during cutback in homogenization
      substepsizehomog, &                                                                           !< size of first substep when cutback in homogenization
      stepIncreaseHomog
  end type tnumerics
 
  type(tnumerics) :: num
 
  interface
 
    module subroutine mech_none_init
    end subroutine mech_none_init
 
    module subroutine mech_isostrain_init
    end subroutine mech_isostrain_init
 
    module subroutine mech_rgc_init
    end subroutine mech_rgc_init
 
 
    module subroutine mech_isostrain_partitiondeformation(f,avgf)
      real(preal),   dimension (:,:,:), intent(out) :: f
      real(preal),   dimension (3,3),   intent(in)  :: avgf
    end subroutine mech_isostrain_partitiondeformation
 
    module subroutine mech_rgc_partitiondeformation(f,avgf,instance,of)
      real(preal),   dimension (:,:,:), intent(out) :: f
      real(preal),   dimension (3,3),   intent(in)  :: avgf
      integer,                          intent(in)  :: &
        instance, &
        of
    end subroutine mech_rgc_partitiondeformation
 
 
    module subroutine mech_isostrain_averagestressanditstangent(avgp,davgpdavgf,p,dpdf,instance)
      real(preal),   dimension (3,3),       intent(out) :: avgp
      real(preal),   dimension (3,3,3,3),   intent(out) :: davgpdavgf
 
      real(preal),   dimension (:,:,:),     intent(in)  :: p
      real(preal),   dimension (:,:,:,:,:), intent(in)  :: dpdf
      integer,                              intent(in)  :: instance
    end subroutine mech_isostrain_averagestressanditstangent
 
    module subroutine mech_rgc_averagestressanditstangent(avgp,davgpdavgf,p,dpdf,instance)
      real(preal),   dimension (3,3),       intent(out) :: avgp
      real(preal),   dimension (3,3,3,3),   intent(out) :: davgpdavgf
 
      real(preal),   dimension (:,:,:),     intent(in)  :: p
      real(preal),   dimension (:,:,:,:,:), intent(in)  :: dpdf
      integer,                              intent(in)  :: instance
    end subroutine mech_rgc_averagestressanditstangent
 
 
    module function mech_rgc_updatestate(p,f,f0,avgf,dt,dpdf,ip,el)
      logical, dimension(2) :: mech_rgc_updatestate
      real(preal), dimension(:,:,:),     intent(in)    :: &
        p,&                                                                                         !< partitioned stresses
        f,&                                                                                         !< partitioned deformation gradients
        f0
     real(preal), dimension(:,:,:,:,:), intent(in) :: dpdf
     real(preal), dimension(3,3),       intent(in) :: avgf
     real(preal),                       intent(in) :: dt
     integer,                           intent(in) :: &
      ip, &                                                                                         !< integration point number
      el
    end function mech_rgc_updatestate
 
 
    module subroutine mech_rgc_results(instance,group)
      integer,          intent(in) :: instance
      character(len=*), intent(in) :: group
    end subroutine mech_rgc_results
 
  end interface
 
  public ::  &
    homogenization_init, &
    materialpoint_stressanditstangent, &
    homogenization_results
 
contains
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine homogenization_init
 
  if (any(homogenization_type == homogenization_none_id))      call mech_none_init
  if (any(homogenization_type == homogenization_isostrain_id)) call mech_isostrain_init
  if (any(homogenization_type == homogenization_rgc_id))       call mech_rgc_init
 
  if (any(thermal_type == thermal_isothermal_id)) call thermal_isothermal_init
  if (any(thermal_type == thermal_adiabatic_id))  call thermal_adiabatic_init
  if (any(thermal_type == thermal_conduction_id)) call thermal_conduction_init
 
  if (any(damage_type == damage_none_id))      call damage_none_init
  if (any(damage_type == damage_local_id))     call damage_local_init
  if (any(damage_type == damage_nonlocal_id))  call damage_nonlocal_init
 
  call config_deallocate('material.config/homogenization')
 
!--------------------------------------------------------------------------------------------------
! allocate and initialize global variables
  allocate(materialpoint_dpdf(3,3,3,3,discretization_nip,discretization_nelem),       source=0.0_preal)
  materialpoint_f0 = spread(spread(math_i3,3,discretization_nip),4,discretization_nelem)            ! initialize to identity
  materialpoint_f = materialpoint_f0                                                                ! initialize to identity
  allocate(materialpoint_subf0(3,3,discretization_nip,discretization_nelem),          source=0.0_preal)
  allocate(materialpoint_subf(3,3,discretization_nip,discretization_nelem),           source=0.0_preal)
  allocate(materialpoint_p(3,3,discretization_nip,discretization_nelem),              source=0.0_preal)
  allocate(materialpoint_subfrac(discretization_nip,discretization_nelem),            source=0.0_preal)
  allocate(materialpoint_substep(discretization_nip,discretization_nelem),            source=0.0_preal)
  allocate(materialpoint_subdt(discretization_nip,discretization_nelem),              source=0.0_preal)
  allocate(materialpoint_requested(discretization_nip,discretization_nelem),          source=.false.)
  allocate(materialpoint_converged(discretization_nip,discretization_nelem),          source=.true.)
  allocate(materialpoint_doneandhappy(2,discretization_nip,discretization_nelem),     source=.true.)
 
  write(6,'(/,a)') ' <<<+-  homogenization init  -+>>>'; flush(6)
 
  if (iand(debug_level(debug_homogenization), debug_levelbasic) /= 0) then
    write(6,'(a32,1x,7(i8,1x))')   'materialpoint_dPdF:             ', shape(materialpoint_dpdf)
    write(6,'(a32,1x,7(i8,1x))')   'materialpoint_F0:               ', shape(materialpoint_f0)
    write(6,'(a32,1x,7(i8,1x))')   'materialpoint_F:                ', shape(materialpoint_f)
    write(6,'(a32,1x,7(i8,1x))')   'materialpoint_subF0:            ', shape(materialpoint_subf0)
    write(6,'(a32,1x,7(i8,1x))')   'materialpoint_subF:             ', shape(materialpoint_subf)
    write(6,'(a32,1x,7(i8,1x))')   'materialpoint_P:                ', shape(materialpoint_p)
    write(6,'(a32,1x,7(i8,1x))')   'materialpoint_subFrac:          ', shape(materialpoint_subfrac)
    write(6,'(a32,1x,7(i8,1x))')   'materialpoint_subStep:          ', shape(materialpoint_substep)
    write(6,'(a32,1x,7(i8,1x))')   'materialpoint_subdt:            ', shape(materialpoint_subdt)
    write(6,'(a32,1x,7(i8,1x))')   'materialpoint_requested:        ', shape(materialpoint_requested)
    write(6,'(a32,1x,7(i8,1x))')   'materialpoint_converged:        ', shape(materialpoint_converged)
    write(6,'(a32,1x,7(i8,1x),/)') 'materialpoint_doneAndHappy:     ', shape(materialpoint_doneandhappy)
  endif
  flush(6)
 
  if (debug_g < 1 .or. debug_g > homogenization_ngrains(material_homogenizationat(debug_e))) &
    call io_error(602,ext_msg='constituent', el=debug_e, g=debug_g)
 
  num%nMPstate          = config_numerics%getInt(  'nmpstate',          defaultval=10)
  num%subStepMinHomog   = config_numerics%getFloat('substepminhomog',   defaultval=1.0e-3_preal)
  num%subStepSizeHomog  = config_numerics%getFloat('substepsizehomog',  defaultval=0.25_preal)
  num%stepIncreaseHomog = config_numerics%getFloat('stepincreasehomog', defaultval=1.5_preal)
  if (num%nMPstate < 1)                   call io_error(301,ext_msg='nMPstate')
  if (num%subStepMinHomog <= 0.0_preal)   call io_error(301,ext_msg='subStepMinHomog')
  if (num%subStepSizeHomog <= 0.0_preal)  call io_error(301,ext_msg='subStepSizeHomog')
  if (num%stepIncreaseHomog <= 0.0_preal) call io_error(301,ext_msg='stepIncreaseHomog')
 
end subroutine homogenization_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine materialpoint_stressanditstangent(updateJaco,dt)
 
  real(preal), intent(in) :: dt
  logical,     intent(in) :: updatejaco
  integer :: &
    niterationhomog, &
    niterationmpstate, &
    g, &                                                                                            !< grain number
    i, &                                                                                            !< integration point number
    e, &                                                                                            !< element number
    mysource, &
    myngrains
 
# 231 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/homogenization.f90"
 
!--------------------------------------------------------------------------------------------------
! initialize restoration points of ...
  do e = fesolving_execelem(1),fesolving_execelem(2)
    myngrains = homogenization_ngrains(material_homogenizationat(e))
    do i = fesolving_execip(1),fesolving_execip(2);
      do g = 1,myngrains
 
        plasticstate(material_phaseat(g,e))%partionedState0(:,material_phasememberat(g,i,e)) = &
        plasticstate(material_phaseat(g,e))%state0(         :,material_phasememberat(g,i,e))
        do mysource = 1, phase_nsources(material_phaseat(g,e))
          sourcestate(material_phaseat(g,e))%p(mysource)%partionedState0(:,material_phasememberat(g,i,e)) = &
          sourcestate(material_phaseat(g,e))%p(mysource)%state0(         :,material_phasememberat(g,i,e))
        enddo
 
        crystallite_partionedfp0(1:3,1:3,g,i,e) = crystallite_fp0(1:3,1:3,g,i,e)
        crystallite_partionedlp0(1:3,1:3,g,i,e) = crystallite_lp0(1:3,1:3,g,i,e)
        crystallite_partionedfi0(1:3,1:3,g,i,e) = crystallite_fi0(1:3,1:3,g,i,e)
        crystallite_partionedli0(1:3,1:3,g,i,e) = crystallite_li0(1:3,1:3,g,i,e)
        crystallite_partionedf0(1:3,1:3,g,i,e)  = crystallite_f0(1:3,1:3,g,i,e)
        crystallite_partioneds0(1:3,1:3,g,i,e)  = crystallite_s0(1:3,1:3,g,i,e)
 
      enddo
 
 
      materialpoint_subf0(1:3,1:3,i,e) = materialpoint_f0(1:3,1:3,i,e)
      materialpoint_subfrac(i,e) = 0.0_preal
      materialpoint_substep(i,e) = 1.0_preal/num%subStepSizeHomog                                   ! <<added to adopt flexibility in cutback size>>
      materialpoint_converged(i,e) = .false.                                                        ! pretend failed step of twice the required size
      materialpoint_requested(i,e) = .true.                                                         ! everybody requires calculation
 
      if (homogstate(material_homogenizationat(e))%sizeState > 0) &
          homogstate(material_homogenizationat(e))%subState0(:,material_homogenizationmemberat(i,e)) = &
          homogstate(material_homogenizationat(e))%State0(   :,material_homogenizationmemberat(i,e))        ! ...internal homogenization state
 
      if (thermalstate(material_homogenizationat(e))%sizeState > 0) &
          thermalstate(material_homogenizationat(e))%subState0(:,material_homogenizationmemberat(i,e)) = &
          thermalstate(material_homogenizationat(e))%State0(   :,material_homogenizationmemberat(i,e))      ! ...internal thermal state
 
      if (damagestate(material_homogenizationat(e))%sizeState > 0) &
          damagestate(material_homogenizationat(e))%subState0(:,material_homogenizationmemberat(i,e)) = &
          damagestate(material_homogenizationat(e))%State0(   :,material_homogenizationmemberat(i,e))       ! ...internal damage state
    enddo
  enddo
 
  niterationhomog = 0
 
  cutbacklooping: do while (.not. terminallyill .and. &
       any(materialpoint_substep(:,fesolving_execelem(1):fesolving_execelem(2)) > num%subStepMinHomog))
 
    !$OMP PARALLEL DO PRIVATE(myNgrains)
    elementlooping1: do e = fesolving_execelem(1),fesolving_execelem(2)
      myngrains = homogenization_ngrains(material_homogenizationat(e))
      iplooping1: do i = fesolving_execip(1),fesolving_execip(2)
 
        converged: if (materialpoint_converged(i,e)) then
# 296 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/homogenization.f90"
 
!---------------------------------------------------------------------------------------------------
! calculate new subStep and new subFrac
          materialpoint_subfrac(i,e) = materialpoint_subfrac(i,e) + materialpoint_substep(i,e)
          materialpoint_substep(i,e) = min(1.0_preal-materialpoint_subfrac(i,e), &
                                           num%stepIncreaseHomog*materialpoint_substep(i,e))        ! introduce flexibility for step increase/acceleration
 
          steppingneeded: if (materialpoint_substep(i,e) > num%subStepMinHomog) then
 
            ! wind forward grain starting point of...
            crystallite_partionedf0(1:3,1:3,1:myngrains,i,e) =  &
               crystallite_partionedf(1:3,1:3,1:myngrains,i,e)
 
            crystallite_partionedfp0(1:3,1:3,1:myngrains,i,e) = &
              crystallite_fp(1:3,1:3,1:myngrains,i,e)
 
            crystallite_partionedlp0(1:3,1:3,1:myngrains,i,e) = &
              crystallite_lp(1:3,1:3,1:myngrains,i,e)
 
            crystallite_partionedfi0(1:3,1:3,1:myngrains,i,e) = &
              crystallite_fi(1:3,1:3,1:myngrains,i,e)
 
            crystallite_partionedli0(1:3,1:3,1:myngrains,i,e) = &
              crystallite_li(1:3,1:3,1:myngrains,i,e)
 
            crystallite_partioneds0(1:3,1:3,1:myngrains,i,e) = &
              crystallite_s(1:3,1:3,1:myngrains,i,e)
 
            do g = 1,myngrains
              plasticstate(material_phaseat(g,e))%partionedState0(:,material_phasememberat(g,i,e)) = &
              plasticstate(material_phaseat(g,e))%state          (:,material_phasememberat(g,i,e))
              do mysource = 1, phase_nsources(material_phaseat(g,e))
                sourcestate(material_phaseat(g,e))%p(mysource)%partionedState0(:,material_phasememberat(g,i,e)) = &
                sourcestate(material_phaseat(g,e))%p(mysource)%state          (:,material_phasememberat(g,i,e))
              enddo
            enddo
 
            if(homogstate(material_homogenizationat(e))%sizeState > 0) &
                homogstate(material_homogenizationat(e))%subState0(:,material_homogenizationmemberat(i,e)) = &
                homogstate(material_homogenizationat(e))%State    (:,material_homogenizationmemberat(i,e))
            if(thermalstate(material_homogenizationat(e))%sizeState > 0) &
                thermalstate(material_homogenizationat(e))%subState0(:,material_homogenizationmemberat(i,e)) = &
                thermalstate(material_homogenizationat(e))%State    (:,material_homogenizationmemberat(i,e))
            if(damagestate(material_homogenizationat(e))%sizeState > 0) &
                damagestate(material_homogenizationat(e))%subState0(:,material_homogenizationmemberat(i,e)) = &
                damagestate(material_homogenizationat(e))%State    (:,material_homogenizationmemberat(i,e))
 
            materialpoint_subf0(1:3,1:3,i,e) = materialpoint_subf(1:3,1:3,i,e)
 
          endif steppingneeded
 
        else converged
          if ( (myngrains == 1 .and. materialpoint_substep(i,e) <= 1.0 ) .or. &                     ! single grain already tried internal subStepping in crystallite
               num%subStepSizeHomog * materialpoint_substep(i,e) <=  num%subStepMinHomog ) then     ! would require too small subStep
                                                                                                    ! cutback makes no sense
            !$OMP FLUSH(terminallyIll)
            if (.not. terminallyill) then                                                           ! so first signals terminally ill...
              !$OMP CRITICAL (write2out)
              write(6,*) 'Integration point ', i,' at element ', e, ' terminally ill'
              !$OMP END CRITICAL (write2out)
            endif
            terminallyill = .true.                                                                  ! ...and kills all others
          else                                                                                      ! cutback makes sense
            materialpoint_substep(i,e) = num%subStepSizeHomog * materialpoint_substep(i,e)          ! crystallite had severe trouble, so do a significant cutback
 
# 370 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/homogenization.f90"
 
!--------------------------------------------------------------------------------------------------
! restore...
            if (materialpoint_substep(i,e) < 1.0_preal) then                                        ! protect against fake cutback from \Delta t = 2 to 1. Maybe that "trick" is not necessary anymore at all? I.e. start with \Delta t = 1
              crystallite_lp(1:3,1:3,1:myngrains,i,e) = &
                crystallite_partionedlp0(1:3,1:3,1:myngrains,i,e)
              crystallite_li(1:3,1:3,1:myngrains,i,e) = &
                crystallite_partionedli0(1:3,1:3,1:myngrains,i,e)
            endif                                                                                   ! maybe protecting everything from overwriting (not only L) makes even more sense
            crystallite_fp(1:3,1:3,1:myngrains,i,e) = &
              crystallite_partionedfp0(1:3,1:3,1:myngrains,i,e)
            crystallite_fi(1:3,1:3,1:myngrains,i,e) = &
              crystallite_partionedfi0(1:3,1:3,1:myngrains,i,e)
            crystallite_s(1:3,1:3,1:myngrains,i,e) = &
               crystallite_partioneds0(1:3,1:3,1:myngrains,i,e)
            do g = 1, myngrains
              plasticstate(material_phaseat(g,e))%state(          :,material_phasememberat(g,i,e)) = &
              plasticstate(material_phaseat(g,e))%partionedState0(:,material_phasememberat(g,i,e))
              do mysource = 1, phase_nsources(material_phaseat(g,e))
                sourcestate(material_phaseat(g,e))%p(mysource)%state(          :,material_phasememberat(g,i,e)) = &
                sourcestate(material_phaseat(g,e))%p(mysource)%partionedState0(:,material_phasememberat(g,i,e))
              enddo
            enddo
            if(homogstate(material_homogenizationat(e))%sizeState > 0) &
                homogstate(material_homogenizationat(e))%State(    :,material_homogenizationmemberat(i,e)) = &
                homogstate(material_homogenizationat(e))%subState0(:,material_homogenizationmemberat(i,e))
            if(thermalstate(material_homogenizationat(e))%sizeState > 0) &
                thermalstate(material_homogenizationat(e))%State(    :,material_homogenizationmemberat(i,e)) = &
                thermalstate(material_homogenizationat(e))%subState0(:,material_homogenizationmemberat(i,e))
            if(damagestate(material_homogenizationat(e))%sizeState > 0) &
                damagestate(material_homogenizationat(e))%State(    :,material_homogenizationmemberat(i,e)) = &
                damagestate(material_homogenizationat(e))%subState0(:,material_homogenizationmemberat(i,e))
          endif
        endif converged
 
        if (materialpoint_substep(i,e) > num%subStepMinHomog) then
          materialpoint_requested(i,e) = .true.
          materialpoint_subf(1:3,1:3,i,e) = materialpoint_subf0(1:3,1:3,i,e) &
                                          + materialpoint_substep(i,e) * (materialpoint_f(1:3,1:3,i,e) &
                                          - materialpoint_f0(1:3,1:3,i,e))
          materialpoint_subdt(i,e) = materialpoint_substep(i,e) * dt
          materialpoint_doneandhappy(1:2,i,e) = [.false.,.true.]
        endif
      enddo iplooping1
    enddo elementlooping1
    !$OMP END PARALLEL DO
 
    niterationmpstate = 0
 
    convergencelooping: do while (.not. terminallyill .and. &
              any(            materialpoint_requested(:,fesolving_execelem(1):fesolving_execelem(2)) &
                  .and. .not. materialpoint_doneandhappy(1,:,fesolving_execelem(1):fesolving_execelem(2)) &
                 ) .and. &
              niterationmpstate < num%nMPstate)
      niterationmpstate = niterationmpstate + 1
 
!--------------------------------------------------------------------------------------------------
! deformation partitioning
! based on materialpoint_subF0,.._subF,crystallite_partionedF0, and homogenization_state,
! results in crystallite_partionedF
      !$OMP PARALLEL DO PRIVATE(myNgrains)
      elementlooping2: do e = fesolving_execelem(1),fesolving_execelem(2)
        myngrains = homogenization_ngrains(material_homogenizationat(e))
        iplooping2: do i = fesolving_execip(1),fesolving_execip(2)
          if (      materialpoint_requested(i,e) .and. &                                            ! process requested but...
              .not. materialpoint_doneandhappy(1,i,e)) then                                         ! ...not yet done material points
            call partitiondeformation(i,e)                                                          ! partition deformation onto constituents
            crystallite_dt(1:myngrains,i,e) = materialpoint_subdt(i,e)                              ! propagate materialpoint dt to grains
            crystallite_requested(1:myngrains,i,e) = .true.                                         ! request calculation for constituents
          else
            crystallite_requested(1:myngrains,i,e) = .false.                                        ! calculation for constituents not required anymore
          endif
        enddo iplooping2
      enddo elementlooping2
      !$OMP END PARALLEL DO
 
!--------------------------------------------------------------------------------------------------
! crystallite integration
! based on crystallite_partionedF0,.._partionedF
! incrementing by crystallite_dt
 
      materialpoint_converged = crystallite_stress() !ToDo: MD not sure if that is the best logic
 
!--------------------------------------------------------------------------------------------------
! state update
     !$OMP PARALLEL DO
      elementlooping3: do e = fesolving_execelem(1),fesolving_execelem(2)
        iplooping3: do i = fesolving_execip(1),fesolving_execip(2)
          if (      materialpoint_requested(i,e) .and. &
              .not. materialpoint_doneandhappy(1,i,e)) then
            if (.not. materialpoint_converged(i,e)) then
              materialpoint_doneandhappy(1:2,i,e) = [.true.,.false.]
            else
              materialpoint_doneandhappy(1:2,i,e) = updatestate(i,e)
              materialpoint_converged(i,e) = all(materialpoint_doneandhappy(1:2,i,e))               ! converged if done and happy
            endif
          endif
        enddo iplooping3
      enddo elementlooping3
      !$OMP END PARALLEL DO
 
    enddo convergencelooping
 
    niterationhomog = niterationhomog + 1
 
  enddo cutbacklooping
 
  if(updatejaco) call crystallite_stresstangent
 
  if (.not. terminallyill ) then
    call crystallite_orientations()                                                                 ! calculate crystal orientations
    !$OMP PARALLEL DO
    elementlooping4: do e = fesolving_execelem(1),fesolving_execelem(2)
      iplooping4: do i = fesolving_execip(1),fesolving_execip(2)
        call averagestressanditstangent(i,e)
      enddo iplooping4
    enddo elementlooping4
    !$OMP END PARALLEL DO
  else
    write(6,'(/,a,/)') '<< HOMOG >> Material Point terminally ill'
  endif
 
end subroutine materialpoint_stressanditstangent
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine partitiondeformation(ip,el)
 
 integer, intent(in) :: &
   ip, &                                                                                            !< integration point
   el
 
 chosenhomogenization: select case(homogenization_type(material_homogenizationat(el)))
 
   case (homogenization_none_id) chosenhomogenization
     crystallite_partionedf(1:3,1:3,1,ip,el) = materialpoint_subf(1:3,1:3,ip,el)
 
   case (homogenization_isostrain_id) chosenhomogenization
     call mech_isostrain_partitiondeformation(&
                          crystallite_partionedf(1:3,1:3,1:homogenization_ngrains(material_homogenizationat(el)),ip,el), &
                          materialpoint_subf(1:3,1:3,ip,el))
 
   case (homogenization_rgc_id) chosenhomogenization
     call mech_rgc_partitiondeformation(&
                         crystallite_partionedf(1:3,1:3,1:homogenization_ngrains(material_homogenizationat(el)),ip,el), &
                         materialpoint_subf(1:3,1:3,ip,el),&
                         ip, &
                         el)
 end select chosenhomogenization
 
end subroutine partitiondeformation
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function updatestate(ip,el)
 
 integer, intent(in) :: &
   ip, &                                                                                            !< integration point
   el
 logical, dimension(2) :: updateState
 
 updatestate = .true.
 chosenhomogenization: select case(homogenization_type(material_homogenizationat(el)))
   case (homogenization_rgc_id) chosenhomogenization
     updatestate = &
       updatestate .and. &
        mech_rgc_updatestate(crystallite_p(1:3,1:3,1:homogenization_ngrains(material_homogenizationat(el)),ip,el), &
                             crystallite_partionedf(1:3,1:3,1:homogenization_ngrains(material_homogenizationat(el)),ip,el), &
                             crystallite_partionedf0(1:3,1:3,1:homogenization_ngrains(material_homogenizationat(el)),ip,el),&
                             materialpoint_subf(1:3,1:3,ip,el),&
                             materialpoint_subdt(ip,el), &
                             crystallite_dpdf(1:3,1:3,1:3,1:3,1:homogenization_ngrains(material_homogenizationat(el)),ip,el), &
                             ip, &
                             el)
 end select chosenhomogenization
 
 chosenthermal: select case (thermal_type(material_homogenizationat(el)))
   case (thermal_adiabatic_id) chosenthermal
     updatestate = &
       updatestate .and. &
       thermal_adiabatic_updatestate(materialpoint_subdt(ip,el), &
                                     ip, &
                                     el)
 end select chosenthermal
 
 chosendamage: select case (damage_type(material_homogenizationat(el)))
   case (damage_local_id) chosendamage
     updatestate = &
       updatestate .and. &
       damage_local_updatestate(materialpoint_subdt(ip,el), &
                                ip, &
                                el)
 end select chosendamage
 
end function updatestate
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine averagestressanditstangent(ip,el)
 
 integer, intent(in) :: &
   ip, &                                                                                            !< integration point
   el
 
 chosenhomogenization: select case(homogenization_type(material_homogenizationat(el)))
   case (homogenization_none_id) chosenhomogenization
       materialpoint_p(1:3,1:3,ip,el)            = crystallite_p(1:3,1:3,1,ip,el)
       materialpoint_dpdf(1:3,1:3,1:3,1:3,ip,el) = crystallite_dpdf(1:3,1:3,1:3,1:3,1,ip,el)
 
   case (homogenization_isostrain_id) chosenhomogenization
     call mech_isostrain_averagestressanditstangent(&
       materialpoint_p(1:3,1:3,ip,el), &
       materialpoint_dpdf(1:3,1:3,1:3,1:3,ip,el),&
       crystallite_p(1:3,1:3,1:homogenization_ngrains(material_homogenizationat(el)),ip,el), &
       crystallite_dpdf(1:3,1:3,1:3,1:3,1:homogenization_ngrains(material_homogenizationat(el)),ip,el), &
       homogenization_typeinstance(material_homogenizationat(el)))
 
   case (homogenization_rgc_id) chosenhomogenization
     call mech_rgc_averagestressanditstangent(&
       materialpoint_p(1:3,1:3,ip,el), &
       materialpoint_dpdf(1:3,1:3,1:3,1:3,ip,el),&
       crystallite_p(1:3,1:3,1:homogenization_ngrains(material_homogenizationat(el)),ip,el), &
       crystallite_dpdf(1:3,1:3,1:3,1:3,1:homogenization_ngrains(material_homogenizationat(el)),ip,el), &
       homogenization_typeinstance(material_homogenizationat(el)))
 end select chosenhomogenization
 
end subroutine averagestressanditstangent
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine homogenization_results
  use material, only: &
    material_homogenization_type => homogenization_type
 
  integer :: p
  character(len=pStringLen) :: group_base,group
 
  !real(pReal), dimension(:,:,:), allocatable :: temp
 
  do p=1,size(config_name_homogenization)
    group_base = 'current/materialpoint/'//trim(config_name_homogenization(p))
    call results_closegroup(results_addgroup(group_base))
 
    group = trim(group_base)//'/generic'
    call results_closegroup(results_addgroup(group))
    !temp = reshape(materialpoint_F,[3,3,discretization_nIP*discretization_nElem])
    !call results_writeDataset(group,temp,'F',&
    !                          'deformation gradient','1')
    !temp = reshape(materialpoint_P,[3,3,discretization_nIP*discretization_nElem])
    !call results_writeDataset(group,temp,'P',&
    !                          '1st Piola-Kirchoff stress','Pa')
 
    group = trim(group_base)//'/mech'
    call results_closegroup(results_addgroup(group))
    select case(material_homogenization_type(p))
      case(homogenization_rgc_id)
        call mech_rgc_results(homogenization_typeinstance(p),group)
    end select
 
    group = trim(group_base)//'/damage'
    call results_closegroup(results_addgroup(group))
    select case(damage_type(p))
      case(damage_local_id)
        call damage_local_results(p,group)
      case(damage_nonlocal_id)
        call damage_nonlocal_results(p,group)
    end select
 
    group = trim(group_base)//'/thermal'
    call results_closegroup(results_addgroup(group))
    select case(thermal_type(p))
      case(thermal_adiabatic_id)
        call thermal_adiabatic_results(p,group)
      case(thermal_conduction_id)
        call thermal_conduction_results(p,group)
    end select
 
 enddo
 
end subroutine homogenization_results
 
end module homogenization
# 52 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/homogenization_mech_none.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
submodule(homogenization) homogenization_mech_none
 
contains
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine mech_none_init
 
  integer :: &
    ninstance, &
    h, &
    nofmyhomog
 
  write(6,'(/,a)') ' <<<+-  homogenization_'//homogenization_none_label//' init  -+>>>'; flush(6)
 
  ninstance = count(homogenization_type == homogenization_none_id)
  if (iand(debug_level(debug_homogenization),debug_levelbasic) /= 0) &
    write(6,'(a16,1x,i5,/)') '# instances:',ninstance
 
  do h = 1, size(homogenization_type)
    if (homogenization_type(h) /= homogenization_none_id) cycle
    
    nofmyhomog = count(material_homogenizationat == h)
    homogstate(h)%sizeState = 0
    allocate(homogstate(h)%state0   (0,nofmyhomog))
    allocate(homogstate(h)%subState0(0,nofmyhomog))
    allocate(homogstate(h)%state    (0,nofmyhomog))
 
  enddo
 
end subroutine mech_none_init
 
end submodule homogenization_mech_none
# 53 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/homogenization_mech_isostrain.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
submodule(homogenization) homogenization_mech_isostrain
 
  enum, bind(c); enumerator :: &
    parallel_id, &
    average_id
  end enum
 
  type :: tparameters                                                                               
    integer :: &
      nconstituents
    integer(kind(average_ID)) :: &
      mapping
  end type
 
  type(tparameters), dimension(:), allocatable :: param
  
 
contains
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine mech_isostrain_init
 
  integer :: &
    ninstance, &
    h, &
    nofmyhomog
  character(len=pStringLen) :: &
    tag  = ''
 
  write(6,'(/,a)')   ' <<<+-  homogenization_'//homogenization_isostrain_label//' init  -+>>>'
 
  ninstance = count(homogenization_type == homogenization_isostrain_id)
  if (iand(debug_level(debug_homogenization),debug_levelbasic) /= 0) &
    write(6,'(a16,1x,i5,/)') '# instances:',ninstance
 
  allocate(param(ninstance))                                                                        ! one container of parameters per instance
 
  do h = 1, size(homogenization_type)
    if (homogenization_type(h) /= homogenization_isostrain_id) cycle
    
    associate(prm => param(homogenization_typeinstance(h)),&
              config => config_homogenization(h))
   
    prm%Nconstituents = config_homogenization(h)%getInt('nconstituents')
    tag = 'sum'
    select case(trim(config%getString('mapping',defaultval = tag)))
      case ('sum')
        prm%mapping = parallel_id
      case ('avg')
        prm%mapping = average_id
      case default
        call io_error(211,ext_msg=trim(tag)//' ('//homogenization_isostrain_label//')')
    end select
 
    nofmyhomog = count(material_homogenizationat == h)
    homogstate(h)%sizeState       = 0
    allocate(homogstate(h)%state0   (0,nofmyhomog))
    allocate(homogstate(h)%subState0(0,nofmyhomog))
    allocate(homogstate(h)%state    (0,nofmyhomog))
    
    end associate
 
  enddo
 
end subroutine mech_isostrain_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine mech_isostrain_partitiondeformation(f,avgf)
  
  real(preal),   dimension (:,:,:), intent(out) :: f
  
  real(preal),   dimension (3,3),   intent(in)  :: avgf
 
  f = spread(avgf,3,size(f,3))
 
end subroutine mech_isostrain_partitiondeformation
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine mech_isostrain_averagestressanditstangent(avgp,davgpdavgf,p,dpdf,instance)
   
  real(preal),   dimension (3,3),       intent(out) :: avgp
  real(preal),   dimension (3,3,3,3),   intent(out) :: davgpdavgf
 
  real(preal),   dimension (:,:,:),     intent(in)  :: p
  real(preal),   dimension (:,:,:,:,:), intent(in)  :: dpdf
  integer,                              intent(in)  :: instance 
   
  associate(prm => param(instance))
  
  select case (prm%mapping)
    case (parallel_id)
      avgp       = sum(p,3)
      davgpdavgf = sum(dpdf,5)
    case (average_id)
      avgp       = sum(p,3)   /real(prm%Nconstituents,preal)
      davgpdavgf = sum(dpdf,5)/real(prm%Nconstituents,preal)
  end select
  
  end associate
 
end subroutine mech_isostrain_averagestressanditstangent
 
end submodule homogenization_mech_isostrain
# 54 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/homogenization_mech_RGC.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
submodule(homogenization) homogenization_mech_rgc
  use rotations
 
  type :: tparameters
    integer, dimension(:), allocatable :: &
      nconstituents
    real(preal) :: &
      xialpha, &
      cialpha
    real(preal), dimension(:), allocatable :: &
      dalpha, &
      angles
    integer :: &
      of_debug = 0
    character(len=pStringLen), allocatable, dimension(:) :: &
      output
  end type tparameters
 
  type :: trgcstate
    real(preal), pointer,     dimension(:) :: &
      work, &
      penaltyenergy
    real(preal), pointer,     dimension(:,:) :: &
      relaxationvector
  end type trgcstate
 
  type :: trgcdependentstate
    real(preal), allocatable,     dimension(:) :: &
      volumediscrepancy, &
      relaxationrate_avg, &
      relaxationrate_max
    real(preal), allocatable,     dimension(:,:) :: &
      mismatch
    real(preal), allocatable,     dimension(:,:,:) :: &
      orientation
  end type trgcdependentstate
 
  type :: tnumerics_rgc
    real(preal) :: &
     atol, &                                                                                        !< absolute tolerance of RGC residuum
     rtol, &                                                                                        !< relative tolerance of RGC residuum
     absmax, &                                                                                      !< absolute maximum of RGC residuum
     relmax, &                                                                                      !< relative maximum of RGC residuum
     ppert, &                                                                                       !< perturbation for computing RGC penalty tangent
     xsmoo, &                                                                                       !< RGC penalty smoothing parameter (hyperbolic tangent)
     viscpower, &                                                                                   !< power (sensitivity rate) of numerical viscosity in RGC scheme, Default 1.0e0: Newton viscosity (linear model)
     viscmodus, &                                                                                   !< stress modulus of RGC numerical viscosity, Default 0.0e0: No viscosity is applied
     refrelaxrate, &                                                                                !< reference relaxation rate in RGC viscosity
     maxdrelax, &                                                                                   !< threshold of maximum relaxation vector increment (if exceed this then cutback)
     maxvoldiscr, &                                                                                 !< threshold of maximum volume discrepancy allowed
     voldiscrmod, &                                                                                 !< stiffness of RGC volume discrepancy (zero = without volume discrepancy constraint)
     voldiscrpow
  end type tnumerics_rgc
 
  type(tparameters),          dimension(:), allocatable :: &
    param
  type(trgcstate),            dimension(:), allocatable :: &
    state, &
    state0
  type(trgcdependentstate),   dimension(:), allocatable :: &
    dependentstate
  type(tnumerics_rgc) :: &
    num                                                                                             ! numerics parameters. Better name?
 
contains
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine mech_rgc_init
 
  integer :: &
    ninstance, &
    h, &
    nofmyhomog, &
    sizestate, nintfacetot
 
  write(6,'(/,a)') ' <<<+-  homogenization_'//homogenization_rgc_label//' init  -+>>>'; flush(6)
 
  write(6,'(/,a)') ' Tjahjanto et al., International Journal of Material Forming 2(1):939–942, 2009'
  write(6,'(a)')   ' https://doi.org/10.1007/s12289-009-0619-1'
 
  write(6,'(/,a)') ' Tjahjanto et al., Modelling and Simulation in Materials Science and Engineering 18:015006, 2010'
  write(6,'(a)')   ' https://doi.org/10.1088/0965-0393/18/1/015006'
 
  ninstance = count(homogenization_type == homogenization_rgc_id)
  if (iand(debug_level(debug_homogenization),debug_levelbasic) /= 0) &
    write(6,'(a16,1x,i5,/)') '# instances:',ninstance
 
  allocate(param(ninstance))
  allocate(state(ninstance))
  allocate(state0(ninstance))
  allocate(dependentstate(ninstance))
 
  num%atol         =  config_numerics%getFloat('atol_rgc',             defaultval=1.0e+4_preal)
  num%rtol         =  config_numerics%getFloat('rtol_rgc',             defaultval=1.0e-3_preal)
  num%absMax       =  config_numerics%getFloat('amax_rgc',             defaultval=1.0e+10_preal)
  num%relMax       =  config_numerics%getFloat('rmax_rgc',             defaultval=1.0e+2_preal)
  num%pPert        =  config_numerics%getFloat('perturbpenalty_rgc',   defaultval=1.0e-7_preal)
  num%xSmoo        =  config_numerics%getFloat('relvantmismatch_rgc',  defaultval=1.0e-5_preal)
  num%viscPower    =  config_numerics%getFloat('viscositypower_rgc',   defaultval=1.0e+0_preal)
  num%viscModus    =  config_numerics%getFloat('viscositymodulus_rgc', defaultval=0.0e+0_preal)
  num%refRelaxRate =  config_numerics%getFloat('refrelaxationrate_rgc',defaultval=1.0e-3_preal)
  num%maxdRelax    =  config_numerics%getFloat('maxrelaxationrate_rgc',defaultval=1.0e+0_preal)
  num%maxVolDiscr  =  config_numerics%getFloat('maxvoldiscrepancy_rgc',defaultval=1.0e-5_preal)
  num%volDiscrMod  =  config_numerics%getFloat('voldiscrepancymod_rgc',defaultval=1.0e+12_preal)
  num%volDiscrPow  =  config_numerics%getFloat('dicrepancypower_rgc',  defaultval=5.0_preal)
 
  if (num%atol <= 0.0_preal)         call io_error(301,ext_msg='absTol_RGC')
  if (num%rtol <= 0.0_preal)         call io_error(301,ext_msg='relTol_RGC')
  if (num%absMax <= 0.0_preal)       call io_error(301,ext_msg='absMax_RGC')
  if (num%relMax <= 0.0_preal)       call io_error(301,ext_msg='relMax_RGC')
  if (num%pPert <= 0.0_preal)        call io_error(301,ext_msg='pPert_RGC')
  if (num%xSmoo <= 0.0_preal)        call io_error(301,ext_msg='xSmoo_RGC')
  if (num%viscPower < 0.0_preal)     call io_error(301,ext_msg='viscPower_RGC')
  if (num%viscModus < 0.0_preal)     call io_error(301,ext_msg='viscModus_RGC')
  if (num%refRelaxRate <= 0.0_preal) call io_error(301,ext_msg='refRelaxRate_RGC')
  if (num%maxdRelax <= 0.0_preal)    call io_error(301,ext_msg='maxdRelax_RGC')
  if (num%maxVolDiscr <= 0.0_preal)  call io_error(301,ext_msg='maxVolDiscr_RGC')
  if (num%volDiscrMod < 0.0_preal)   call io_error(301,ext_msg='volDiscrMod_RGC')
  if (num%volDiscrPow <= 0.0_preal)  call io_error(301,ext_msg='volDiscrPw_RGC')
 
  do h = 1, size(homogenization_type)
    if (homogenization_type(h) /= homogenization_rgc_id) cycle
    associate(prm => param(homogenization_typeinstance(h)), &
              stt => state(homogenization_typeinstance(h)), &
              st0 => state0(homogenization_typeinstance(h)), &
              dst => dependentstate(homogenization_typeinstance(h)), &
              config => config_homogenization(h))
 
 
 
 
 
 
 
    prm%output = config%getStrings('(output)',defaultval=emptystringarray)
 
    prm%Nconstituents = config%getInts('clustersize',requiredsize=3)
    if (homogenization_ngrains(h) /= product(prm%Nconstituents)) &
      call io_error(211,ext_msg='clustersize ('//homogenization_rgc_label//')')
 
    prm%xiAlpha = config%getFloat('scalingparameter')
    prm%ciAlpha = config%getFloat('overproportionality')
 
    prm%dAlpha  = config%getFloats('grainsize',         requiredsize=3)
    prm%angles  = config%getFloats('clusterorientation',requiredsize=3)
 
    nofmyhomog = count(material_homogenizationat == h)
    nintfacetot = 3*(  (prm%Nconstituents(1)-1)*prm%Nconstituents(2)*prm%Nconstituents(3) &
                      + prm%Nconstituents(1)*(prm%Nconstituents(2)-1)*prm%Nconstituents(3) &
                      + prm%Nconstituents(1)*prm%Nconstituents(2)*(prm%Nconstituents(3)-1))
    sizestate = nintfacetot &
              + size(['avg constitutive work ','average penalty energy'])
 
    homogstate(h)%sizeState = sizestate
    allocate(homogstate(h)%state0   (sizestate,nofmyhomog), source=0.0_preal)
    allocate(homogstate(h)%subState0(sizestate,nofmyhomog), source=0.0_preal)
    allocate(homogstate(h)%state    (sizestate,nofmyhomog), source=0.0_preal)
 
    stt%relaxationVector   => homogstate(h)%state(1:nintfacetot,:)
    st0%relaxationVector   => homogstate(h)%state0(1:nintfacetot,:)
    stt%work               => homogstate(h)%state(nintfacetot+1,:)
    stt%penaltyEnergy      => homogstate(h)%state(nintfacetot+2,:)
 
    allocate(dst%volumeDiscrepancy(   nofmyhomog))
    allocate(dst%relaxationRate_avg(  nofmyhomog))
    allocate(dst%relaxationRate_max(  nofmyhomog))
    allocate(dst%mismatch(          3,nofmyhomog))
 
!--------------------------------------------------------------------------------------------------
! assigning cluster orientations
    dependentstate(homogenization_typeinstance(h))%orientation = spread(eu2om(prm%angles*inrad),3,nofmyhomog)
    !dst%orientation = spread(eu2om(prm%angles*inRad),3,NofMyHomog) ifort version 18.0.1 crashes (for whatever reason)
 
    end associate
 
  enddo
 
end subroutine mech_rgc_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine mech_rgc_partitiondeformation(f,avgf,instance,of)
 
  real(preal),   dimension (:,:,:), intent(out) :: f
 
  real(preal),   dimension (3,3),   intent(in)  :: avgf
  integer,                          intent(in)  :: &
    instance, &
    of
 
  real(preal), dimension(3) :: avect,nvect
  integer,     dimension(4) :: intface
  integer,     dimension(3) :: igrain3
  integer ::  igrain,iface,i,j
 
  associate(prm => param(instance))
 
!--------------------------------------------------------------------------------------------------
! compute the deformation gradient of individual grains due to relaxations
  f = 0.0_preal
  do igrain = 1,product(prm%Nconstituents)
    igrain3 = grain1to3(igrain,prm%Nconstituents)
    do iface = 1,6
      intface = getinterface(iface,igrain3)                                                         ! identifying 6 interfaces of each grain
      avect = relaxationvector(intface,instance,of)                                                 ! get the relaxation vectors for each interface from global relaxation vector array
      nvect = interfacenormal(intface,instance,of)
      forall (i=1:3,j=1:3) &
        f(i,j,igrain) = f(i,j,igrain) + avect(i)*nvect(j)                                           ! calculating deformation relaxations due to interface relaxation
    enddo
    f(1:3,1:3,igrain) = f(1:3,1:3,igrain) + avgf                                                    ! resulting relaxed deformation gradient
 
# 234 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/homogenization_mech_RGC.f90"
  enddo
 
  end associate
 
end subroutine mech_rgc_partitiondeformation
 
 
!--------------------------------------------------------------------------------------------------
! "happy" with result
!--------------------------------------------------------------------------------------------------
module procedure mech_rgc_updatestate
 
  integer, dimension(4) :: intfacen,intfacep,faceid
  integer, dimension(3) :: ngdim,igr3n,igr3p
  integer :: instance,inum,i,j,nintfacetot,igrn,igrp,imun,iface,k,l,ipert,igrain,ngrain, of
  real(preal), dimension(3,3,size(P,3)) :: r,pf,pr,d,pd
  real(preal), dimension(3,size(P,3))   :: nn,devnull
  real(preal), dimension(3)             :: normp,normn,mornp,mornn
  real(preal) :: residmax,stresmax
  logical :: error
  real(preal), dimension(:,:), allocatable :: tract,jmatrix,jnverse,smatrix,pmatrix,rmatrix
  real(preal), dimension(:), allocatable   :: resid,relax,p_relax,p_resid,drelax
 
 
 
 
 
  zerotimestep: if(deq0(dt)) then
    mech_rgc_updatestate = .true.                                                                   ! pretend everything is fine and return
    return
  endif zerotimestep
 
  instance  = homogenization_typeinstance(material_homogenizationat(el))
  of = material_homogenizationmemberat(ip,el)
 
  associate(stt => state(instance), st0 => state0(instance), dst => dependentstate(instance), prm => param(instance))
 
!--------------------------------------------------------------------------------------------------
! get the dimension of the cluster (grains and interfaces)
  ngdim  = prm%Nconstituents
  ngrain = product(ngdim)
  nintfacetot = (ngdim(1)-1)*ngdim(2)*ngdim(3) &
              + ngdim(1)*(ngdim(2)-1)*ngdim(3) &
              + ngdim(1)*ngdim(2)*(ngdim(3)-1)
 
!--------------------------------------------------------------------------------------------------
! allocate the size of the global relaxation arrays/jacobian matrices depending on the size of the cluster
  allocate(resid(3*nintfacetot),   source=0.0_preal)
  allocate(tract(nintfacetot,3),        source=0.0_preal)
  relax  = stt%relaxationVector(:,of)
  drelax = stt%relaxationVector(:,of) - st0%relaxationVector(:,of)
 
# 296 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/homogenization_mech_RGC.f90"
 
!--------------------------------------------------------------------------------------------------
! computing interface mismatch and stress penalty tensor for all interfaces of all grains
  call stresspenalty(r,nn,avgf,f,ip,el,instance,of)
 
!--------------------------------------------------------------------------------------------------
! calculating volume discrepancy and stress penalty related to overall volume discrepancy
  call volumepenalty(d,dst%volumeDiscrepancy(of),avgf,f,ngrain,instance,of)
 
# 320 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/homogenization_mech_RGC.f90"
 
!------------------------------------------------------------------------------------------------
! computing the residual stress from the balance of traction at all (interior) interfaces
  do inum = 1,nintfacetot
    faceid = interface1to4(inum,param(instance)%Nconstituents)                                      ! identifying the interface ID in local coordinate system (4-dimensional index)
 
!--------------------------------------------------------------------------------------------------
! identify the left/bottom/back grain (-|N)
    igr3n = faceid(2:4)                                                                             ! identifying the grain ID in local coordinate system (3-dimensional index)
    igrn = grain3to1(igr3n,param(instance)%Nconstituents)                                           ! translate the local grain ID into global coordinate system (1-dimensional index)
    intfacen = getinterface(2*faceid(1),igr3n)
    normn = interfacenormal(intfacen,instance,of)
 
!--------------------------------------------------------------------------------------------------
! identify the right/up/front grain (+|P)
    igr3p = igr3n
    igr3p(faceid(1)) = igr3n(faceid(1))+1                                                           ! identifying the grain ID in local coordinate system (3-dimensional index)
    igrp = grain3to1(igr3p,param(instance)%Nconstituents)                                           ! translate the local grain ID into global coordinate system (1-dimensional index)
    intfacep = getinterface(2*faceid(1)-1,igr3p)
    normp = interfacenormal(intfacep,instance,of)
 
!--------------------------------------------------------------------------------------------------
! compute the residual of traction at the interface (in local system, 4-dimensional index)
    do i = 1,3
      tract(inum,i) = sign(num%viscModus*(abs(drelax(i+3*(inum-1)))/(num%refRelaxRate*dt))**num%viscPower, &
                           drelax(i+3*(inum-1)))                                                    ! contribution from the relaxation viscosity
      do j = 1,3
        tract(inum,i) = tract(inum,i) + (p(i,j,igrp) + r(i,j,igrp) + d(i,j,igrp))*normp(j) &        ! contribution from material stress P, mismatch penalty R, and volume penalty D projected into the interface
                                      + (p(i,j,igrn) + r(i,j,igrn) + d(i,j,igrn))*normn(j)
        resid(i+3*(inum-1)) = tract(inum,i)                                                         ! translate the local residual into global 1-dimensional residual array
      enddo
    enddo
 
 
 
 
 
 
 
 
  enddo
 
!--------------------------------------------------------------------------------------------------
! convergence check for stress residual
  stresmax = maxval(abs(p))                                                                         ! get the maximum of first Piola-Kirchhoff (material) stress
  residmax = maxval(abs(tract))                                                                     ! get the maximum of the residual
 
# 380 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/homogenization_mech_RGC.f90"
 
  mech_rgc_updatestate = .false.
 
!--------------------------------------------------------------------------------------------------
!  If convergence reached => done and happy
  if (residmax < num%rtol*stresmax .or. residmax < num%atol) then
    mech_rgc_updatestate = .true.
 
 
 
 
 
!--------------------------------------------------------------------------------------------------
! compute/update the state for postResult, i.e., all energy densities computed by time-integration
    do igrain = 1,product(prm%Nconstituents)
      do i = 1,3;do j = 1,3
        stt%work(of)          = stt%work(of) &
                              + p(i,j,igrain)*(f(i,j,igrain) - f0(i,j,igrain))/real(ngrain,preal)
        stt%penaltyEnergy(of) = stt%penaltyEnergy(of) &
                              + r(i,j,igrain)*(f(i,j,igrain) - f0(i,j,igrain))/real(ngrain,preal)
      enddo; enddo
    enddo
 
    dst%mismatch(1:3,of)       = sum(nn,2)/real(ngrain,preal)
    dst%relaxationRate_avg(of) = sum(abs(drelax))/dt/real(3*nintfacetot,preal)
    dst%relaxationRate_max(of) = maxval(abs(drelax))/dt
 
# 420 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/homogenization_mech_RGC.f90"
 
    return
 
!--------------------------------------------------------------------------------------------------
! if residual blows-up => done but unhappy
  elseif (residmax > num%relMax*stresmax .or. residmax > num%absMax) then                           ! try to restart when residual blows up exceeding maximum bound
    mech_rgc_updatestate = [.true.,.false.]                                                         ! with direct cut-back
 
 
 
 
 
 
   return
 
 else                                                                                               ! proceed with computing the Jacobian and state update
 
 
 
 
 
 endif
 
!---------------------------------------------------------------------------------------------------
! construct the global Jacobian matrix for updating the global relaxation vector array when
! convergence is not yet reached ...
 
!--------------------------------------------------------------------------------------------------
! ... of the constitutive stress tangent, assembled from dPdF or material constitutive model "smatrix"
  allocate(smatrix(3*nintfacetot,3*nintfacetot), source=0.0_preal)
  do inum = 1,nintfacetot
    faceid = interface1to4(inum,param(instance)%Nconstituents)                                      ! assembling of local dPdF into global Jacobian matrix
 
!--------------------------------------------------------------------------------------------------
! identify the left/bottom/back grain (-|N)
    igr3n = faceid(2:4)                                                                             ! identifying the grain ID in local coordinate sytem
    igrn = grain3to1(igr3n,param(instance)%Nconstituents)                                           ! translate into global grain ID
    intfacen = getinterface(2*faceid(1),igr3n)                                                      ! identifying the connecting interface in local coordinate system
    normn = interfacenormal(intfacen,instance,of)
    do iface = 1,6
      intfacen = getinterface(iface,igr3n)                                                          ! identifying all interfaces that influence relaxation of the above interface
      mornn = interfacenormal(intfacen,instance,of)
      imun = interface4to1(intfacen,param(instance)%Nconstituents)                                  ! translate the interfaces ID into local 4-dimensional index
      if (imun > 0) then                                                                            ! get the corresponding tangent
        do i=1,3; do j=1,3; do k=1,3; do l=1,3
          smatrix(3*(inum-1)+i,3*(imun-1)+j) = smatrix(3*(inum-1)+i,3*(imun-1)+j) &
                                             + dpdf(i,k,j,l,igrn)*normn(k)*mornn(l)
        enddo;enddo;enddo;enddo
! projecting the material tangent dPdF into the interface
! to obtain the Jacobian matrix contribution of dPdF
      endif
    enddo
 
!--------------------------------------------------------------------------------------------------
! identify the right/up/front grain (+|P)
    igr3p = igr3n
    igr3p(faceid(1)) = igr3n(faceid(1))+1                                                           ! identifying the grain ID in local coordinate sytem
    igrp = grain3to1(igr3p,param(instance)%Nconstituents)                                           ! translate into global grain ID
    intfacep = getinterface(2*faceid(1)-1,igr3p)                                                    ! identifying the connecting interface in local coordinate system
    normp = interfacenormal(intfacep,instance,of)
    do iface = 1,6
      intfacep = getinterface(iface,igr3p)                                                          ! identifying all interfaces that influence relaxation of the above interface
      mornp = interfacenormal(intfacep,instance,of)
      imun = interface4to1(intfacep,param(instance)%Nconstituents)                                  ! translate the interfaces ID into local 4-dimensional index
      if (imun > 0) then                                                                            ! get the corresponding tangent
        do i=1,3; do j=1,3; do k=1,3; do l=1,3
          smatrix(3*(inum-1)+i,3*(imun-1)+j) = smatrix(3*(inum-1)+i,3*(imun-1)+j) &
                                             + dpdf(i,k,j,l,igrp)*normp(k)*mornp(l)
        enddo;enddo;enddo;enddo
      endif
    enddo
  enddo
 
# 503 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/homogenization_mech_RGC.f90"
 
!--------------------------------------------------------------------------------------------------
! ... of the stress penalty tangent (mismatch penalty and volume penalty, computed using numerical
! perturbation method) "pmatrix"
  allocate(pmatrix(3*nintfacetot,3*nintfacetot), source=0.0_preal)
  allocate(p_relax(3*nintfacetot),               source=0.0_preal)
  allocate(p_resid(3*nintfacetot),               source=0.0_preal)
 
  do ipert = 1,3*nintfacetot
    p_relax = relax
    p_relax(ipert) = relax(ipert) + num%pPert                                                       ! perturb the relaxation vector
    stt%relaxationVector(:,of) = p_relax
    call graindeformation(pf,avgf,instance,of)                                                      ! rain deformation from perturbed state
    call stresspenalty(pr,devnull,      avgf,pf,ip,el,instance,of)                                  ! stress penalty due to interface mismatch from perturbed state
    call volumepenalty(pd,devnull(1,1), avgf,pf,ngrain,instance,of)                                 ! stress penalty due to volume discrepancy from perturbed state
 
!--------------------------------------------------------------------------------------------------
! computing the global stress residual array from the perturbed state
    p_resid = 0.0_preal
    do inum = 1,nintfacetot
      faceid = interface1to4(inum,param(instance)%Nconstituents)                                    ! identifying the interface ID in local coordinate system (4-dimensional index)
 
!--------------------------------------------------------------------------------------------------
! identify the left/bottom/back grain (-|N)
      igr3n = faceid(2:4)                                                                           ! identify the grain ID in local coordinate system (3-dimensional index)
      igrn = grain3to1(igr3n,param(instance)%Nconstituents)                                         ! translate the local grain ID into global coordinate system (1-dimensional index)
      intfacen = getinterface(2*faceid(1),igr3n)                                                    ! identify the interface ID of the grain
      normn = interfacenormal(intfacen,instance,of)
 
!--------------------------------------------------------------------------------------------------
! identify the right/up/front grain (+|P)
      igr3p = igr3n
      igr3p(faceid(1)) = igr3n(faceid(1))+1                                                         ! identify the grain ID in local coordinate system (3-dimensional index)
      igrp = grain3to1(igr3p,param(instance)%Nconstituents)                                         ! translate the local grain ID into global coordinate system (1-dimensional index)
      intfacep = getinterface(2*faceid(1)-1,igr3p)                                                  ! identify the interface ID of the grain
      normp = interfacenormal(intfacep,instance,of)
 
!--------------------------------------------------------------------------------------------------
! compute the residual stress (contribution of mismatch and volume penalties) from perturbed state
! at all interfaces
      do i = 1,3; do j = 1,3
        p_resid(i+3*(inum-1)) = p_resid(i+3*(inum-1)) + (pr(i,j,igrp) - r(i,j,igrp))*normp(j) &
                                                      + (pr(i,j,igrn) - r(i,j,igrn))*normn(j) &
                                                      + (pd(i,j,igrp) - d(i,j,igrp))*normp(j) &
                                                      + (pd(i,j,igrn) - d(i,j,igrn))*normn(j)
      enddo; enddo
    enddo
    pmatrix(:,ipert) = p_resid/num%pPert
  enddo
 
# 563 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/homogenization_mech_RGC.f90"
 
!--------------------------------------------------------------------------------------------------
! ... of the numerical viscosity traction "rmatrix"
  allocate(rmatrix(3*nintfacetot,3*nintfacetot),source=0.0_preal)
  do i=1,3*nintfacetot
    rmatrix(i,i) = num%viscModus*num%viscPower/(num%refRelaxRate*dt)* &                             ! tangent due to numerical viscosity traction appears
                   (abs(drelax(i))/(num%refRelaxRate*dt))**(num%viscPower - 1.0_preal)              ! only in the main diagonal term
  enddo
 
# 582 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/homogenization_mech_RGC.f90"
 
!--------------------------------------------------------------------------------------------------
! The overall Jacobian matrix summarizing contributions of smatrix, pmatrix, rmatrix
  allocate(jmatrix(3*nintfacetot,3*nintfacetot)); jmatrix = smatrix + pmatrix + rmatrix
 
# 597 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/homogenization_mech_RGC.f90"
 
!--------------------------------------------------------------------------------------------------
! computing the update of the state variable (relaxation vectors) using the Jacobian matrix
  allocate(jnverse(3*nintfacetot,3*nintfacetot),source=0.0_preal)
  call math_invert(jnverse,error,jmatrix)
 
# 613 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/homogenization_mech_RGC.f90"
 
!--------------------------------------------------------------------------------------------------
! calculate the state update (global relaxation vectors) for the next Newton-Raphson iteration
  drelax = 0.0_preal
  do i = 1,3*nintfacetot;do j = 1,3*nintfacetot
    drelax(i) = drelax(i) - jnverse(i,j)*resid(j)                                                   ! Calculate the correction for the state variable
  enddo; enddo
  stt%relaxationVector(:,of) = relax + drelax                                                       ! Updateing the state variable for the next iteration
  if (any(abs(drelax) > num%maxdRelax)) then                                                        ! Forcing cutback when the incremental change of relaxation vector becomes too large
    mech_rgc_updatestate = [.true.,.false.]
    !$OMP CRITICAL (write2out)
    write(6,'(1x,a,1x,i3,1x,a,1x,i3,1x,a)')'RGC_updateState: ip',ip,'| el',el,'enforces cutback'
    write(6,'(1x,a,1x,e15.8)')'due to large relaxation change =',maxval(abs(drelax))
    flush(6)
    !$OMP END CRITICAL (write2out)
  endif
 
# 640 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/homogenization_mech_RGC.f90"
 
  end associate
 
  contains
  !------------------------------------------------------------------------------------------------
  !------------------------------------------------------------------------------------------------
  subroutine stresspenalty(rPen,nMis,avgF,fDef,ip,el,instance,of)
 
    real(preal),   dimension (:,:,:), intent(out) :: rpen
    real(preal),   dimension (:,:),   intent(out) :: nmis
 
    real(preal),   dimension (:,:,:), intent(in)  :: fdef
    real(preal),   dimension (3,3),   intent(in)  :: avgf
    integer,                          intent(in)  :: ip,el,instance,of
 
    integer, dimension (4)   :: intFace
    integer, dimension (3)   :: iGrain3,iGNghb3,nGDim
    real(pReal),   dimension (3,3) :: gDef,nDef
    real(pReal),   dimension (3)   :: nVect,surfCorr
    real(pReal),   dimension (2)   :: Gmoduli
    integer :: iGrain,iGNghb,iFace,i,j,k,l
    real(pReal)   :: muGrain,muGNghb,nDefNorm,bgGrain,bgGNghb
    real(pReal), parameter  :: nDefToler = 1.0e-10_preal
 
 
 
 
    ngdim = param(instance)%Nconstituents
    rpen = 0.0_preal
    nmis = 0.0_preal
 
    !----------------------------------------------------------------------------------------------
    ! get the correction factor the modulus of penalty stress representing the evolution of area of
    ! the interfaces due to deformations
 
    surfcorr = surfacecorrection(avgf,instance,of)
 
    associate(prm => param(instance))
 
# 688 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/homogenization_mech_RGC.f90"
 
   !-----------------------------------------------------------------------------------------------
   ! computing the mismatch and penalty stress tensor of all grains
   grainloop: do igrain = 1,product(prm%Nconstituents)
     gmoduli = equivalentmoduli(igrain,ip,el)
     mugrain = gmoduli(1)                                                                           ! collecting the equivalent shear modulus of grain
     bggrain = gmoduli(2)                                                                           ! and the lengthh of Burgers vector
     igrain3 = grain1to3(igrain,prm%Nconstituents)                                                  ! get the grain ID in local 3-dimensional index (x,y,z)-position
 
     interfaceloop: do iface = 1,6
       intface = getinterface(iface,igrain3)                                                        ! get the 4-dimensional index of the interface in local numbering system of the grain
       nvect = interfacenormal(intface,instance,of)
       ignghb3 = igrain3                                                                            ! identify the neighboring grain across the interface
       ignghb3(abs(intface(1))) = ignghb3(abs(intface(1))) &
                                + int(real(intface(1),preal)/real(abs(intface(1)),preal))
       where(ignghb3 < 1)    ignghb3 = ngdim
       where(ignghb3 >ngdim) ignghb3 = 1
       ignghb  = grain3to1(ignghb3,prm%Nconstituents)                                               ! get the ID of the neighboring grain
       gmoduli = equivalentmoduli(ignghb,ip,el)                                                     ! collect the shear modulus and Burgers vector of the neighbor
       mugnghb = gmoduli(1)
       bggnghb = gmoduli(2)
       gdef = 0.5_preal*(fdef(1:3,1:3,ignghb) - fdef(1:3,1:3,igrain))                               ! difference/jump in deformation gradeint across the neighbor
 
       !-------------------------------------------------------------------------------------------
       ! compute the mismatch tensor of all interfaces
       ndefnorm = 0.0_preal
       ndef = 0.0_preal
       do i = 1,3; do j = 1,3
         do k = 1,3; do l = 1,3
           ndef(i,j) = ndef(i,j) - nvect(k)*gdef(i,l)*math_levicivita(j,k,l)                        ! compute the interface mismatch tensor from the jump of deformation gradient
         enddo; enddo
         ndefnorm = ndefnorm + ndef(i,j)**2.0_preal                                                 ! compute the norm of the mismatch tensor
       enddo; enddo
       ndefnorm = max(ndeftoler,sqrt(ndefnorm))                                                     ! approximation to zero mismatch if mismatch is zero (singularity)
       nmis(abs(intface(1)),igrain) = nmis(abs(intface(1)),igrain) + ndefnorm                       ! total amount of mismatch experienced by the grain (at all six interfaces)
 
 
 
 
 
 
 
 
       !-------------------------------------------------------------------------------------------
       ! compute the stress penalty of all interfaces
       do i = 1,3; do j = 1,3; do k = 1,3; do l = 1,3
         rpen(i,j,igrain) = rpen(i,j,igrain) + 0.5_preal*(mugrain*bggrain + mugnghb*bggnghb)*prm%xiAlpha &
                                                *surfcorr(abs(intface(1)))/prm%dAlpha(abs(intface(1))) &
                                                *cosh(prm%ciAlpha*ndefnorm) &
                                                *0.5_preal*nvect(l)*ndef(i,k)/ndefnorm*math_levicivita(k,l,j) &
                                                *tanh(ndefnorm/num%xSmoo)
       enddo; enddo;enddo; enddo
     enddo interfaceloop
 
 
 
 
 
 
 
   enddo grainloop
 
   end associate
 
  end subroutine stresspenalty
 
 
  !------------------------------------------------------------------------------------------------
  !------------------------------------------------------------------------------------------------
  subroutine volumepenalty(vPen,vDiscrep,fAvg,fDef,nGrain,instance,of)
 
    real(pReal), dimension (:,:,:), intent(out) :: vPen                                             ! stress-like penalty due to volume
    real(pReal),                    intent(out) :: vDiscrep                                         ! total volume discrepancy
 
    real(pReal), dimension (:,:,:), intent(in)  :: fDef                                             ! deformation gradients
    real(pReal), dimension (3,3),   intent(in)  :: fAvg                                             ! overall deformation gradient
    integer,                        intent(in) :: &
      Ngrain, &
      instance, &
      of
 
    real(pReal), dimension(size(vPen,3)) :: gVol
    integer :: i
 
    !----------------------------------------------------------------------------------------------
    ! compute the volumes of grains and of cluster
    vdiscrep = math_det33(favg)                                                                     ! compute the volume of the cluster
    do i = 1,ngrain
      gvol(i) = math_det33(fdef(1:3,1:3,i))                                                         ! compute the volume of individual grains
      vdiscrep     = vdiscrep - gvol(i)/real(ngrain,preal)                                          ! calculate the difference/dicrepancy between
                                                                                                    ! the volume of the cluster and the the total volume of grains
    enddo
 
    !----------------------------------------------------------------------------------------------
    ! calculate the stress and penalty due to volume discrepancy
    vpen      = 0.0_preal
    do i = 1,ngrain
      vpen(:,:,i) = -1.0_preal/real(ngrain,preal)*num%volDiscrMod*num%volDiscrPow/num%maxVolDiscr* &
                         sign((abs(vdiscrep)/num%maxVolDiscr)**(num%volDiscrPow - 1.0),vdiscrep)* &
                         gvol(i)*transpose(math_inv33(fdef(:,:,i)))
 
 
 
 
 
 
 
 
    enddo
 
  end subroutine volumepenalty
 
 
  !--------------------------------------------------------------------------------------------------
  ! deformation
  !--------------------------------------------------------------------------------------------------
  function surfacecorrection(avgF,instance,of)
 
    real(pReal), dimension(3)               :: surfaceCorrection
 
    real(pReal), dimension(3,3), intent(in) :: avgF
    integer,                     intent(in) :: &
      instance, &
      of
    real(preal), dimension(3,3)             :: invc
    real(preal), dimension(3)               :: nvect
    real(preal)  :: detf
    integer :: i,j,ibase
    logical     ::  error
 
    call math_invert33(invc,detf,error,matmul(transpose(avgf),avgf))
 
    surfacecorrection = 0.0_preal
    do ibase = 1,3
      nvect = interfacenormal([ibase,1,1,1],instance,of)
      do i = 1,3; do j = 1,3
        surfacecorrection(ibase) = surfacecorrection(ibase) + invc(i,j)*nvect(i)*nvect(j)           ! compute the component of (the inverse of) the stretch in the direction of the normal
      enddo; enddo
      surfacecorrection(ibase) = sqrt(surfacecorrection(ibase))*detf                                ! get the surface correction factor (area contraction/enlargement)
    enddo
 
  end function surfacecorrection
 
 
  !--------------------------------------------------------------------------------------------------
  !--------------------------------------------------------------------------------------------------
  function equivalentmoduli(grainID,ip,el)
 
    real(preal), dimension(2)    :: equivalentmoduli
 
    integer, intent(in)    :: &
      grainid,&
      ip, &                                                                                         !< integration point number
      el
    real(preal), dimension(6,6) :: elastens
    real(preal) :: &
      cequiv_11, &
      cequiv_12, &
      cequiv_44
 
    elastens = constitutive_homogenizedc(grainid,ip,el)
 
    !----------------------------------------------------------------------------------------------
    ! compute the equivalent shear modulus after Turterltaub and Suiker, JMPS (2005)
    cequiv_11 = (elastens(1,1) + elastens(2,2) + elastens(3,3))/3.0_preal
    cequiv_12 = (elastens(1,2) + elastens(2,3) + elastens(3,1) + &
                 elastens(1,3) + elastens(2,1) + elastens(3,2))/6.0_preal
    cequiv_44 = (elastens(4,4) + elastens(5,5) + elastens(6,6))/3.0_preal
    equivalentmoduli(1) = 0.2_preal*(cequiv_11 - cequiv_12) + 0.6_preal*cequiv_44
 
    !----------------------------------------------------------------------------------------------
    ! obtain the length of Burgers vector (could be model dependend)
    equivalentmoduli(2) = 2.5e-10_preal
 
  end function equivalentmoduli
 
 
  !--------------------------------------------------------------------------------------------------
  ! homogenization_RGC_partitionDeformation, but used only for perturbation scheme)
  !--------------------------------------------------------------------------------------------------
  subroutine graindeformation(F, avgF, instance, of)
 
    real(preal),   dimension(:,:,:), intent(out) :: f
 
    real(preal),   dimension(:,:),   intent(in)  :: avgf
    integer,                          intent(in)  :: &
      instance, &
      of
 
    real(pReal),   dimension(3) :: aVect,nVect
    integer,       dimension(4) :: intFace
    integer,       dimension(3) :: iGrain3
    integer :: iGrain,iFace,i,j
 
    !-------------------------------------------------------------------------------------------------
    ! compute the deformation gradient of individual grains due to relaxations
 
    associate(prm => param(instance))
 
    f = 0.0_preal
    do igrain = 1,product(prm%Nconstituents)
      igrain3 = grain1to3(igrain,prm%Nconstituents)
      do iface = 1,6
        intface = getinterface(iface,igrain3)
        avect   = relaxationvector(intface,instance,of)
        nvect   = interfacenormal(intface,instance,of)
        forall (i=1:3,j=1:3) &
          f(i,j,igrain) = f(i,j,igrain) + avect(i)*nvect(j)                                         ! effective relaxations
      enddo
      f(1:3,1:3,igrain) = f(1:3,1:3,igrain) + avgf                                                  ! relaxed deformation gradient
    enddo
 
    end associate
 
  end subroutine graindeformation
 
end procedure mech_rgc_updatestate
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine mech_rgc_averagestressanditstangent(avgp,davgpdavgf,p,dpdf,instance)
 
  real(pReal), dimension (3,3),        intent(out) :: avgP
  real(pReal), dimension (3,3,3,3),    intent(out) :: dAvgPdAvgF
 
  real(pReal), dimension (:,:,:),      intent(in)  :: P
  real(pReal), dimension (:,:,:,:,:),  intent(in)  :: dPdF
  integer,                             intent(in)  :: instance
 
  avgp       = sum(p,3)   /real(product(param(instance)%Nconstituents),preal)
  davgpdavgf = sum(dpdf,5)/real(product(param(instance)%Nconstituents),preal)
 
end subroutine mech_rgc_averagestressanditstangent
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module subroutine mech_rgc_results(instance,group)
 
  integer,          intent(in) :: instance
  character(len=*), intent(in) :: group
 
  integer :: o
 
  associate(stt => state(instance), dst => dependentstate(instance), prm => param(instance))
  outputsloop: do o = 1,size(prm%output)
    select case(trim(prm%output(o)))
      case('constitutivework')
        call results_writedataset(group,stt%work,'W',&
                                  'work density','J/m³')
      case('magnitudemismatch')
        call results_writedataset(group,dst%mismatch,'N',&
                                  'average mismatch tensor','1')
      case('penaltyenergy')
        call results_writedataset(group,stt%penaltyEnergy,'R',&
                                  'mismatch penalty density','J/m³')
      case('volumediscrepancy')
        call results_writedataset(group,dst%volumeDiscrepancy,'Delta_V',&
                                  'volume discrepancy','m³')
      case('maximumrelaxrate')
        call results_writedataset(group,dst%relaxationrate_max,'max_alpha_dot',&
                                  'maximum relaxation rate','m/s')
      case('averagerelaxrate')
        call results_writedataset(group,dst%relaxationrate_avg,'avg_alpha_dot',&
                                  'average relaxation rate','m/s')
    end select
  enddo outputsloop
  end associate
 
end subroutine mech_rgc_results
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function relaxationvector(intFace,instance,of)
 
  real(pReal), dimension (3)            :: relaxationVector
 
  integer,                   intent(in) :: instance,of
  integer,     dimension(4), intent(in) :: intFace
 
  integer :: inum
 
!--------------------------------------------------------------------------------------------------
! collect the interface relaxation vector from the global state array
 
  inum = interface4to1(intface,param(instance)%Nconstituents)                                       ! identify the position of the interface in global state array
  if (inum > 0) then
    relaxationvector = state(instance)%relaxationVector((3*inum-2):(3*inum),of)
  else
    relaxationvector = 0.0_preal
  endif
 
end function relaxationvector
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function interfacenormal(intFace,instance,of)
 
  real(preal), dimension(3)             :: interfacenormal
 
  integer,     dimension(4), intent(in) :: intface
  integer,                   intent(in) :: &
    instance, &
    of
 
  integer :: npos
 
!--------------------------------------------------------------------------------------------------
! get the normal of the interface, identified from the value of intFace(1)
  interfacenormal = 0.0_preal
  npos = abs(intface(1))                                                                            ! identify the position of the interface in global state array
  interfacenormal(npos) = real(intface(1)/abs(intface(1)),preal)                                    ! get the normal vector w.r.t. cluster axis
 
  interfacenormal = matmul(dependentstate(instance)%orientation(1:3,1:3,of),interfacenormal)        ! map the normal vector into sample coordinate system (basis)
 
end function interfacenormal
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function getinterface(iFace,iGrain3)
 
  integer, dimension(4)             :: getinterface
 
  integer, dimension(3), intent(in) :: igrain3
  integer,               intent(in) :: iface
 
  integer :: idir
 
 idir = (int(real(iface-1,preal)/2.0_preal)+1)*(-1)**iface
 getinterface(1) = idir
 
!--------------------------------------------------------------------------------------------------
! identify the interface position by the direction of its normal
  getinterface(2:4) = igrain3
  if (idir < 0) getinterface(1-idir) = getinterface(1-idir)-1                                       ! to have a correlation with coordinate/position in real space
 
end function getinterface
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function grain1to3(grain1,nGDim)
 
  integer, dimension(3)             :: grain1to3
 
  integer,               intent(in) :: grain1
  integer, dimension(3), intent(in) :: ngdim
 
  grain1to3 = 1 + [mod((grain1-1), ngdim(1)), &
                   mod((grain1-1)/ ngdim(1),ngdim(2)), &
                       (grain1-1)/(ngdim(1)*ngdim(2))]
 
end function grain1to3
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
integer pure function grain3to1(grain3,ngdim)
 
  integer, dimension(3), intent(in) :: grain3
  integer, dimension(3), intent(in) :: ngdim
 
  grain3to1 = grain3(1) &
            + ngdim(1)*(grain3(2)-1) &
            + ngdim(1)*ngdim(2)*(grain3(3)-1)
 
end function grain3to1
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
integer pure function interface4to1(iface4d, ngdim)
 
  integer, dimension(4), intent(in) :: iface4d
  integer, dimension(3), intent(in) :: ngdim
 
 
  select case(abs(iface4d(1)))
 
    case(1)
      if ((iface4d(2) == 0) .or. (iface4d(2) == ngdim(1))) then
        interface4to1 = 0
      else
        interface4to1 = iface4d(3) + ngdim(2)*(iface4d(4)-1) &
                      + ngdim(2)*ngdim(3)*(iface4d(2)-1)
      endif
 
    case(2)
      if ((iface4d(3) == 0) .or. (iface4d(3) == ngdim(2))) then
        interface4to1 = 0
      else
        interface4to1 = iface4d(4) + ngdim(3)*(iface4d(2)-1) &
                      + ngdim(3)*ngdim(1)*(iface4d(3)-1) &
                      + (ngdim(1)-1)*ngdim(2)*ngdim(3)                                              ! total # of interfaces normal || e1
      endif
 
    case(3)
      if ((iface4d(4) == 0) .or. (iface4d(4) == ngdim(3))) then
        interface4to1 = 0
      else
        interface4to1 = iface4d(2) + ngdim(1)*(iface4d(3)-1) &
                      + ngdim(1)*ngdim(2)*(iface4d(4)-1) &
                      + (ngdim(1)-1)*ngdim(2)*ngdim(3) &                                            ! total # of interfaces normal || e1
                      + ngdim(1)*(ngdim(2)-1)*ngdim(3)                                              ! total # of interfaces normal || e2
      endif
 
    case default
      interface4to1 = -1
 
  end select
 
end function interface4to1
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
pure function interface1to4(iFace1D, nGDim)
 
  integer, dimension(4)             :: interface1to4
 
  integer,               intent(in) :: iface1d
  integer, dimension(3), intent(in) :: ngdim
  integer, dimension(3)             :: nintface
 
!--------------------------------------------------------------------------------------------------
! compute the total number of interfaces, which ...
  nintface = [(ngdim(1)-1)*ngdim(2)*ngdim(3), &                                                     ! ... normal || e1
              ngdim(1)*(ngdim(2)-1)*ngdim(3), &                                                     ! ... normal || e2
              ngdim(1)*ngdim(2)*(ngdim(3)-1)]                                                       ! ... normal || e3
 
!--------------------------------------------------------------------------------------------------
! get the corresponding interface ID in 4D (normal and local position)
  if (iface1d > 0 .and. iface1d <= nintface(1)) then                                                ! interface with normal || e1
    interface1to4(1) = 1
    interface1to4(3) = mod((iface1d-1),ngdim(2))+1
    interface1to4(4) = mod(int(real(iface1d-1,preal)/real(ngdim(2),preal)),ngdim(3))+1
    interface1to4(2) = int(real(iface1d-1,preal)/real(ngdim(2),preal)/real(ngdim(3),preal))+1
  elseif (iface1d > nintface(1) .and. iface1d <= (nintface(2) + nintface(1))) then                  ! interface with normal || e2
    interface1to4(1) = 2
    interface1to4(4) = mod((iface1d-nintface(1)-1),ngdim(3))+1
    interface1to4(2) = mod(int(real(iface1d-nintface(1)-1,preal)/real(ngdim(3),preal)),ngdim(1))+1
    interface1to4(3) = int(real(iface1d-nintface(1)-1,preal)/real(ngdim(3),preal)/real(ngdim(1),preal))+1
  elseif (iface1d > nintface(2) + nintface(1) .and. iface1d <= (nintface(3) + nintface(2) + nintface(1))) then ! interface with normal || e3
    interface1to4(1) = 3
    interface1to4(2) = mod((iface1d-nintface(2)-nintface(1)-1),ngdim(1))+1
    interface1to4(3) = mod(int(real(iface1d-nintface(2)-nintface(1)-1,preal)/real(ngdim(1),preal)),ngdim(2))+1
    interface1to4(4) = int(real(iface1d-nintface(2)-nintface(1)-1,preal)/real(ngdim(1),preal)/real(ngdim(2),preal))+1
  endif
 
end function interface1to4
 
 
end submodule homogenization_mech_rgc
# 55 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
 
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/CPFEM.f90" 1
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module cpfem
  use prec
  use numerics
  use debug
  use fesolving
  use math
  use rotations
  use discretization_marc
  use material
  use config
  use crystallite
  use homogenization
  use io
  use discretization
  use damask_interface
  use numerics
  use hdf5_utilities
  use results
  use lattice
  use constitutive
 
  implicit none
  private
 
  real(preal), dimension (:,:,:),   allocatable, private :: &
    cpfem_cs
  real(preal), dimension (:,:,:,:), allocatable, private :: &
    cpfem_dcsde
  real(preal), dimension (:,:,:,:), allocatable, private :: &
    cpfem_dcsde_knowngood
  integer(pInt),                                 public :: &
    cyclecounter =  0_pint, &                                                                       
    theinc       = -1_pint, &                                                                       
    lastlovl     =  0_pint                                                                          
  real(preal),                                   public :: &
    thetime      = 0.0_preal, &                                                                     
    thedelta     = 0.0_preal
  logical,                                       public :: &
    outdatedffn1      = .false., &                                                                  
    lastincconverged  = .false., &                                                                  
    outdatedbynewinc  = .false.                                                                     
 
  logical,                                       public, protected :: &
    cpfem_init_done       = .false.                                                                 
  logical,                                       private :: &
    cpfem_calc_done       = .false.                                                                 
 
  integer(pInt), parameter,                      public :: &
    cpfem_collect         = 2_pint**0_pint, &
    cpfem_calcresults     = 2_pint**1_pint, &
    cpfem_ageresults      = 2_pint**2_pint, &
    cpfem_backupjacobian  = 2_pint**3_pint, &
    cpfem_restorejacobian = 2_pint**4_pint
 
  public :: &
    cpfem_general, &
    cpfem_initall, &
    cpfem_results
 
contains
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine cpfem_initall(el,ip)
 
  integer(pInt), intent(in) :: el, &                                                                !< FE el number
                               ip
 
  !$OMP CRITICAL(init)
  if (.not. cpfem_init_done) then
    call damask_interface_init
    call prec_init
    call io_init
    call numerics_init
    call debug_init
    call config_init
    call math_init
    call rotations_init
    call hdf5_utilities_init
    call results_init
    call discretization_marc_init(ip, el)
    call lattice_init
    call material_init
    call constitutive_init
    call crystallite_init
    call homogenization_init
    call cpfem_init
    cpfem_init_done = .true.
  endif
  !$OMP END CRITICAL(init)
 
end subroutine cpfem_initall
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine cpfem_init
 
  write(6,'(/,a)')   ' <<<+-  CPFEM init  -+>>>'
  flush(6)
 
  allocate(cpfem_cs(               6,discretization_nip,discretization_nelem), source= 0.0_preal)
  allocate(cpfem_dcsde(          6,6,discretization_nip,discretization_nelem), source= 0.0_preal)
  allocate(cpfem_dcsde_knowngood(6,6,discretization_nip,discretization_nelem), source= 0.0_preal)
 
  if (iand(debug_level(debug_cpfem), debug_levelbasic) /= 0) then
    write(6,'(a32,1x,6(i8,1x))')   'CPFEM_cs:              ', shape(cpfem_cs)
    write(6,'(a32,1x,6(i8,1x))')   'CPFEM_dcsdE:           ', shape(cpfem_dcsde)
    write(6,'(a32,1x,6(i8,1x),/)') 'CPFEM_dcsdE_knownGood: ', shape(cpfem_dcsde_knowngood)
    flush(6)
  endif
 
end subroutine cpfem_init
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine cpfem_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt, elFE, ip, cauchyStress, jacobian)
 
  integer(pInt), intent(in) ::                        elFE, &                                       !< FE element number
                                                      ip
  real(pReal), intent(in) ::                          dt
  real(pReal), dimension (3,3), intent(in) ::         ffn, &                                        !< deformation gradient for t=t0
                                                      ffn1
  integer(pInt), intent(in) ::                        mode
  real(pReal), intent(in) ::                          temperature_inp
  logical, intent(in) ::                              parallelExecution
  real(pReal), dimension(6), intent(out) ::           cauchyStress
  real(pReal), dimension(6,6), intent(out) ::         jacobian
 
  real(pReal)                                         J_inverse, &                                  ! inverse of Jacobian
                                                      rnd
  real(pReal), dimension (3,3) ::                     Kirchhoff, &                                  ! Piola-Kirchhoff stress
                                                      cauchyStress33                                ! stress vector
  real(pReal), dimension (3,3,3,3) ::                 H_sym, &
                                                      H, &
                                                      jacobian3333                                  ! jacobian in Matrix notation
 
  integer(pInt)                                       elCP, &                                       ! crystal plasticity element number
                                                      i, j, k, l, m, n, ph, homog, mySource
  logical                                             updateJaco                                    ! flag indicating if Jacobian has to be updated
 
  real(pReal), parameter ::                          ODD_STRESS    = 1e15_preal, &                  
                                                     odd_jacobian  = 1e50_preal                     
 
  elcp = mesh_fem2damask_elem(elfe)
 
  if (iand(debug_level(debug_cpfem), debug_levelbasic) /= 0_pint &
      .and. elcp == debug_e .and. ip == debug_i) then
    write(6,'(/,a)') '#############################################'
    write(6,'(a1,a22,1x,i8,a13)')   '#','element',        elcp,         '#'
    write(6,'(a1,a22,1x,i8,a13)')   '#','ip',             ip,           '#'
    write(6,'(a1,a22,1x,f15.7,a6)') '#','theTime',        thetime,      '#'
    write(6,'(a1,a22,1x,f15.7,a6)') '#','theDelta',       thedelta,     '#'
    write(6,'(a1,a22,1x,i8,a13)')   '#','theInc',         theinc,       '#'
    write(6,'(a1,a22,1x,i8,a13)')   '#','cycleCounter',   cyclecounter, '#'
    write(6,'(a1,a22,1x,i8,a13)')   '#','computationMode',mode,         '#'
    if (terminallyill) &
    write(6,'(a,/)') '#           --- terminallyIll ---           #'
    write(6,'(a,/)') '#############################################'; flush (6)
  endif
 
  if (iand(mode, cpfem_backupjacobian) /= 0_pint) &
    cpfem_dcsde_knowngood = cpfem_dcsde
  if (iand(mode, cpfem_restorejacobian) /= 0_pint) &
    cpfem_dcsde = cpfem_dcsde_knowngood
 
  !*** age results
  if (iand(mode, cpfem_ageresults) /= 0_pint) call cpfem_forward
 
 
  !*** collection of FEM input with returning of randomize odd stress and jacobian
  !*   If no parallel execution is required, there is no need to collect FEM input
  if (.not. parallelexecution) then
    chosenthermal1: select case (thermal_type(material_homogenizationat(elcp)))
      case (thermal_conduction_id) chosenthermal1
        temperature(material_homogenizationat(elcp))%p(thermalmapping(material_homogenizationat(elcp))%p(ip,elcp)) = &
          temperature_inp
      end select chosenthermal1
    materialpoint_f0(1:3,1:3,ip,elcp) = ffn
    materialpoint_f(1:3,1:3,ip,elcp) = ffn1
 
  elseif (iand(mode, cpfem_collect) /= 0_pint) then
    call random_number(rnd)
    if (rnd < 0.5_preal) rnd = rnd - 1.0_preal
    cpfem_cs(1:6,ip,elcp) = rnd * odd_stress
    cpfem_dcsde(1:6,1:6,ip,elcp) = odd_jacobian * math_identity2nd(6)
    chosenthermal2: select case (thermal_type(material_homogenizationat(elcp)))
      case (thermal_conduction_id) chosenthermal2
        temperature(material_homogenizationat(elcp))%p(thermalmapping(material_homogenizationat(elcp))%p(ip,elcp)) = &
          temperature_inp
      end select chosenthermal2
    materialpoint_f0(1:3,1:3,ip,elcp) = ffn
    materialpoint_f(1:3,1:3,ip,elcp) = ffn1
    cpfem_calc_done = .false.
  endif
 
 
  !*** calculation of stress and jacobian
  if (iand(mode, cpfem_calcresults) /= 0_pint) then
 
    !*** deformation gradient outdated or any actual deformation gradient differs more than relevantStrain from the stored one
    validcalculation: if (terminallyill &
                     .or. outdatedffn1 &
                     .or. any(abs(ffn1 - materialpoint_f(1:3,1:3,ip,elcp)) > defgradtolerance)) then
      if (any(abs(ffn1 - materialpoint_f(1:3,1:3,ip,elcp)) > defgradtolerance)) then
        if (iand(debug_level(debug_cpfem), debug_levelbasic) /=  0_pint) then
            write(6,'(a,1x,i8,1x,i2)') '<< CPFEM >> OUTDATED at elFE ip',elfe,ip
            write(6,'(a,/,3(12x,3(f10.6,1x),/))') '<< CPFEM >> FFN1 old:',&
                                              transpose(materialpoint_f(1:3,1:3,ip,elcp))
            write(6,'(a,/,3(12x,3(f10.6,1x),/))') '<< CPFEM >> FFN1 now:',transpose(ffn1)
        endif
        outdatedffn1 = .true.
      endif
      call random_number(rnd)
      if (rnd < 0.5_preal) rnd = rnd - 1.0_preal
      cpfem_cs(1:6,ip,elcp)        = odd_stress * rnd
      cpfem_dcsde(1:6,1:6,ip,elcp) = odd_jacobian * math_identity2nd(6)
 
    !*** deformation gradient is not outdated
    else validcalculation
      updatejaco = mod(cyclecounter,ijacostiffness) == 0
      !* no parallel computation, so we use just one single elFE and ip for computation
      if (.not. parallelexecution) then
        fesolving_execelem = elcp
        fesolving_execip   = ip
        if (iand(debug_level(debug_cpfem), debug_levelextensive) /=  0_pint) &
          write(6,'(a,i8,1x,i2)') '<< CPFEM >> calculation for elFE ip ',elfe,ip
        call materialpoint_stressanditstangent(updatejaco, dt)
 
      !* parallel computation and calulation not yet done
      elseif (.not. cpfem_calc_done) then
        if (iand(debug_level(debug_cpfem), debug_levelextensive) /= 0_pint) &
          write(6,'(a,i8,a,i8)') '<< CPFEM >> calculation for elements ',fesolving_execelem(1),&
                                                                  ' to ',fesolving_execelem(2)
        call materialpoint_stressanditstangent(updatejaco, dt)
        cpfem_calc_done = .true.
      endif
 
      !* map stress and stiffness (or return odd values if terminally ill)
      terminalillness: if (terminallyill) then
 
        call random_number(rnd)
        if (rnd < 0.5_preal) rnd = rnd - 1.0_preal
        cpfem_cs(1:6,ip,elcp)        = odd_stress * rnd
        cpfem_dcsde(1:6,1:6,ip,elcp) = odd_jacobian * math_identity2nd(6)
 
      else terminalillness
 
        ! translate from P to CS
        kirchhoff = matmul(materialpoint_p(1:3,1:3,ip,elcp), transpose(materialpoint_f(1:3,1:3,ip,elcp)))
        j_inverse  = 1.0_preal / math_det33(materialpoint_f(1:3,1:3,ip,elcp))
        cpfem_cs(1:6,ip,elcp) = math_sym33to6(j_inverse * kirchhoff,weighted=.false.)
 
        !  translate from dP/dF to dCS/dE
        h = 0.0_preal
        do i=1,3; do j=1,3; do k=1,3; do l=1,3; do m=1,3; do n=1,3
          h(i,j,k,l) = h(i,j,k,l) &
                     +  materialpoint_f(j,m,ip,elcp) * materialpoint_f(l,n,ip,elcp) &
                                                     * materialpoint_dpdf(i,m,k,n,ip,elcp) &
                     -  math_delta(j,l) * materialpoint_f(i,m,ip,elcp) * materialpoint_p(k,m,ip,elcp) &
                     +  0.5_preal * (  kirchhoff(j,l)*math_delta(i,k) + kirchhoff(i,k)*math_delta(j,l) &
                                     + kirchhoff(j,k)*math_delta(i,l) + kirchhoff(i,l)*math_delta(j,k))
        enddo; enddo; enddo; enddo; enddo; enddo
 
        forall(i=1:3, j=1:3,k=1:3,l=1:3) &
          h_sym(i,j,k,l) = 0.25_preal * (h(i,j,k,l) + h(j,i,k,l) + h(i,j,l,k) + h(j,i,l,k))
 
        cpfem_dcsde(1:6,1:6,ip,elcp) = math_sym3333to66(j_inverse * h_sym,weighted=.false.)
 
      endif terminalillness
    endif validcalculation
 
    !* report stress and stiffness
    if ((iand(debug_level(debug_cpfem), debug_levelextensive) /= 0_pint) &
         .and. ((debug_e == elcp .and. debug_i == ip) &
                .or. .not. iand(debug_level(debug_cpfem), debug_levelselective) /= 0_pint)) then
        write(6,'(a,i8,1x,i2,/,12x,6(f10.3,1x)/)') &
          '<< CPFEM >> stress/MPa at elFE ip ',   elfe, ip, cpfem_cs(1:6,ip,elcp)*1.0e-6_preal
        write(6,'(a,i8,1x,i2,/,6(12x,6(f10.3,1x)/))') &
          '<< CPFEM >> Jacobian/GPa at elFE ip ', elfe, ip, transpose(cpfem_dcsde(1:6,1:6,ip,elcp))*1.0e-9_preal
        flush(6)
    endif
 
  endif
 
  !*** warn if stiffness close to zero
  if (all(abs(cpfem_dcsde(1:6,1:6,ip,elcp)) < 1e-10_preal)) call io_warning(601,elcp,ip)
 
  !*** copy to output if using commercial FEM solver
  cauchystress = cpfem_cs(1:6,    ip,elcp)
  jacobian     = cpfem_dcsde(1:6,1:6,ip,elcp)
 
 
  !*** remember extreme values of stress ...
  cauchystress33 = math_6tosym33(cpfem_cs(1:6,ip,elcp),weighted=.false.)
  if (maxval(cauchystress33) > debug_stressmax) then
    debug_stressmaxlocation = [elcp, ip]
    debug_stressmax = maxval(cauchystress33)
  endif
  if (minval(cauchystress33) < debug_stressmin) then
    debug_stressminlocation = [elcp, ip]
    debug_stressmin = minval(cauchystress33)
  endif
  !*** ... and Jacobian
  jacobian3333 = math_66tosym3333(cpfem_dcsde(1:6,1:6,ip,elcp),weighted=.false.)
  if (maxval(jacobian3333) > debug_jacobianmax) then
    debug_jacobianmaxlocation = [elcp, ip]
    debug_jacobianmax = maxval(jacobian3333)
  endif
  if (minval(jacobian3333) < debug_jacobianmin) then
    debug_jacobianminlocation = [elcp, ip]
    debug_jacobianmin = minval(jacobian3333)
  endif
 
end subroutine cpfem_general
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine cpfem_forward
 
  call crystallite_forward
 
end subroutine cpfem_forward
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine cpfem_results(inc,time)
 
  integer(pInt), intent(in) :: inc
  real(pReal),   intent(in) :: time
 
  call results_openjobfile
  call results_addincrement(inc,time)
  call constitutive_results
  call crystallite_results
  call homogenization_results
  call discretization_results
  call results_finalizeincrement
  call results_closejobfile
 
end subroutine cpfem_results
 
end module cpfem
# 56 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/commercialFEM_fileList.f90" 2
# 163 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/DAMASK_marc.f90" 2
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, &
                   dispt,coord,ffn,frotn,strechn,eigvn,ffn1,frotn1, &
                   strechn1,eigvn1,ncrd,itel,ndeg,ndm,nnode, &
                   jtype,lclass,ifr,ifu)
 use prec
 use damask_interface
 use numerics
 use fesolving
 use debug
 use discretization_marc
 use cpfem
 
 implicit none
!$ include "omp_lib.h"                                                                              ! the openMP function library
 integer,                               intent(in) :: &                                             ! according to MSC.Marc 2012 Manual D
   ngens, &                                                                                         !< size of stress-strain law
   nn, &                                                                                            !< integration point number
   ndi, &                                                                                           !< number of direct components
   nshear, &                                                                                        !< number of shear components
   ncrd, &                                                                                          !< number of coordinates
   itel, &                                                                                          !< dimension of F and R, either 2 or 3
   ndeg, &                                                                                          !< number of degrees of freedom
   ndm, &                                                                                           !< not specified in MSC.Marc 2012 Manual D
   nnode, &                                                                                         !< number of nodes per element
   jtype, &                                                                                         !< element type
   ifr, &                                                                                           !< set to 1 if R has been calculated
   ifu
 integer, dimension(2),                 intent(in) :: &                                             ! according to MSC.Marc 2012 Manual D
   m, &                                                                                             !< (1) user element number, (2) internal element number
   matus, &                                                                                         !< (1) user material identification number, (2) internal material identification number
   kcus, &                                                                                          !< (1) layer number, (2) internal layer number
   lclass
 real(pReal),   dimension(*),           intent(in) :: &                                             ! has dimension(1) according to MSC.Marc 2012 Manual D, but according to example hypela2.f dimension(*)
   e, &                                                                                             !< total elastic strain
   de, &                                                                                            !< increment of strain
   dt
 real(pReal),   dimension(itel),        intent(in) :: &                                             ! according to MSC.Marc 2012 Manual D
   strechn, &                                                                                       !< square of principal stretch ratios, lambda(i) at t=n
   strechn1
 real(pReal),   dimension(3,3),         intent(in) :: &                                             ! has dimension(itel,*) according to MSC.Marc 2012 Manual D, but we alway assume dimension(3,3)
   ffn, &                                                                                           !< deformation gradient at t=n
   ffn1
 real(pReal),   dimension(itel,*),      intent(in) :: &                                             ! according to MSC.Marc 2012 Manual D
   frotn, &                                                                                         !< rotation tensor at t=n
   eigvn, &                                                                                         !< i principal direction components for j eigenvalues at t=n
   frotn1, &                                                                                        !< rotation tensor at t=n+1
   eigvn1
 real(pReal),   dimension(ndeg,*),      intent(in) :: &                                             ! according to MSC.Marc 2012 Manual D
   disp, &                                                                                          !< incremental displacements
   dispt
 real(pReal),   dimension(ncrd,*),      intent(in) :: &                                             ! according to MSC.Marc 2012 Manual D
   coord
 real(pReal),   dimension(*),           intent(inout) :: &                                          ! according to MSC.Marc 2012 Manual D
   t
 real(pReal),   dimension(ndi+nshear),  intent(out) :: &                                            ! has dimension(*) according to MSC.Marc 2012 Manual D, but we need to loop over it
   s, &                                                                                             !< stress - should be updated by user
   g
 real(pReal),   dimension(ngens,ngens), intent(out) :: &                                            ! according to MSC.Marc 2012 Manual D, but according to example hypela2.f dimension(ngens,*)
   d
 
!--------------------------------------------------------------------------------------------------
! Marc common blocks are in fixed format so they have to be reformated to free format (f90)
! Beware of changes in newer Marc versions
 
 
 
 
 logical :: cutBack
 real(pReal), dimension(6) ::   stress
 real(pReal), dimension(6,6) :: ddsdde
 integer :: computationMode, i, cp_en, node, CPnodeID
 !$ integer(4) :: defaultNumThreadsInt                                                              !< default value set by Marc
 
 if (iand(debug_level(debug_marc),debug_levelbasic) /= 0) then
   write(6,'(a,/,i8,i8,i2)') ' MSC.MARC information on shape of element(2), IP:', m, nn
   write(6,'(a,2(i1))')      ' Jacobian:                      ', ngens,ngens
   write(6,'(a,i1)')         ' Direct stress:                 ', ndi
   write(6,'(a,i1)')         ' Shear stress:                  ', nshear
   write(6,'(a,i2)')         ' DoF:                           ', ndeg
   write(6,'(a,i2)')         ' Coordinates:                   ', ncrd
   write(6,'(a,i12)')        ' Nodes:                         ', nnode
   write(6,'(a,i1)')         ' Deformation gradient:          ', itel
   write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') ' Deformation gradient at t=n:', &
                                 transpose(ffn)
   write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') ' Deformation gradient at t=n+1:', &
                                 transpose(ffn1)
 endif
 
 !$ defaultNumThreadsInt = omp_get_num_threads()                                                    ! remember number of threads set by Marc
 
 if (.not. cpfem_init_done) call cpfem_initall(m(1),nn)
 
 !$ call omp_set_num_threads(DAMASK_NumThreadsInt)                                                  ! set number of threads for parallel execution set by DAMASK_NUM_THREADS
 
 computationmode = 0                                                                                ! save initialization value, since it does not result in any calculation
 if (lovl == 4 ) then                                                                               ! jacobian requested by marc
   if (timinc < thedelta .and. theinc == inc .and. lastlovl /= lovl) &                              ! first after cutback
     computationmode = cpfem_restorejacobian
 elseif (lovl == 6) then                                                                            ! stress requested by marc
   cp_en = mesh_fem2damask_elem(m(1))
   if (cptim > thetime .or. inc /= theinc) then                                                     ! reached "convergence"
     terminallyill = .false.
     cyclecounter = -1                                                                              ! first calc step increments this to cycle = 0
     if (inc == 0) then                                                                             ! >> start of analysis <<
       lastincconverged = .false.                                                                   ! no Jacobian backup
       outdatedbynewinc = .false.                                                                   ! no aging of state
       calcmode = .false.                                                                           ! pretend last step was collection
       lastlovl = lovl                                                                              ! pretend that this is NOT the first after a lovl change
       write(6,'(a,i6,1x,i2)') '<< HYPELA2 >> start of analysis..! ',m(1),nn
       flush(6)
     else if (inc - theinc > 1) then                                                                ! >> restart of broken analysis <<
       lastincconverged = .false.                                                                   ! no Jacobian backup
       outdatedbynewinc = .false.                                                                   ! no aging of state
       calcmode = .true.                                                                            ! pretend last step was calculation
       write(6,'(a,i6,1x,i2)') '<< HYPELA2 >> restart of analysis..! ',m(1),nn
       flush(6)
     else                                                                                           ! >> just the next inc <<
       lastincconverged = .true.                                                                    ! request Jacobian backup
       outdatedbynewinc = .true.                                                                    ! request aging of state
       calcmode = .true.                                                                            ! assure last step was calculation
       write(6,'(a,i6,1x,i2)') '<< HYPELA2 >> new increment..! ',m(1),nn
       flush(6)
     endif
   else if ( timinc < thedelta ) then                                                               ! >> cutBack <<
     lastincconverged = .false.                                                                     ! no Jacobian backup
     outdatedbynewinc = .false.                                                                     ! no aging of state
     terminallyill = .false.
     cyclecounter = -1                                                                              ! first calc step increments this to cycle = 0
     calcmode = .true.                                                                              ! pretend last step was calculation
     write(6,'(a,i6,1x,i2)') '<< HYPELA2 >> cutback detected..! ',m(1),nn
     flush(6)
   endif                                                                                            ! convergence treatment end
 
 
   if (usepingpong) then
     calcmode(nn,cp_en) = .not. calcmode(nn,cp_en)                                                  ! ping pong (calc <--> collect)
     if (calcmode(nn,cp_en)) then                                                                   ! now --- CALC ---
       computationmode = cpfem_calcresults
       if (lastlovl /= lovl) then                                                                   ! first after ping pong
         call debug_reset()                                                                         ! resets debugging
         outdatedffn1  = .false.
         cyclecounter  = cyclecounter + 1
         !mesh_cellnode = mesh_build_cellnodes()                                                     ! update cell node coordinates
         !call mesh_build_ipCoordinates()                                                            ! update ip coordinates
       endif
       if (outdatedbynewinc) then
         computationmode = ior(computationmode,cpfem_ageresults)                                    ! calc and age results
         outdatedbynewinc = .false.                                                                 ! reset flag
       endif
     else                                                                                           ! now --- COLLECT ---
       computationmode = cpfem_collect                                                              ! plain collect
       if (lastlovl /= lovl .and. & .not. terminallyill) &
         call debug_info()                                                                          ! first after ping pong reports (meaningful) debugging
       if (lastincconverged) then
         computationmode = ior(computationmode,cpfem_backupjacobian)                                ! collect and backup Jacobian after convergence
         lastincconverged = .false.                                                                 ! reset flag
       endif
       !do node = 1,theMesh%elem%nNodes
         !CPnodeID = mesh_element(4+node,cp_en)
         !mesh_node(1:ndeg,CPnodeID) = mesh_node0(1:ndeg,CPnodeID) + numerics_unitlength * dispt(1:ndeg,node)
       !enddo
     endif
 
   else                                                                                             ! --- PLAIN MODE ---
     computationmode = cpfem_calcresults                                                            ! always calc
     if (lastlovl /= lovl) then
       if (.not. terminallyill) &
         call debug_info()                                                                          ! first reports (meaningful) debugging
       call debug_reset()                                                                           ! and resets debugging
       outdatedffn1  = .false.
       cyclecounter  = cyclecounter + 1
       !mesh_cellnode = mesh_build_cellnodes()                                                       ! update cell node coordinates
       !call mesh_build_ipCoordinates()                                                              ! update ip coordinates
     endif
     if (outdatedbynewinc) then
       computationmode = ior(computationmode,cpfem_ageresults)
       outdatedbynewinc = .false.                                                                   ! reset flag
     endif
     if (lastincconverged) then
       computationmode = ior(computationmode,cpfem_backupjacobian)                                  ! backup Jacobian after convergence
       lastincconverged = .false.                                                                   ! reset flag
     endif
   endif
 
   thetime  = cptim                                                                                 ! record current starting time
   thedelta = timinc                                                                                ! record current time increment
   theinc   = inc                                                                                   ! record current increment number
 
 endif
 lastlovl = lovl                                                                                    ! record lovl
 
 call cpfem_general(computationmode,usepingpong,ffn,ffn1,t(1),timinc,m(1),nn,stress,ddsdde)
 
 d = ddsdde(1:ngens,1:ngens)
 s = stress(1:ndi+nshear)
 g = 0.0_preal
 if(symmetricsolver) d = 0.5_preal*(d+transpose(d))
 
 !$ call omp_set_num_threads(defaultNumThreadsInt)                                                  ! reset number of threads to stored default value
 
end subroutine hypela2
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
subroutine flux(f,ts,n,time)
  use prec
  use thermal_conduction
  use discretization_marc
 
  implicit none
  real(pReal), dimension(6),           intent(in) :: &
    ts
  integer,     dimension(10),          intent(in) :: &
    n
  real(pReal),                         intent(in) :: &
    time
  real(pReal), dimension(2),           intent(out) :: &
    f
 
  call thermal_conduction_getsourceanditstangent(f(1), f(2), ts(3), n(3),mesh_fem2damask_elem(n(1)))
 
 end subroutine flux
 
 
!--------------------------------------------------------------------------------------------------
! same increment multiple times.
!--------------------------------------------------------------------------------------------------
subroutine uedinc(inc,incsub)
  use prec
  use cpfem
 
  implicit none
  integer, intent(in) :: inc, incsub
  integer, save :: inc_written
 
 
  if (inc > inc_written) then
    call cpfem_results(inc,cptim)
    inc_written = inc
  endif
 
end subroutine uedinc