diff --git a/trunk/CPFEM_GIA8.f90 b/trunk/CPFEM_GIA8.f90
index 891e29024..8d36ff87b 100644
--- a/trunk/CPFEM_GIA8.f90
+++ b/trunk/CPFEM_GIA8.f90
@@ -78,7 +78,8 @@
  enddo
 !
 !    *** Output to MARC output file ***
-!$OMP CRITICAL (write2out)
+!$OMP CRITICAL (write2out)
+
  write(6,*)
  write(6,*) 'CPFEM Initialization'
  write(6,*)
@@ -99,7 +100,8 @@
  write(6,*) 'GIA_bNorm:           ', shape(GIA_bNorm)
  write(6,*)
  call flush(6)
-!$OMP END CRITICAL (write2out)
+!$OMP END CRITICAL (write2out)
+
  return
 !
  END SUBROUTINE
@@ -158,28 +160,28 @@
  endif
 !
  cp_en = mesh_FEasCP('elem',CPFEM_en)
-  if (cp_en == 1 .and. CPFEM_in == 1) then
-!$OMP CRITICAL (write2out)
+  if (cp_en == 1 .and. CPFEM_in == 1) then
+!$OMP CRITICAL (write2out)
     write(6,'(a6,x,i4,x,a4,x,i4,x,a10,x,f8.4,x,a10,x,i2,x,a10,x,i2,x,a10,x,i2,x,a10,x,i2)') &
     'elem',cp_en,'IP',CPFEM_in,&
     'theTime',theTime,'theInc',theInc,'theCycle',theCycle,'theLovl',theLovl,&
     'mode',CPFEM_mode
-!$OMP END CRITICAL (write2out)
-  endif
+!$OMP END CRITICAL (write2out)
+  endif
 !
  select case (CPFEM_mode)
     case (2,1)     ! regular computation (with aging of results)
        if (.not. CPFEM_calc_done) then                ! puuh, me needs doing all the work...
-!$OMP CRITICAL (write2out)
+!$OMP CRITICAL (write2out)
            write (6,*) 'puuh me needs doing all the work', cp_en
-!$OMP END CRITICAL (write2out)
+!$OMP END CRITICAL (write2out)
            if (CPFEM_mode == 1) then                  ! age results at start of new increment
              CPFEM_Fp_old            = CPFEM_Fp_new
              constitutive_state_old  = constitutive_state_new
              GIA_rVect_old           = GIA_rVect_new
-!$OMP CRITICAL (write2out)
+!$OMP CRITICAL (write2out)
              write (6,*) '#### aged results'
-!$OMP END CRITICAL (write2out)
+!$OMP END CRITICAL (write2out)
            endif
            debug_cutbackDistribution = 0_pInt         ! initialize debugging data
            debug_InnerLoopDistribution = 0_pInt
@@ -195,9 +197,9 @@
            CPFEM_calc_done = .true.                   ! now calc is done
          endif    
 !       translate from P and dP/dF to CS and dCS/dE
-!!$OMP CRITICAL (evilmatmul)
+!!$OMP CRITICAL (evilmatmul)
        Kirchhoff_bar = math_mul33x33(CPFEM_PK1_bar(:,:,CPFEM_in, cp_en),transpose(CPFEM_ffn1_bar(:,:,CPFEM_in, cp_en)))
-!!$OMP END CRITICAL (evilmatmul)
+!!$OMP END CRITICAL (evilmatmul)
        J_inverse  = 1.0_pReal/math_det3x3(CPFEM_ffn1_bar(:,:,CPFEM_in, cp_en))
        CPFEM_stress_bar(1:CPFEM_ngens,CPFEM_in,cp_en) = math_Mandel33to6(J_inverse*Kirchhoff_bar)
 !
@@ -208,8 +210,8 @@
                            math_I3(j,l)*CPFEM_ffn1_bar(i,m,CPFEM_in,cp_en)*CPFEM_PK1_bar(k,m,CPFEM_in,cp_en)) + &
                           0.5_pReal*(math_I3(i,k)*Kirchhoff_bar(j,l) + math_I3(j,l)*Kirchhoff_bar(i,k) + &
                                      math_I3(i,l)*Kirchhoff_bar(j,k) + math_I3(j,k)*Kirchhoff_bar(i,l))
-       forall(i=1:3,j=1:3,k=1:3,l=1:3) &
-          H_bar_sym(i,j,k,l)= 0.25_pReal*(H_bar(i,j,k,l) +H_bar(j,i,k,l) +H_bar(i,j,l,k) +H_bar(j,i,l,k))
+       forall(i=1:3,j=1:3,k=1:3,l=1:3) &
+          H_bar_sym(i,j,k,l)= 0.25_pReal*(H_bar(i,j,k,l) +H_bar(j,i,k,l) +H_bar(i,j,l,k) +H_bar(j,i,l,k))
        CPFEM_jaco_bar(1:CPFEM_ngens,1:CPFEM_ngens,CPFEM_in,cp_en) = math_Mandel3333to66(J_inverse*H_bar)
 !
     case (3)    ! collect and return odd result
@@ -219,7 +221,6 @@
        CPFEM_stress_bar(1:CPFEM_ngens,CPFEM_in,cp_en) = CPFEM_odd_stress
        CPFEM_jaco_bar(1:CPFEM_ngens,1:CPFEM_ngens,CPFEM_in,cp_en) = CPFEM_odd_jacobian*math_identity2nd(CPFEM_ngens)
        CPFEM_calc_done = .false.
-
     case (4)    ! do nothing since we can recycle the former results (MARC specialty)
     case (5)    ! record consistent tangent at beginning of new increment
        CPFEM_jaco_knownGood = CPFEM_jaco_bar
@@ -314,15 +315,15 @@
 ! -------------- grain loop -----------------
    do grain = 1,texture_Ngrains(mesh_element(4,cp_en))
      call SingleCrystallite(msg,PK1(:,:,grain),dPdF(:,:,:,:,grain),&
-                      CPFEM_results(CPFEM_Nresults+1:CPFEM_Nresults+constitutive_Nresults(grain,CPFEM_in,cp_en),&
-                                    grain,CPFEM_in,cp_en),&
+                      CPFEM_results(CPFEM_Nresults+1:CPFEM_Nresults+constitutive_Nresults(grain,CPFEM_in,cp_en),&
+                                    grain,CPFEM_in,cp_en),&
                       Fp1(:,:,grain),Fe1(:,:,grain),state1(:,grain),&   ! output up to here
                       dTime,cp_en,CPFEM_in,grain,.true.,&
                       CPFEM_Temperature(CPFEM_in,cp_en),F1(:,:,grain),F0(:,:,grain),Fp0(:,:,grain),state0(:,grain))
      if (msg /= 'ok') then                    ! solution not reached --> exit NRIteration
-!$OMP CRITICAL (write2out)
+!$OMP CRITICAL (write2out)
        write(6,*) 'GIA: grain loop failed to converge @ EL:',cp_en,' IP:',CPFEM_in
-!$OMP END CRITICAL (write2out)
+!$OMP END CRITICAL (write2out)
        NRconvergent = .false.
        exit NRiteration
      endif
@@ -379,10 +380,10 @@
    enddo
    resNorm = sqrt(resNorm)
 !
-   if (debugger) then
-!$OMP CRITICAL (write2out)
+   if (debugger) then
+!$OMP CRITICAL (write2out)
     write(6,'(x,a,i3,a,i3,a,i3,a,e10.4)')'EL:',cp_en,' IP:',CPFEM_in,' Iter:',NRiter,' RNorm:',resNorm
-!$OMP END CRITICAL (write2out)
+!$OMP END CRITICAL (write2out)
    if (NRiter == 1_pInt) resMax = resNorm
    if ((resNorm < resToler*resMax) .or. (resNorm < resAbsol)) then     ! resNorm < tolerance ===> convergent
      NRconvergent = .true.
@@ -422,9 +423,9 @@
      dvardres = 0.0_pReal
      call math_invert(36,dresdvar,dvardres,dummy,failed)
      if (failed) then
-!$OMP CRITICAL (write2out)
+!$OMP CRITICAL (write2out)
        write(6,*) 'GIA: failed to invert the Jacobian @ EL:',cp_en,' IP:',CPFEM_in
-!$OMP END CRITICAL (write2out)
+!$OMP END CRITICAL (write2out)
        NRconvergent = .false.
        exit NRiteration
      endif
@@ -452,9 +453,9 @@
 !
 ! return to the general subroutine when convergence is not reached
  if (.not. NRconvergent) then
-!$OMP CRITICAL (write2out)
+!$OMP CRITICAL (write2out)
    write(6,'(x,a)') 'GIA: convergence is not reached @ EL:',cp_en,' IP:',CPFEM_in
-!$OMP END CRITICAL (write2out)
+!$OMP END CRITICAL (write2out)
    call IO_error(600)
    return
  endif
@@ -473,13 +474,13 @@
 !   update results plotted in MENTAT
    call math_pDecomposition(Fe1(:,:,grain),U,R,error) ! polar decomposition
    if (error) then
-!$OMP CRITICAL (write2out)
+!$OMP CRITICAL (write2out)
      write(6,*) Fe1(:,:,grain)
      write(6,*) 'polar decomposition'
      write(6,*) 'Grain:             ',grain
      write(6,*) 'Integration point: ',CPFEM_in
      write(6,*) 'Element:           ',mesh_element(1,cp_en)
-!$OMP END CRITICAL (write2out)
+!$OMP END CRITICAL (write2out)
      call IO_error(650)
      return
    endif
@@ -503,15 +504,15 @@
        call GIA_RelaxedDeformation(F1,F1_bar,rx)
        do grain = 1,8
          call SingleCrystallite(msg,PK1(:,:,grain),dPdF(:,:,:,:,grain),&
-                      CPFEM_results(CPFEM_Nresults+1:CPFEM_Nresults+constitutive_Nresults(grain,CPFEM_in,cp_en),&
-                                    grain,CPFEM_in,cp_en),&
+                      CPFEM_results(CPFEM_Nresults+1:CPFEM_Nresults+constitutive_Nresults(grain,CPFEM_in,cp_en),&
+                                    grain,CPFEM_in,cp_en),&
                       Fp1(:,:,grain),Fe1(:,:,grain),state1(:,grain),&   ! output up to here
                       dTime,cp_en,CPFEM_in,grain,.true.,&
                       CPFEM_Temperature(CPFEM_in,cp_en),F1(:,:,grain),F0(:,:,grain),Fp0(:,:,grain),state0(:,grain))
          if (msg /= 'ok') then                    ! solution not reached --> exit NRIteration
-!$OMP CRITICAL (write2out)
+!$OMP CRITICAL (write2out)
            write(6,*) 'GIA: perturbation grain loop failed to converge within allowable step-size'
-!$OMP END CRITICAL (write2out)
+!$OMP END CRITICAL (write2out)
            NRconvergent = .false.
            exit NRPerturbation
          endif
@@ -563,11 +564,11 @@
        enddo
        resNorm = sqrt(resNorm)
 !
-!       if (debugger) then
-!!$OMP CRITICAL (write2out)
+!       if (debugger) then
+!!$OMP CRITICAL (write2out)
 !            write(6,'(x,a,i3,a,i3,a,i3,a,i3,a,e10.4)')'EL = ',cp_en,':IP = ',CPFEM_in,':pert = ',3*(ip-1)+jp,':Iter = ',NRiter,':RNorm = ',resNorm
-!!$OMP END CRITICAL (write2out)
-!       endif
+!!$OMP END CRITICAL (write2out)
+!       endif
        if (NRiter == 1_pInt) resMax = resNorm
        if ((resNorm < resToler*resMax) .or. (resNorm < resAbsol)) then     ! resNorm < tolerance ===> convergent
          NRconvergent = .true.
@@ -607,9 +608,9 @@
          dvardres = 0.0_pReal
          call math_invert(36,dresdvar,dvardres,dummy,failed)
          if (failed) then
-!$OMP CRITICAL (write2out)
+!$OMP CRITICAL (write2out)
            write(6,*) 'GIA: perturbation failed to invert the Jacobian'
-!$OMP END CRITICAL (write2out)
+!$OMP END CRITICAL (write2out)
            NRconvergent = .false.
            exit NRPerturbation
          endif
diff --git a/trunk/CPFEM_Taylor.f90 b/trunk/CPFEM_Taylor.f90
index 2f9b010df..d744f3694 100644
--- a/trunk/CPFEM_Taylor.f90
+++ b/trunk/CPFEM_Taylor.f90
@@ -1,996 +1,996 @@
-!##############################################################
- MODULE CPFEM
-!##############################################################
-!    *** CPFEM engine ***
-!
- use prec, only: pReal,pInt
- implicit none
-!
-! ****************************************************************
-! *** General variables for the material behaviour calculation ***
-! ****************************************************************
- real(pReal), dimension (:,:),          allocatable :: CPFEM_Temperature
- real(pReal), dimension (:,:,:,:),      allocatable :: CPFEM_ffn_bar          !average FFN per IP
- real(pReal), dimension (:,:,:,:,:),    allocatable :: CPFEM_ffn              !individual FFN per grain
- real(pReal), dimension (:,:,:,:),      allocatable :: CPFEM_ffn1_bar         !average FFN1 per IP
- real(pReal), dimension (:,:,:,:,:),    allocatable :: CPFEM_ffn1             !individual FFN1 per grain
- real(pReal), dimension (:,:,:,:),      allocatable :: CPFEM_PK1_bar          !average PK1 per IP
- real(pReal), dimension (:,:,:,:,:),    allocatable :: CPFEM_PK1              !individual PK1 per grain
- real(pReal), dimension (:,:,:,:,:,:),  allocatable :: CPFEM_dPdF_bar         !average dPdF per IP
- real(pReal), dimension (:,:,:,:,:,:),  allocatable :: CPFEM_dPdF_bar_old     !old average dPdF per IP
- real(pReal), dimension (:,:,:,:,:,:,:),allocatable :: CPFEM_dPdF             !individual dPdF per grain
- real(pReal), dimension (:,:,:),        allocatable :: CPFEM_stress_bar
- real(pReal), dimension (:,:,:,:),      allocatable :: CPFEM_jaco_bar
- real(pReal), dimension (:,:,:,:),      allocatable :: CPFEM_jaco_knownGood
- real(pReal), dimension (:,:,:,:),      allocatable :: CPFEM_results
- real(pReal), dimension (:,:,:,:,:),    allocatable :: CPFEM_Lp_old
- real(pReal), dimension (:,:,:,:,:),    allocatable :: CPFEM_Lp_new
- real(pReal), dimension (:,:,:,:,:),    allocatable :: CPFEM_Fp_old
- real(pReal), dimension (:,:,:,:,:),    allocatable :: CPFEM_Fp_new
- real(pReal), dimension (:,:,:,:,:),    allocatable :: CPFEM_Fe1
- real(pReal), dimension (:,:,:,:),      allocatable :: CPFEM_Tstar_v
- real(pReal), parameter :: CPFEM_odd_stress = 1e15_pReal, CPFEM_odd_jacobian = 1e50_pReal
- integer(pInt) :: CPFEM_Nresults   = 4_pInt    ! three Euler angles plus volume fraction
- logical :: CPFEM_init_done    = .false.       ! remember whether init has been done already
- logical :: CPFEM_calc_done    = .false.       ! remember whether first IP has already calced the results
-!
-!    *** Solution at single crystallite level ***
-!
- logical, dimension (:,:,:),allocatable :: crystallite_converged            !individual covergence flag per grain
-!
- CONTAINS
-!
-!*********************************************************
-!***    allocate the arrays defined in module CPFEM    ***
-!***    and initialize them                            ***
-!*********************************************************
- SUBROUTINE CPFEM_init(Temperature)
-!
- use prec
- use math, only: math_EulertoR, math_I3, math_identity2nd
- use mesh
- use constitutive
-!
- implicit none
-!
- real(pReal) Temperature
- integer(pInt) e,i,g
-!
-!    *** mpie.marc parameters ***
- allocate(CPFEM_Temperature(mesh_maxNips,mesh_NcpElems)) ; CPFEM_Temperature = Temperature
- allocate(CPFEM_ffn_bar(3,3,mesh_maxNips,mesh_NcpElems))
- forall(e=1:mesh_NcpElems,i=1:mesh_maxNips) CPFEM_ffn_bar(:,:,i,e)             = math_I3
- allocate(CPFEM_ffn(3,3,constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems))
- forall(g=1:constitutive_maxNgrains,e=1:mesh_NcpElems,i=1:mesh_maxNips) CPFEM_ffn(:,:,g,i,e) = math_I3
- allocate(CPFEM_ffn1_bar(3,3,mesh_maxNips,mesh_NcpElems)) ; CPFEM_ffn1_bar   = CPFEM_ffn_bar
- allocate(CPFEM_ffn1(3,3,constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; CPFEM_ffn1 = CPFEM_ffn
- allocate(CPFEM_PK1_bar(3,3,mesh_maxNips,mesh_NcpElems)) ; CPFEM_PK1_bar    = 0.0_pReal
- allocate(CPFEM_PK1(3,3,constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; CPFEM_PK1 = 0.0_pReal
- allocate(CPFEM_dPdF_bar(3,3,3,3,mesh_maxNips,mesh_NcpElems)) ; CPFEM_dPdF_bar = 0.0_pReal
- allocate(CPFEM_dPdF_bar_old(3,3,3,3,mesh_maxNips,mesh_NcpElems)) ; CPFEM_dPdF_bar_old = 0.0_pReal
- allocate(CPFEM_dPdF(3,3,3,3,constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; CPFEM_dPdF = 0.0_pReal
- allocate(CPFEM_stress_bar(6,mesh_maxNips,mesh_NcpElems)) ;   CPFEM_stress_bar = 0.0_pReal
- allocate(CPFEM_jaco_bar(6,6,mesh_maxNips,mesh_NcpElems)) ;   CPFEM_jaco_bar   = 0.0_pReal
- allocate(CPFEM_jaco_knownGood(6,6,mesh_maxNips,mesh_NcpElems)) ;   CPFEM_jaco_knownGood = 0.0_pReal
-!
-!    *** User defined results !!! MISSING incorporate consti_Nresults ***
- allocate(CPFEM_results(CPFEM_Nresults+constitutive_maxNresults,constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems))
- CPFEM_results = 0.0_pReal
-!
-!    *** Plastic velocity gradient ***
- allocate(CPFEM_Lp_old(3,3,constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; CPFEM_Lp_old = 0.0_pReal
- allocate(CPFEM_Lp_new(3,3,constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; CPFEM_Lp_new = 0.0_pReal
-
-!    *** Plastic deformation gradient at (t=t0) and (t=t1) ***
- allocate(CPFEM_Fp_new(3,3,constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; CPFEM_Fp_new = 0.0_pReal
- allocate(CPFEM_Fp_old(3,3,constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems))
- forall (e=1:mesh_NcpElems,i=1:mesh_maxNips,g=1:constitutive_maxNgrains) &
-   CPFEM_Fp_old(:,:,g,i,e) = math_EulerToR(constitutive_EulerAngles(:,g,i,e))  ! plastic def gradient reflects init orientation
-!    *** Elastic deformation gradient at (t=t1) ***
- allocate(CPFEM_Fe1(3,3,constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; CPFEM_Fe1 = 0.0_pReal
-!    *** Stress vector at (t=t1) ***
- allocate(CPFEM_Tstar_v(6,constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; CPFEM_Tstar_v = 0.0_pReal
-!
-!    *** Output to MARC output file ***
-!$OMP CRITICAL (write2out)
- write(6,*)
- write(6,*) 'CPFEM Initialization'
- write(6,*)
- write(6,*) 'CPFEM_Temperature:    ', shape(CPFEM_Temperature)
- write(6,*) 'CPFEM_ffn_bar:        ', shape(CPFEM_ffn_bar)
- write(6,*) 'CPFEM_ffn:            ', shape(CPFEM_ffn)
- write(6,*) 'CPFEM_ffn1_bar:       ', shape(CPFEM_ffn1_bar)
- write(6,*) 'CPFEM_ffn1:           ', shape(CPFEM_ffn1)
- write(6,*) 'CPFEM_PK1_bar:        ', shape(CPFEM_PK1_bar)
- write(6,*) 'CPFEM_PK1:            ', shape(CPFEM_PK1)
- write(6,*) 'CPFEM_dPdF_bar:       ', shape(CPFEM_dPdF_bar)
- write(6,*) 'CPFEM_dPdF_bar_old:   ', shape(CPFEM_dPdF_bar_old)
- write(6,*) 'CPFEM_dPdF:           ', shape(CPFEM_dPdF)
- write(6,*) 'CPFEM_stress_bar:     ', shape(CPFEM_stress_bar)
- write(6,*) 'CPFEM_jaco_bar:       ', shape(CPFEM_jaco_bar)
- write(6,*) 'CPFEM_jaco_knownGood: ', shape(CPFEM_jaco_knownGood)
- write(6,*) 'CPFEM_results:        ', shape(CPFEM_results)
- write(6,*) 'CPFEM_Lp_old:         ', shape(CPFEM_Lp_old)
- write(6,*) 'CPFEM_Lp_new:         ', shape(CPFEM_Lp_new)
- write(6,*) 'CPFEM_Fp_old:         ', shape(CPFEM_Fp_old)
- write(6,*) 'CPFEM_Fp_new:         ', shape(CPFEM_Fp_new)
- write(6,*) 'CPFEM_Fe1:            ', shape(CPFEM_Fe1)
- write(6,*) 'CPFEM_Tstar_v:        ', shape(CPFEM_Tstar_v)
- write(6,*)
- call flush(6)
-!$OMP END CRITICAL (write2out)
- return
-!
- END SUBROUTINE
-!
-!
-!***********************************************************************
-!***    perform initialization at first call, update variables and   ***
-!***    call the actual material model                               ***
-!
-!     CPFEM_mode             computation mode (regular, collection, recycle)
-!     ffn                    deformation gradient for t=t0
-!     ffn1                   deformation gradient for t=t1
-!     Temperature            temperature
-!     CPFEM_dt               time increment
-!     CPFEM_en               element number
-!     CPFEM_in               intergration point number
-!     CPFEM_stress           stress vector in Mandel notation
-!     CPFEM_updateJaco       flag to initiate computation of Jacobian
-!     CPFEM_jaco             jacobian in Mandel notation
-!     CPFEM_ngens            size of stress strain law
-!***********************************************************************
- SUBROUTINE CPFEM_general(CPFEM_mode, ffn, ffn1, Temperature, CPFEM_dt,&
-                          CPFEM_en, CPFEM_in, CPFEM_stress, CPFEM_updateJaco, CPFEM_jaco, CPFEM_ngens)
-! note: CPFEM_stress = Cauchy stress cs(6) and CPFEM_jaco = Consistent tangent dcs/de
-!
- use prec, only: pReal,pInt
- use FEsolving
- use debug
- use math
- use mesh, only: mesh_init,mesh_FEasCP, mesh_NcpElems, FE_Nips, FE_mapElemtype, mesh_element
- use lattice, only: lattice_init
- use constitutive, only: constitutive_init,constitutive_state_old,constitutive_state_new,material_Cslip_66
- implicit none
-!
- integer(pInt) CPFEM_en, CPFEM_in, cp_en, CPFEM_ngens, i,j,k,l,m,n
- real(pReal), dimension (3,3)        :: ffn,ffn1,Kirchhoff_bar
- real(pReal), dimension (3,3,3,3)    :: H_bar, H_bar_sym
- real(pReal), dimension(CPFEM_ngens) :: CPFEM_stress
- real(pReal), dimension(CPFEM_ngens,CPFEM_ngens) :: CPFEM_jaco, odd_jaco
- real(pReal) Temperature,CPFEM_dt,J_inverse
- integer(pInt) CPFEM_mode               ! 1: regular computation with aged results&
-                                        ! 2: regular computation&
-                                        ! 3: collection of FEM data&
-                                        ! 4: recycling of former results (MARC speciality)&
-                                        ! 5: record tangent from former converged inc&
-                                        ! 6: restore tangent from former converged inc
- logical       CPFEM_updateJaco
-!
- if (.not. CPFEM_init_done) then        ! initialization step (three dimensional stress state check missing?)
-   call math_init()
-   call mesh_init()
-   call lattice_init()
-   call constitutive_init()
-   call crystallite_init()
-   call CPFEM_init(Temperature)			
-   CPFEM_init_done = .true.
- endif
-!
- cp_en = mesh_FEasCP('elem',CPFEM_en)
- if (cp_en == 1 .and. CPFEM_in == 1) then
-!$OMP CRITICAL (write2out)
-    write(6,'(a10,1x,f8.4,1x,a10,1x,i4,1x,a10,1x,i3,1x,a10,1x,i2,x,a10,1x,i2)') &
-    'theTime',theTime,'theInc',theInc,'theCycle',theCycle,'theLovl',theLovl,&
-    'mode',CPFEM_mode
-!$OMP END CRITICAL (write2out)
- endif
-!
- select case (CPFEM_mode)
-    case (2,1)     ! regular computation (with aging of results)
-       if (any(abs(ffn1 - CPFEM_ffn1_bar(:,:,CPFEM_in,cp_en)) > relevantStrain)) then
-           CPFEM_stress_bar(1:CPFEM_ngens,:,:) = CPFEM_odd_stress
-           odd_jaco = CPFEM_odd_jacobian*math_identity2nd(CPFEM_ngens)
-           forall (i=1:mesh_NcpElems, j=1:FE_Nips(mesh_element(2,cp_en))) &
-              CPFEM_jaco_bar(1:CPFEM_ngens,1:CPFEM_ngens,j,i) = odd_jaco
-           outdatedFFN1 = .true.
-           if (.not. CPFEM_calc_done .AND.CPFEM_mode == 1) then
-             CPFEM_Lp_old            = CPFEM_Lp_new
-             CPFEM_Fp_old            = CPFEM_Fp_new
-             constitutive_state_old  = constitutive_state_new
-           endif
-!$OMP CRITICAL (write2out)
-           write(6,*) 'WARNING: FFN1 changed for ip', CPFEM_in, 'of element', cp_en
-!$OMP END CRITICAL (write2out)
-           return
-       else
-         if (.not. CPFEM_calc_done) then                ! puuh, me needs doing all the work...
-           if (CPFEM_mode == 1) then                  ! age results at start of new increment
-             CPFEM_Lp_old            = CPFEM_Lp_new
-             CPFEM_Fp_old            = CPFEM_Fp_new
-             constitutive_state_old  = constitutive_state_new
-           endif
-           debug_cutbackDistribution   = 0_pInt       ! initialize debugging data
-           debug_InnerLoopDistribution = 0_pInt
-           debug_OuterLoopDistribution = 0_pInt
-!
-!******************************************************************************************************
-! parallelization moved down to material point and single crystallite
-!******************************************************************************************************
-!!$OMP PARALLEL DO
-!           do e=1,mesh_NcpElems                       ! ## this shall be done in a parallel loop in the future ##
-!               do i=1,FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
-!                  debugger = (e==1 .and. i==1)        ! switch on debugging for first IP in first element
-                  call CPFEM_MaterialPoint(CPFEM_updateJaco, CPFEM_dt, 0, 0)
-!               enddo
-!           enddo
-!!$OMP END PARALLEL DO
-           call debug_info()                          ! output of debugging/performance statistics
-           CPFEM_calc_done = .true.                   ! now calc is done
-         endif    
-!       translate from P and dP/dF to CS and dCS/dE
-!!$OMP CRITICAL (evilmatmul)
-         Kirchhoff_bar = math_mul33x33(CPFEM_PK1_bar(:,:,CPFEM_in, cp_en),transpose(CPFEM_ffn1_bar(:,:,CPFEM_in, cp_en)))
-!!$OMP END CRITICAL (evilmatmul)
-         J_inverse  = 1.0_pReal/math_det3x3(CPFEM_ffn1_bar(:,:,CPFEM_in, cp_en))
-         CPFEM_stress_bar(1:CPFEM_ngens,CPFEM_in,cp_en) = math_Mandel33to6(J_inverse*Kirchhoff_bar)
-!
-         H_bar = 0.0_pReal
-         forall(i=1:3,j=1:3,k=1:3,l=1:3,m=1:3,n=1:3) &
-           H_bar(i,j,k,l) = H_bar(i,j,k,l) + &
-                          CPFEM_ffn1_bar(j,m,CPFEM_in,cp_en) * &
-                          CPFEM_ffn1_bar(l,n,CPFEM_in,cp_en) * &
-                          CPFEM_dPdF_bar(i,m,k,n,CPFEM_in,cp_en) - &
-                          math_I3(j,l)*CPFEM_ffn1_bar(i,m,CPFEM_in,cp_en)*CPFEM_PK1_bar(k,m,CPFEM_in,cp_en) + &
-                          0.5_pReal*(math_I3(i,k)*Kirchhoff_bar(j,l) + math_I3(j,l)*Kirchhoff_bar(i,k) + &
-                                     math_I3(i,l)*Kirchhoff_bar(j,k) + math_I3(j,k)*Kirchhoff_bar(i,l))
-         forall(i=1:3,j=1:3,k=1:3,l=1:3) &
-            H_bar_sym(i,j,k,l)= 0.25_pReal*(H_bar(i,j,k,l) +H_bar(j,i,k,l) +H_bar(i,j,l,k) +H_bar(j,i,l,k))
-         CPFEM_jaco_bar(1:CPFEM_ngens,1:CPFEM_ngens,CPFEM_in,cp_en) = math_Mandel3333to66(J_inverse*H_bar)
-! if (CPFEM_in==8 .and. cp_en==80) then
-!   do e=1,80
-!       do i=1,8
-!       write(6,*)
-!       write(6,*) e, i
-!       write(6,*) CPFEM_stress_bar(1:CPFEM_ngens,i,e)
-!       write(6,*)
-!       write(6,*) CPFEM_jaco_bar(1:CPFEM_ngens,1:CPFEM_ngens,i,e)
-!       enddo
-!   enddo
-! endif
-!
-      endif
-    case (3)    ! collect and return odd result
-       CPFEM_Temperature(CPFEM_in,cp_en)  = Temperature
-       CPFEM_ffn_bar(:,:,CPFEM_in,cp_en)  = ffn
-       CPFEM_ffn1_bar(:,:,CPFEM_in,cp_en) = ffn1
-       CPFEM_stress_bar(1:CPFEM_ngens,CPFEM_in,cp_en) = CPFEM_odd_stress
-       CPFEM_jaco_bar(1:CPFEM_ngens,1:CPFEM_ngens,CPFEM_in,cp_en) = CPFEM_odd_jacobian*math_identity2nd(CPFEM_ngens)
-       CPFEM_calc_done = .false.
-! if (CPFEM_in==8 .and. cp_en==80) then
-!   do e=1,80
-!       do i=1,8
-!       write(6,*)
-!       write(6,*) e, i
-!       write(6,*) ffn1
-!       enddo
-!   enddo
-! endif
-
-    case (4)    ! do nothing since we can recycle the former results (MARC specialty)
-    case (5)    ! record consistent tangent at beginning of new increment
-       CPFEM_jaco_knownGood = CPFEM_jaco_bar
-    case (6)    ! restore consistent tangent after cutback
-       CPFEM_jaco_bar = CPFEM_jaco_knownGood
- end select
-!
-! return the local stress and the jacobian from storage
- CPFEM_stress(1:CPFEM_ngens) = CPFEM_stress_bar(1:CPFEM_ngens,CPFEM_in,cp_en)
- CPFEM_jaco(1:CPFEM_ngens,1:CPFEM_ngens) = CPFEM_jaco_bar(1:CPFEM_ngens,1:CPFEM_ngens,CPFEM_in,cp_en)
-!
- return
-!
- END SUBROUTINE
-!
-!
-!**********************************************************
-!***      calculate the material point behaviour        ***
-!**********************************************************
- SUBROUTINE CPFEM_MaterialPoint(&
-     updateJaco,&     ! flag to initiate Jacobian updating
-     CPFEM_dt,&       ! Time increment (dt)
-     CPFEM_in,&       ! Integration point number
-     cp_en)           ! Element number
-!
- use prec
- use FEsolving, only: theCycle
- use debug
- use math, only: math_pDecomposition,math_RtoEuler,inDeg,math_I3,math_invert3x3,math_permut,math_invert,math_delta
- use IO,   only: IO_error
- use mesh, only: mesh_element, mesh_NcpElems, FE_Nips
-! use crystallite
- use constitutive
- implicit none
-!
- integer(pInt) cp_en,CPFEM_in,g,i,e
- integer(pInt) el_start, el_end, ip_start, ip_end
- logical updateJaco,error
- real(pReal) CPFEM_dt,volfrac
- real(pReal), dimension(3,3)        :: U,R !,Fe1
-! real(pReal), dimension(3,3)        :: PK1
-! real(pReal), dimension(3,3,3,3)    :: dPdF,dPdF_bar_old
-!
- CPFEM_PK1_bar = 0.0_pReal                         ! zero out average first PK stress
-!initialize element loop
- if (cp_en /= 0_pInt) then
-    el_start = cp_en
-    el_end = cp_en
- else
-    el_start = 1_pInt
-    el_end = mesh_NcpElems
- endif
-! prescribe FFN and FFN1 depending on homogenization scheme
-!$OMP PARALLEL DO
- do e=el_start,el_end
-    if(CPFEM_in /= 0_pInt) then
-        ip_start = CPFEM_in
-        ip_end = CPFEM_in
-    else
-        ip_start = 1
-        ip_end = FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
-    endif
-    do i=ip_start,ip_end
-        do g=1,texture_Ngrains(mesh_element(4,e))
-            CPFEM_ffn(:,:,g,i,e) = CPFEM_ffn_bar(:,:,i,e)    !Taylor homogenization
-            CPFEM_ffn1(:,:,g,i,e) = CPFEM_ffn1_bar(:,:,i,e)  !Taylor homogenization
-        end do
-    end do
- end do
-!$OMP END PARALLEL DO
-! calculate stress, update state and update jacobian in case needed for all or one ip
- if (updateJaco) then
-   CPFEM_dPdF_bar_old = CPFEM_dPdF_bar               ! remember former average consistent tangent
-   CPFEM_dPdF_bar = 0.0_pReal                        ! zero out avg consistent tangent for later assembly
- endif
- call SingleCrystallite(updateJaco,CPFEM_dt,el_start,el_end,CPFEM_in)
-!******************************************************************************************************
-! check convergence of homogenization in case needed
-!******************************************************************************************************
-! calculate average quantities per ip and post results
-!$OMP PARALLEL DO
- do e=el_start,el_end
-    if(CPFEM_in /= 0_pInt) then
-        ip_start = CPFEM_in
-        ip_end = CPFEM_in
-    else
-        ip_start = 1
-        ip_end = FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
-    endif
-    do i=ip_start,ip_end
-        do g=1,texture_Ngrains(mesh_element(4,e))
-            volfrac = constitutive_matVolFrac(g,i,e)*constitutive_texVolFrac(g,i,e)
-            CPFEM_PK1_bar(:,:,i,e) = CPFEM_PK1_bar(:,:,i,e) + volfrac * CPFEM_PK1(:,:,g,i,e)
-            if (updateJaco) CPFEM_dPdF_bar(:,:,:,:,i,e) = &
-                   CPFEM_dPdF_bar(:,:,:,:,i,e) + volfrac * CPFEM_dPdF(:,:,:,:,g,i,e)   ! add up crystallite stiffnesses
-				                                                                       ! (may have "holes" corresponding 
-				                                                                       ! to former avg tangent)
-!   update results plotted in MENTAT
-            call math_pDecomposition(CPFEM_Fe1(:,:,g,i,e),U,R,error) ! polar decomposition
-            if (error) then
-!$OMP CRITICAL (write2out)
-                write(6,*) 'polar decomposition of', CPFEM_Fe1(:,:,g,i,e)
-                write(6,*) 'Grain:             ',g
-                write(6,*) 'Integration point: ',i
-                write(6,*) 'Element:           ',mesh_element(1,e)
-!$OMP END CRITICAL (write2out)
-                call IO_error(650)
-                return
-            endif
-            CPFEM_results(1:3,g,i,e) = math_RtoEuler(transpose(R))*inDeg        ! orientation
-            CPFEM_results(4  ,g,i,e) = volfrac                                  ! volume fraction of orientation
-        end do
-    end do
- end do
-!$OMP END PARALLEL DO
-!
- return
-!
- END SUBROUTINE
-!
-!
-!********************************************************************
-! Initialize crystallite
-!********************************************************************
- subroutine crystallite_init()
- use mesh, only: mesh_maxNips,mesh_NcpElems
- use constitutive, only: constitutive_maxNgrains
-
- implicit none
-
- allocate(crystallite_converged(constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems)); crystallite_converged = .false.
-!
-!    *** Output to MARC output file ***
-!$OMP CRITICAL (write2out)
- write(6,*)
- write(6,*) 'crystallite Initialization'
- write(6,*)
- write(6,*) 'crystallite_converged:      ', shape(crystallite_converged)
- write(6,*)
- call flush(6)
-!$OMP END CRITICAL (write2out)
- return
-!
- end subroutine
-!
-!
-!********************************************************************
-! Calculates the stress and jacobi (if wanted) for all or a single component
-!********************************************************************
- subroutine SingleCrystallite(&
-     updateJaco,& ! update of Jacobian required
-     dt,&         ! time increment
-     el_start,&   ! first element in element loop
-     el_end,&     ! last element in element loop
-     CPFEM_in)    ! IP number
-!
- use prec, only: pReal,pInt,pert_Fg,subStepMin, nCutback
- use debug
- use constitutive
- use mesh, only: mesh_element, FE_Nips
- use math
- use IO,   only: IO_error
-! use CPFEM
-
- implicit none
-!
- logical updateJaco, JacoOK
- real(preal) dt
- real(pReal), dimension(3,3) :: Fg_pert,Lp_pert, P_pert, Fp_pert, Fe_pert
- real(pReal), dimension(6) :: Tstar_v     
- real(pReal), dimension(constitutive_maxNstatevars) :: state_pert
- integer(pInt) el_start, el_end, CPFEM_in, ip_start, ip_end, g, i, e, k, l, iOuter
-!
- crystallite_converged=.true.
-!$OMP PARALLEL DO
-    do e=el_start,el_end
-        if(CPFEM_in /= 0_pInt) then
-            ip_start = CPFEM_in
-            ip_end = CPFEM_in
-        else
-            ip_start = 1
-            ip_end = FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
-        endif
-        do i=ip_start,ip_end
-            do g=1,texture_Ngrains(mesh_element(4,e))
-                crystallite_converged(g,i,e)=.false.
-            end do
-        end do
-    end do
-!$OMP END PARALLEL DO
- constitutive_state_new=constitutive_state_old
- CPFEM_Lp_new = CPFEM_Lp_old
- iOuter = 0_pInt
- do while(any(crystallite_converged(:,:,el_start:el_end))==.false.)
-!$OMP PARALLEL DO
-    do e=el_start,el_end
-        if(CPFEM_in /= 0_pInt) then
-            ip_start = CPFEM_in
-            ip_end = CPFEM_in
-        else
-            ip_start = 1
-            ip_end = FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
-        endif
-        do i=ip_start,ip_end
-            do g=1,texture_Ngrains(mesh_element(4,e))
-                if(.not.crystallite_converged(g,i,e))&
-                    call IntegrateStress(CPFEM_Tstar_v(:,g,i,e), CPFEM_PK1(:,:,g,i,e), CPFEM_ffn1(:,:,g,i,e),&
-                     CPFEM_Fp_new(:,:,g,i,e), CPFEM_Fe1(:,:,g,i,e), CPFEM_Lp_new(:,:,g,i,e),&
-                     constitutive_state_new(:,g,i,e), dt, g, i, e)
-            end do
-        end do
-    end do
-!$OMP END PARALLEL DO
-!$OMP PARALLEL DO
-    do e=el_start,el_end
-        if(CPFEM_in /= 0_pInt) then
-            ip_start = CPFEM_in
-            ip_end = CPFEM_in
-        else
-            ip_start = 1
-            ip_end = FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
-        endif
-        do i=ip_start,ip_end
-            do g=1,texture_Ngrains(mesh_element(4,e))
-                if(.not.crystallite_converged(g,i,e))& 
-                    call UpdateState(CPFEM_Tstar_v(:,g,i,e),constitutive_state_new(:,g,i,e),dt,g,i,e)
-            end do
-        end do
-    end do
-!$OMP END PARALLEL DO
-    iOuter = iOuter + 1_pInt
-    if (iOuter==Nouter) then
-!$OMP CRITICAL (write2out)
-        write (6,*) 'Terminated outer loop at el,ip,grain',e,i,g
-!$OMP CRITICAL (out)
-        debug_OuterLoopDistribution(iOuter) = debug_OuterLoopDistribution(iOuter)+1
-!$OMP END CRITICAL (out)
-        call IO_error(600)
-!$OMP END CRITICAL (write2out)
-    endif
- end do
-!$OMP CRITICAL (out)
- debug_OuterLoopDistribution(iOuter) = debug_OuterLoopDistribution(iOuter)+1
-!$OMP END CRITICAL (out)
-
- if (wantsConstitutiveResults) then                                ! get the post_results upon request
-!$OMP PARALLEL DO
-    do e=el_start,el_end
-        if(CPFEM_in /= 0_pInt) then
-            ip_start = CPFEM_in
-            ip_end = CPFEM_in
-        else
-            ip_start = 1
-            ip_end = FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
-        endif
-        do i=ip_start,ip_end
-            do g=1,texture_Ngrains(mesh_element(4,e))
-                CPFEM_results(CPFEM_Nresults+1:CPFEM_Nresults+constitutive_Nresults(g,i,e),g,i,e) =&
-                 constitutive_post_results(CPFEM_Tstar_v(:,g,i,e),constitutive_state_new(:,g,i,e),&
-                 CPFEM_Temperature(i,e),dt,g,i,e)
-            end do
-        end do
-    end do
-!$OMP END PARALLEL DO
- endif
-!
-!***** Calculate Jacobian *****
- if(updateJaco) then
-    if (debugger) then
-!$OMP CRITICAL (write2out)
-        write (6,*) 'Jacobian calc'
-!$OMP END CRITICAL (write2out)
-    endif   
-!    crystallite_converged=.false.
-!$OMP PARALLEL DO
-    do e=el_start,el_end
-        if(CPFEM_in /= 0_pInt) then
-            ip_start = CPFEM_in
-            ip_end = CPFEM_in
-        else
-            ip_start = 1
-            ip_end = FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
-        endif
-        do i=ip_start,ip_end
-            do g=1,texture_Ngrains(mesh_element(4,e))
-                do k=1,3
-                    do l=1,3
-                        crystallite_converged(g,i,e)=.false.
-                        JacoOK=.true.
-                        Fg_pert = CPFEM_ffn1(:,:,g,i,e)                                   ! initialize perturbed Fg
-                        Fg_pert(k,l) = Fg_pert(k,l) + pert_Fg                             ! perturb single component
-                        Lp_pert = CPFEM_Lp_new(:,:,g,i,e)                                 ! initialize Lp
-                        Fp_pert = CPFEM_Fp_new(:,:,g,i,e)                                 ! initialize Fp
-                        state_pert = constitutive_state_new(:,g,i,e)                      ! initial guess from end of time step
-                        iOuter=0_pInt
-                        do while(.not.crystallite_converged(g,i,e))
-                            call IntegrateStress(Tstar_v, P_pert, Fg_pert, Fp_pert, Fe_pert, Lp_pert, state_pert, dt, g, i, e)
-                            call UpdateState(Tstar_v,state_pert,dt,g,i,e)
-                            iOuter = iOuter + 1_pInt
-                            if (iOuter==Nouter) then
-                                JacoOK=.false.
-                                exit
-                            endif
-                        end do
-!$OMP CRITICAL (out)
-                        debug_OuterLoopDistribution(iOuter) = debug_OuterLoopDistribution(iOuter)+1
-!$OMP END CRITICAL (out)
-                        if (JacoOK) &
-                        CPFEM_dPdF(:,:,k,l,g,i,e) = (P_pert-CPFEM_PK1(:,:,g,i,e))/pert_Fg ! constructing tangent dP_ij/dFg_kl only if valid forward difference
-                                                                                          ! otherwise leave component unchanged
-                     end do
-                end do
-            end do
-        end do
-    end do
-!$OMP END PARALLEL DO
- endif
-!
- return
-!
- end subroutine
-!
-!********************************************************************
-! Update the state for a single component
-!********************************************************************
- subroutine UpdateState(&
-   Tstar_v,&        ! stress
-   state,&          ! state  
-   dt,&             ! time increment
-   g,&              ! grain number
-   i,&              ! integration point number
-   e&               ! element number
- )
- use prec, only: pReal,pInt,reltol_Outer
- use constitutive, only: constitutive_dotState, constitutive_state_old, constitutive_Nstatevars
-! use CPFEM, only: CPFEM_Temperature
-!
- integer(pInt) g, i, e
- real(pReal), dimension(6) :: Tstar_v
- real(pReal), dimension(constitutive_Nstatevars(g, i, e)) :: state, ROuter
- real(pReal) dt
-!
- ROuter = state - constitutive_state_old(:,g,i,e) - &
-                dt*constitutive_dotState(Tstar_v,state,CPFEM_Temperature(i,e),&
-                                         g,i,e)          ! residuum from evolution of microstructure
- state = state - ROuter                                           ! update of microstructure
- if (maxval(abs(ROuter/state),state /= 0.0_pReal) < reltol_Outer) crystallite_converged(g,i,e) = .true.
-!
- return
-!
- end subroutine
-!
-!
-!********************************************************************
-! Calculates the stress for a single component
-!********************************************************************
-!***********************************************************************
-!***     calculation of stress (P), stiffness (dPdF),                ***
-!***     and announcment of any                  ***
-!***     acceleration of the Newton-Raphson correction               ***
-!***********************************************************************
- subroutine IntegrateStress(&
-     Tstar_v,&    ! Stress vector
-     P,&          ! first PK stress
-     Fg_new,&     ! new global deformation gradient
-     Fp_new,&     ! new plastic deformation gradient
-     Fe_new,&     ! new "elastic" deformation gradient
-     Lp,&         ! plastic velocity gradient
-     state_new,&  ! new state variable array
-     dt,&         ! time increment
-     g,&          ! grain number
-     i,&          ! integration point number
-     e)           ! element number
-
-!     post_results,& ! plot results from constitutive model
-!     Fp_new,&     ! new plastic deformation gradient
-!     updateJaco,& ! update of Jacobian required
-!     Temperature,& ! temperature of crystallite
-!     Fg_old,&     ! old global deformation gradient
-!     Fp_old,&     ! old plastic deformation gradient
-!     state_old)   ! old state variable array
-!
- use prec, only: pReal,pInt,pert_Fg,subStepMin, nCutback
- use debug
- use constitutive, only: constitutive_Nstatevars,constitutive_Nresults,constitutive_state_old
- use math
-! use CPFEM
-!
- implicit none
-!
- character(len=128) msg
- logical error,success
- integer(pInt) e,i,g, nCutbacks, maxCutbacks
- real(pReal) Temperature
- real(pReal) dt,dt_aim,subFrac,subStep,det
- real(pReal), dimension(3,3)     :: Lp,Lp_interpolated,inv
- real(pReal), dimension(3,3)     :: Fg_current,Fg_new,Fg_aim,deltaFg
- real(pReal), dimension(3,3)     :: Fp_current,Fp_new
- real(pReal), dimension(3,3)     :: Fe_current,Fe_new
- real(pReal), dimension(3,3)     :: P
- real(pReal), dimension(6) :: Tstar_v
- real(pReal), dimension(constitutive_Nstatevars(g,i,e)) :: state_new
-! real(pReal), dimension(constitutive_Nstatevars(g,i,e)) :: state_current
-! 
-! debugger= e==1.and.i==1
- deltaFg = Fg_new - CPFEM_ffn(:,:,g,i,e)
- subFrac = 0.0_pReal
- subStep = 1.0_pReal
- nCutbacks = 0_pInt
- maxCutbacks = 0_pInt
- Fg_current = CPFEM_ffn(:,:,g,i,e)                                 ! initialize to start of inc
- Fp_current = CPFEM_Fp_old(:,:,g,i,e)
- call math_invert3x3(Fp_current,inv,det,error)
- Fe_current = math_mul33x33(Fg_current,inv)
-! state_current = state_new
- success = .false.                                                 ! pretend cutback
- dt_aim = 0.0_pReal                                                ! prevent initial Lp interpolation
- Temperature=CPFEM_Temperature(i,e)
-! 
-! begin the cutback loop
- do while (subStep > subStepMin)                                   ! continue until finished or too much cut backing
-   if (success) then                                               ! wind forward
-     Fg_current = Fg_aim
-     Fe_current = Fe_new
-     Fp_current = Fp_new
-!     state_current = state_new
-   elseif (dt_aim > 0.0_pReal) then
-     call math_invert3x3(Fg_aim,inv,det,error)                     !  inv of Fg_aim
-     Lp_interpolated = 0.5_pReal*Lp + &
-                       0.5_pReal*(math_I3 -  math_mul33x33(Fp_current,&
-                                  math_mul33x33(inv,Fe_current)))/dt_aim  ! interpolate Lp  and L
-     if (debugger) then
-!$OMP CRITICAL (write2out)
-       write (6,*) 'Lp interpolation'
-       write (6,'(a,/,3(3(f12.7,x)/))') 'from',Lp(1:3,:)
-       write (6,'(a,/,3(3(f12.7,x)/))') 'to',Lp_interpolated(1:3,:)
-!$OMP END CRITICAL (write2out)
-     endif
-     Lp = Lp_interpolated
-   endif
-!
-   Fg_aim = Fg_current + subStep*deltaFg                           ! aim for Fg
-   dt_aim = subStep*dt                                             ! aim for dt
-   if (debugger) then
-!$OMP CRITICAL (write2out)
-     write (6,*) 'using these values'
-!     write (6,'(a,/,3(4(f9.3,x)/))') 'state current / MPa',state_current/1e6_pReal
-     write (6,'(a,/,3(4(f9.3,x)/))') 'state new / MPa',state_new/1e6_pReal
-     write (6,'(a,/,3(3(f12.7,x)/))') 'Fe current',Fe_current(1:3,:)
-     write (6,'(a,/,3(3(f12.7,x)/))') 'Fp current',Fp_current(1:3,:)
-     write (6,'(a,/,3(3(f12.7,x)/))') 'Lp (old=new guess)',Lp(1:3,:)
-     write (6,'(a20,f,x,a2,x,f)') 'integrating from ',subFrac,'to',(subFrac+subStep)
-!$OMP END CRITICAL (write2out)
-   endif
-!
-   call TimeIntegration(msg,Lp,Fp_new,Fe_new,Tstar_v,P,state_new,dt_aim,e,i,g,Temperature,Fg_aim,Fp_current)
-!
-
-   if (msg == 'ok') then
-     subFrac = subFrac + subStep
-     subStep = min(1.0_pReal-subFrac, subStep*2.0_pReal) ! accelerate
-     nCutbacks = 0_pInt                   ! reset cutback counter
-     success = .true.                     ! keep current Lp
-   else
-     nCutbacks = nCutbacks + 1            ! record additional cutback
-     maxCutbacks = max(nCutbacks,maxCutbacks)! remember maximum number of cutbacks
-     subStep = subStep / 2.0_pReal        ! cut time step in half
-     success = .false.                    ! force Lp interpolation
-!     if (debugger) then
-!$OMP CRITICAL (write2out)
-       write (6,*) '>>>>>>>>>>>>>>>>>>>> cutback <<<<<<<<<<<<<<<<<<<<<<'
-       write (6,*) 'Element, Ip:', e, i
-       write (6,*) msg
-!$OMP END CRITICAL (write2out)
-!     endif
-!
-   endif
- enddo  ! potential substepping
-!
-!$OMP CRITICAL (cutback)
- debug_cutbackDistribution(min(nCutback,maxCutbacks)+1) = debug_cutbackDistribution(min(nCutback,maxCutbacks)+1)+1
-!$OMP END CRITICAL (cutback)
-!
-! debugger = .false.
- return
- end subroutine
-
-!
-!***********************************************************************
-!***     fully-implicit two-level time integration                   ***
-!***     based on a residuum in Lp and intermediate                  ***
-!***     acceleration of the Newton-Raphson correction               ***
-!***********************************************************************
- SUBROUTINE TimeIntegration(&
-     msg,&              ! return message
-     Lpguess,&          ! guess of plastic velocity gradient
-     Fp_new,&           ! new plastic deformation gradient
-     Fe_new,&           ! new "elastic" deformation gradient
-     Tstar_v,&          ! Stress vector
-     P,&                ! 1nd PK stress (taken as initial guess if /= 0)
-     state,&            ! current microstructure at end of time inc (taken as guess if /= 0)
-     dt,&               ! time increment
-     cp_en,&            ! element number
-     ip,&               ! integration point number
-     grain,&            ! grain number
-     Temperature,&      ! temperature
-     Fg_new,&           ! new total def gradient
-     Fp_old)            ! former plastic def gradient
-!     state_current)         ! former microstructure
- use prec
- use debug
- use mesh, only: mesh_element
- use constitutive, only: constitutive_Nstatevars,constitutive_Microstructure,&
-                         constitutive_homogenizedC,constitutive_LpAndItsTangent
- use math
- use IO
- implicit none
-!
- character(len=*) msg
- logical failed
- integer(pInt) cp_en, ip, grain
- integer(pInt) iInner,dummy, i,j,k,l,m,n
- real(pReal) dt, Temperature, det, p_hydro, leapfrog,maxleap
- real(pReal), dimension(6) :: Tstar_v
- real(pReal), dimension(9,9) :: dLp,dTdLp,dRdLp,invdRdLp,eye2
- real(pReal), dimension(6,6) :: C_66
- real(pReal), dimension(3,3) :: Fg_new,Fp_new,invFp_new,Fp_old,invFp_old,Fe_new
- real(pReal), dimension(3,3) :: P !,Tstar
- real(pReal), dimension(3,3) :: Lp,Lpguess,Lpguess_old,Rinner,Rinner_old,A,B,BT,AB,BTA
- real(pReal), dimension(3,3,3,3) :: C
- real(pReal), dimension(constitutive_Nstatevars(grain, ip, cp_en)) :: state
-!
- msg = 'ok'  ! error-free so far
- eye2 = math_identity2nd(9)
-
- call math_invert3x3(Fp_old,invFp_old,det,failed) ! inversion of Fp_old
- if (failed) then
-    msg = 'inversion Fp_old'
-    return
- endif
-
- A = math_mul33x33(transpose(invFp_old), math_mul33x33(transpose(Fg_new),math_mul33x33(Fg_new,invFp_old)))
-!
-! if (all(state == 0.0_pReal)) state = state_current ! former state guessed, if none specified
-! iOuter = 0_pInt                                    ! outer counter
-!
- if (debugger) then
-!$OMP CRITICAL (write2out)
-   write (6,'(a,/,3(3(f12.7,x)/))') 'Fg to be calculated',Fg_new
-!$OMP END CRITICAL (write2out)
- endif
-!
-!Outer: do                ! outer iteration: State
-!         iOuter = iOuter+1
-!         if (debugger) then
-!!$OMP CRITICAL (write2out)
-!           write (6,'(a,i3)') '---outer ',iOuter
-!           write (6,'(a,/,3(4(f9.3,x)/))') 'state old / MPa',state_old/1e6_pReal
-!           write (6,'(a,/,3(4(f9.3,x)/))') 'state / MPa',state/1e6_pReal
-!           write (6,'(a,/,3(3(f12.7,x)/))') 'Lpguess',Lpguess(1:3,:)
-!!$OMP END CRITICAL (write2out)
-!         endif
-!
-!         if (iOuter > nOuter) then
-!           msg = 'limit Outer iteration'
-!!$OMP CRITICAL (out)
-!           debug_OuterLoopDistribution(nOuter) = debug_OuterLoopDistribution(nOuter)+1
-!!$OMP END CRITICAL (out)
-!           return
-!         endif
-         call constitutive_Microstructure(state,Temperature,grain,ip,cp_en)
-         C_66 = constitutive_HomogenizedC(state, grain, ip, cp_en)
-         C = math_Mandel66to3333(C_66)       ! 4th rank elasticity tensor
-!
-         iInner = 0_pInt
-         leapfrog = 1.0_pReal                ! correction as suggested by invdRdLp-step
-         maxleap = 1024.0_pReal              ! preassign maximum acceleration level
-!
-		 Lpguess_old = Lpguess               ! consider present Lpguess good
-!
-Inner: do              ! inner iteration: Lp
-         iInner = iInner+1
-!         if (debugger) then
-!!$OMP CRITICAL (write2out)
-!           write (6,'(a,i3)') 'inner ',iInner
-!		   if (iInner < 3) then
-!             write (6,'(a,/,3(3(f12.7,x)/))') 'Lpguess',Lpguess(1:3,:)
-!		   endif
-!!$OMP END CRITICAL (write2out)
-!         endif
-         if (iInner > nInner) then           ! too many loops required
-           Lpguess = Lpguess_old             ! do not trust the last update but resort to former one
-           msg = 'limit Inner iteration'
-!$OMP CRITICAL (in)
-           debug_InnerLoopDistribution(nInner) = debug_InnerLoopDistribution(nInner)+1
-!$OMP END CRITICAL (in)
-           return
-         endif
-!
-         B = math_i3 - dt*Lpguess
-         BT = transpose(B)
-         AB = math_mul33x33(A,B)
-         BTA = math_mul33x33(BT,A)
-         Tstar_v = 0.5_pReal*math_mul66x6(C_66,math_mandel33to6(math_mul33x33(BT,AB)-math_I3))
-!         Tstar = math_Mandel6to33(Tstar_v)
-         p_hydro=(Tstar_v(1)+Tstar_v(2)+Tstar_v(3))/3.0_pReal
-         forall(i=1:3) Tstar_v(i) = Tstar_v(i)-p_hydro                ! subtract hydrostatic pressure
-         call constitutive_LpAndItsTangent(Lp,dLp, &
-                                           Tstar_v,state,Temperature,grain,ip,cp_en)
-!			    
-         Rinner = Lpguess - Lp                                        ! update current residuum
-!
-         if (.not.(any(Rinner/=Rinner)) .and. &                       ! exclude any NaN in residuum
-             ( (maxval(abs(Rinner)) < abstol_Inner) .or. &            ! below abs tol .or.
-               ( any(abs(dt*Lpguess) > relevantStrain) .and. &        ! worth checking? .and.
-                 maxval(abs(Rinner/Lpguess),abs(dt*Lpguess) > relevantStrain) < reltol_Inner &  ! below rel tol
-               ) &
-             )   &
-            )    &
-            exit Inner                                                ! convergence
-!
-!          check for acceleration/deceleration in Newton--Raphson correction
-!
-         if (any(Rinner/=Rinner) .and. &                              ! NaN occured at regular speed
-		     leapfrog == 1.0) then
-			Lpguess = Lpguess_old                                     ! restore known good guess
-		    msg = 'NaN present'                                       ! croak for cutback
-			return
-
-         elseif (leapfrog > 1.0_pReal .and. &                         ! at fast pace ?
-             (sum(Rinner*Rinner) > sum(Rinner_old*Rinner_old) .or. &  ! worse residuum
-              sum(Rinner*Rinner_old) < 0.0_pReal) .or. &              ! residuum changed sign (overshoot)
-			  any(Rinner/=Rinner) ) then                              ! NaN
-           maxleap = 0.5_pReal * leapfrog                             ! limit next acceleration
-           leapfrog = 1.0_pReal                                       ! grinding halt
-
-         else                                                         ! better residuum
-           dTdLp = 0.0_pReal                                          ! calc dT/dLp
-           forall (i=1:3,j=1:3,k=1:3,l=1:3,m=1:3,n=1:3) &
-             dTdLp(3*(i-1)+j,3*(k-1)+l) = dTdLp(3*(i-1)+j,3*(k-1)+l) + &
-             C(i,j,l,n)*AB(k,n)+C(i,j,m,l)*BTA(m,k)
-           dTdLp = -0.5_pReal*dt*dTdLp
-           dRdLp = eye2 - math_mul99x99(dLp,dTdLp)                    ! calc dR/dLp
-           invdRdLp = 0.0_pReal
-           call math_invert(9,dRdLp,invdRdLp,dummy,failed)            ! invert dR/dLp --> dLp/dR
-           if (failed) then
-             msg = 'inversion dR/dLp'
-               if (debugger) then
-!$OMP CRITICAL (write2out)
-                 write (6,*) msg
-                 write (6,'(a,/,9(9(e9.3,x)/))') 'dRdLp', dRdLp(1:9,:)
-                 write (6,'(a,/,3(4(f9.3,x)/))') 'state / MPa',state/1e6_pReal
-                 write (6,'(a,/,3(3(f12.7,x)/))') 'Lpguess',Lpguess(1:3,:)
-                 write (6,'(a,/,3(3(e12.7,x)/))') 'Lp',Lp(1:3,:)
-                 write (6,'(a,/,6(f9.3,x))') 'Tstar / MPa',Tstar_v/1e6_pReal
-!$OMP END CRITICAL (write2out)
-               endif 
-             return
-           endif
-!
-           Rinner_old = Rinner                                        ! remember current residuum
-           Lpguess_old = Lpguess                                      ! remember current Lp guess 
-           if (iInner > 1 .and. leapfrog < maxleap) &
-		     leapfrog = 2.0_pReal * leapfrog                          ! accelerate if ok
-         endif
-!
-         Lpguess = Lpguess_old                                        ! start from current guess                                       
-         Rinner  = Rinner_old                                         ! use current residuum
-         forall (i=1:3,j=1:3,k=1:3,l=1:3) &                           ! leapfrog to updated Lpguess 
-           Lpguess(i,j) = Lpguess(i,j) - leapfrog*invdRdLp(3*(i-1)+j,3*(k-1)+l)*Rinner(k,l)
-       enddo Inner
-!
-!$OMP CRITICAL (in)
-       debug_InnerLoopDistribution(iInner) = debug_InnerLoopDistribution(iInner)+1
-!$OMP END CRITICAL (in)
-!       ROuter = state - state_old - &
-!                dt*constitutive_dotState(Tstar_v,state,Temperature,&
-!                                         grain,ip,cp_en)          ! residuum from evolution of microstructure
-!       state = state - ROuter                                           ! update of microstructure
-!
-!	   if (iOuter==nOuter) then
-!!$OMP CRITICAL (write2out)
-!	      write (6,*) 'Terminated outer loop at el,ip,grain',cp_en,ip,grain
-!!$OMP END CRITICAL (write2out)
-!	      exit Outer
-!	   endif
-!       if (maxval(abs(Router/state),state /= 0.0_pReal) < reltol_Outer) exit Outer
-!     enddo Outer
-!
-!!$OMP CRITICAL (out)
-! debug_OuterLoopDistribution(iOuter) = debug_OuterLoopDistribution(iOuter)+1
-!!$OMP END CRITICAL (out)
- invFp_new = math_mul33x33(invFp_old,B)
- call math_invert3x3(invFp_new,Fp_new,det,failed)
- if (failed) then
-   msg = 'inversion Fp_new^-1'
-   return
- endif
-!
-! if (wantsConstitutiveResults) then     ! get the post_results upon request
-!   results = 0.0_pReal
-!   results = constitutive_post_results(Tstar_v,state,Temperature,dt,grain,ip,cp_en)
-! endif
-!
- Fp_new = Fp_new*det**(1.0_pReal/3.0_pReal)     ! regularize Fp by det = det(InvFp_new) !!
- forall (i=1:3) Tstar_v(i) = Tstar_v(i)+p_hydro ! add hydrostatic component back
- Fe_new = math_mul33x33(Fg_new,invFp_new)              ! calc resulting Fe
-! P = math_mul33x33(Fe_new,math_mul33x33(Tstar,transpose(invFp_new)))    ! first PK stress
- P = math_mul33x33(Fe_new,math_mul33x33(math_Mandel6to33(Tstar_v),transpose(invFp_new)))    ! first PK stress
-
- return
-!
- END SUBROUTINE
-!
- END MODULE
-!##############################################################
-
+!##############################################################
+ MODULE CPFEM
+!##############################################################
+!    *** CPFEM engine ***
+!
+ use prec, only: pReal,pInt
+ implicit none
+!
+! ****************************************************************
+! *** General variables for the material behaviour calculation ***
+! ****************************************************************
+ real(pReal), dimension (:,:),          allocatable :: CPFEM_Temperature
+ real(pReal), dimension (:,:,:,:),      allocatable :: CPFEM_ffn_bar          !average FFN per IP
+ real(pReal), dimension (:,:,:,:,:),    allocatable :: CPFEM_ffn              !individual FFN per grain
+ real(pReal), dimension (:,:,:,:),      allocatable :: CPFEM_ffn1_bar         !average FFN1 per IP
+ real(pReal), dimension (:,:,:,:,:),    allocatable :: CPFEM_ffn1             !individual FFN1 per grain
+ real(pReal), dimension (:,:,:,:),      allocatable :: CPFEM_PK1_bar          !average PK1 per IP
+ real(pReal), dimension (:,:,:,:,:),    allocatable :: CPFEM_PK1              !individual PK1 per grain
+ real(pReal), dimension (:,:,:,:,:,:),  allocatable :: CPFEM_dPdF_bar         !average dPdF per IP
+ real(pReal), dimension (:,:,:,:,:,:),  allocatable :: CPFEM_dPdF_bar_old     !old average dPdF per IP
+ real(pReal), dimension (:,:,:,:,:,:,:),allocatable :: CPFEM_dPdF             !individual dPdF per grain
+ real(pReal), dimension (:,:,:),        allocatable :: CPFEM_stress_bar
+ real(pReal), dimension (:,:,:,:),      allocatable :: CPFEM_jaco_bar
+ real(pReal), dimension (:,:,:,:),      allocatable :: CPFEM_jaco_knownGood
+ real(pReal), dimension (:,:,:,:),      allocatable :: CPFEM_results
+ real(pReal), dimension (:,:,:,:,:),    allocatable :: CPFEM_Lp_old
+ real(pReal), dimension (:,:,:,:,:),    allocatable :: CPFEM_Lp_new
+ real(pReal), dimension (:,:,:,:,:),    allocatable :: CPFEM_Fp_old
+ real(pReal), dimension (:,:,:,:,:),    allocatable :: CPFEM_Fp_new
+ real(pReal), dimension (:,:,:,:,:),    allocatable :: CPFEM_Fe1
+ real(pReal), dimension (:,:,:,:),      allocatable :: CPFEM_Tstar_v
+ real(pReal), parameter :: CPFEM_odd_stress = 1e15_pReal, CPFEM_odd_jacobian = 1e50_pReal
+ integer(pInt) :: CPFEM_Nresults   = 4_pInt    ! three Euler angles plus volume fraction
+ logical :: CPFEM_init_done    = .false.       ! remember whether init has been done already
+ logical :: CPFEM_calc_done    = .false.       ! remember whether first IP has already calced the results
+!
+!    *** Solution at single crystallite level ***
+!
+ logical, dimension (:,:,:),allocatable :: crystallite_converged            !individual covergence flag per grain
+!
+ CONTAINS
+!
+!*********************************************************
+!***    allocate the arrays defined in module CPFEM    ***
+!***    and initialize them                            ***
+!*********************************************************
+ SUBROUTINE CPFEM_init(Temperature)
+!
+ use prec
+ use math, only: math_EulertoR, math_I3, math_identity2nd
+ use mesh
+ use constitutive
+!
+ implicit none
+!
+ real(pReal) Temperature
+ integer(pInt) e,i,g
+!
+!    *** mpie.marc parameters ***
+ allocate(CPFEM_Temperature(mesh_maxNips,mesh_NcpElems)) ; CPFEM_Temperature = Temperature
+ allocate(CPFEM_ffn_bar(3,3,mesh_maxNips,mesh_NcpElems))
+ forall(e=1:mesh_NcpElems,i=1:mesh_maxNips) CPFEM_ffn_bar(:,:,i,e)             = math_I3
+ allocate(CPFEM_ffn(3,3,constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems))
+ forall(g=1:constitutive_maxNgrains,e=1:mesh_NcpElems,i=1:mesh_maxNips) CPFEM_ffn(:,:,g,i,e) = math_I3
+ allocate(CPFEM_ffn1_bar(3,3,mesh_maxNips,mesh_NcpElems)) ; CPFEM_ffn1_bar   = CPFEM_ffn_bar
+ allocate(CPFEM_ffn1(3,3,constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; CPFEM_ffn1 = CPFEM_ffn
+ allocate(CPFEM_PK1_bar(3,3,mesh_maxNips,mesh_NcpElems)) ; CPFEM_PK1_bar    = 0.0_pReal
+ allocate(CPFEM_PK1(3,3,constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; CPFEM_PK1 = 0.0_pReal
+ allocate(CPFEM_dPdF_bar(3,3,3,3,mesh_maxNips,mesh_NcpElems)) ; CPFEM_dPdF_bar = 0.0_pReal
+ allocate(CPFEM_dPdF_bar_old(3,3,3,3,mesh_maxNips,mesh_NcpElems)) ; CPFEM_dPdF_bar_old = 0.0_pReal
+ allocate(CPFEM_dPdF(3,3,3,3,constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; CPFEM_dPdF = 0.0_pReal
+ allocate(CPFEM_stress_bar(6,mesh_maxNips,mesh_NcpElems)) ;   CPFEM_stress_bar = 0.0_pReal
+ allocate(CPFEM_jaco_bar(6,6,mesh_maxNips,mesh_NcpElems)) ;   CPFEM_jaco_bar   = 0.0_pReal
+ allocate(CPFEM_jaco_knownGood(6,6,mesh_maxNips,mesh_NcpElems)) ;   CPFEM_jaco_knownGood = 0.0_pReal
+!
+!    *** User defined results !!! MISSING incorporate consti_Nresults ***
+ allocate(CPFEM_results(CPFEM_Nresults+constitutive_maxNresults,constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems))
+ CPFEM_results = 0.0_pReal
+!
+!    *** Plastic velocity gradient ***
+ allocate(CPFEM_Lp_old(3,3,constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; CPFEM_Lp_old = 0.0_pReal
+ allocate(CPFEM_Lp_new(3,3,constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; CPFEM_Lp_new = 0.0_pReal
+
+!    *** Plastic deformation gradient at (t=t0) and (t=t1) ***
+ allocate(CPFEM_Fp_new(3,3,constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; CPFEM_Fp_new = 0.0_pReal
+ allocate(CPFEM_Fp_old(3,3,constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems))
+ forall (e=1:mesh_NcpElems,i=1:mesh_maxNips,g=1:constitutive_maxNgrains) &
+   CPFEM_Fp_old(:,:,g,i,e) = math_EulerToR(constitutive_EulerAngles(:,g,i,e))  ! plastic def gradient reflects init orientation
+!    *** Elastic deformation gradient at (t=t1) ***
+ allocate(CPFEM_Fe1(3,3,constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; CPFEM_Fe1 = 0.0_pReal
+!    *** Stress vector at (t=t1) ***
+ allocate(CPFEM_Tstar_v(6,constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems)) ; CPFEM_Tstar_v = 0.0_pReal
+!
+!    *** Output to MARC output file ***
+!$OMP CRITICAL (write2out)
+ write(6,*)
+ write(6,*) 'CPFEM Initialization'
+ write(6,*)
+ write(6,*) 'CPFEM_Temperature:    ', shape(CPFEM_Temperature)
+ write(6,*) 'CPFEM_ffn_bar:        ', shape(CPFEM_ffn_bar)
+ write(6,*) 'CPFEM_ffn:            ', shape(CPFEM_ffn)
+ write(6,*) 'CPFEM_ffn1_bar:       ', shape(CPFEM_ffn1_bar)
+ write(6,*) 'CPFEM_ffn1:           ', shape(CPFEM_ffn1)
+ write(6,*) 'CPFEM_PK1_bar:        ', shape(CPFEM_PK1_bar)
+ write(6,*) 'CPFEM_PK1:            ', shape(CPFEM_PK1)
+ write(6,*) 'CPFEM_dPdF_bar:       ', shape(CPFEM_dPdF_bar)
+ write(6,*) 'CPFEM_dPdF_bar_old:   ', shape(CPFEM_dPdF_bar_old)
+ write(6,*) 'CPFEM_dPdF:           ', shape(CPFEM_dPdF)
+ write(6,*) 'CPFEM_stress_bar:     ', shape(CPFEM_stress_bar)
+ write(6,*) 'CPFEM_jaco_bar:       ', shape(CPFEM_jaco_bar)
+ write(6,*) 'CPFEM_jaco_knownGood: ', shape(CPFEM_jaco_knownGood)
+ write(6,*) 'CPFEM_results:        ', shape(CPFEM_results)
+ write(6,*) 'CPFEM_Lp_old:         ', shape(CPFEM_Lp_old)
+ write(6,*) 'CPFEM_Lp_new:         ', shape(CPFEM_Lp_new)
+ write(6,*) 'CPFEM_Fp_old:         ', shape(CPFEM_Fp_old)
+ write(6,*) 'CPFEM_Fp_new:         ', shape(CPFEM_Fp_new)
+ write(6,*) 'CPFEM_Fe1:            ', shape(CPFEM_Fe1)
+ write(6,*) 'CPFEM_Tstar_v:        ', shape(CPFEM_Tstar_v)
+ write(6,*)
+ call flush(6)
+!$OMP END CRITICAL (write2out)
+ return
+!
+ END SUBROUTINE
+!
+!
+!***********************************************************************
+!***    perform initialization at first call, update variables and   ***
+!***    call the actual material model                               ***
+!
+!     CPFEM_mode             computation mode (regular, collection, recycle)
+!     ffn                    deformation gradient for t=t0
+!     ffn1                   deformation gradient for t=t1
+!     Temperature            temperature
+!     CPFEM_dt               time increment
+!     CPFEM_en               element number
+!     CPFEM_in               intergration point number
+!     CPFEM_stress           stress vector in Mandel notation
+!     CPFEM_updateJaco       flag to initiate computation of Jacobian
+!     CPFEM_jaco             jacobian in Mandel notation
+!     CPFEM_ngens            size of stress strain law
+!***********************************************************************
+ SUBROUTINE CPFEM_general(CPFEM_mode, ffn, ffn1, Temperature, CPFEM_dt,&
+                          CPFEM_en, CPFEM_in, CPFEM_stress, CPFEM_updateJaco, CPFEM_jaco, CPFEM_ngens)
+! note: CPFEM_stress = Cauchy stress cs(6) and CPFEM_jaco = Consistent tangent dcs/de
+!
+ use prec, only: pReal,pInt
+ use FEsolving
+ use debug
+ use math
+ use mesh, only: mesh_init,mesh_FEasCP, mesh_NcpElems, FE_Nips, FE_mapElemtype, mesh_element
+ use lattice, only: lattice_init
+ use constitutive, only: constitutive_init,constitutive_state_old,constitutive_state_new,material_Cslip_66
+ implicit none
+!
+ integer(pInt) CPFEM_en, CPFEM_in, cp_en, CPFEM_ngens, i,j,k,l,m,n
+ real(pReal), dimension (3,3)        :: ffn,ffn1,Kirchhoff_bar
+ real(pReal), dimension (3,3,3,3)    :: H_bar, H_bar_sym
+ real(pReal), dimension(CPFEM_ngens) :: CPFEM_stress
+ real(pReal), dimension(CPFEM_ngens,CPFEM_ngens) :: CPFEM_jaco, odd_jaco
+ real(pReal) Temperature,CPFEM_dt,J_inverse
+ integer(pInt) CPFEM_mode               ! 1: regular computation with aged results&
+                                        ! 2: regular computation&
+                                        ! 3: collection of FEM data&
+                                        ! 4: recycling of former results (MARC speciality)&
+                                        ! 5: record tangent from former converged inc&
+                                        ! 6: restore tangent from former converged inc
+ logical       CPFEM_updateJaco
+!
+ if (.not. CPFEM_init_done) then        ! initialization step (three dimensional stress state check missing?)
+   call math_init()
+   call mesh_init()
+   call lattice_init()
+   call constitutive_init()
+   call crystallite_init()
+   call CPFEM_init(Temperature)			
+   CPFEM_init_done = .true.
+ endif
+!
+ cp_en = mesh_FEasCP('elem',CPFEM_en)
+ if (cp_en == 1 .and. CPFEM_in == 1) then
+!$OMP CRITICAL (write2out)
+    write(6,'(a10,1x,f8.4,1x,a10,1x,i4,1x,a10,1x,i3,1x,a10,1x,i2,x,a10,1x,i2)') &
+    'theTime',theTime,'theInc',theInc,'theCycle',theCycle,'theLovl',theLovl,&
+    'mode',CPFEM_mode
+!$OMP END CRITICAL (write2out)
+ endif
+!
+ select case (CPFEM_mode)
+    case (2,1)     ! regular computation (with aging of results)
+       if (any(abs(ffn1 - CPFEM_ffn1_bar(:,:,CPFEM_in,cp_en)) > relevantStrain)) then
+           CPFEM_stress_bar(1:CPFEM_ngens,:,:) = CPFEM_odd_stress
+           odd_jaco = CPFEM_odd_jacobian*math_identity2nd(CPFEM_ngens)
+           forall (i=1:mesh_NcpElems, j=1:FE_Nips(mesh_element(2,cp_en))) &
+              CPFEM_jaco_bar(1:CPFEM_ngens,1:CPFEM_ngens,j,i) = odd_jaco
+           outdatedFFN1 = .true.
+           if (.not. CPFEM_calc_done .AND.CPFEM_mode == 1) then
+             CPFEM_Lp_old            = CPFEM_Lp_new
+             CPFEM_Fp_old            = CPFEM_Fp_new
+             constitutive_state_old  = constitutive_state_new
+           endif
+!$OMP CRITICAL (write2out)
+           write(6,*) 'WARNING: FFN1 changed for ip', CPFEM_in, 'of element', cp_en
+!$OMP END CRITICAL (write2out)
+           return
+       else
+         if (.not. CPFEM_calc_done) then                ! puuh, me needs doing all the work...
+           if (CPFEM_mode == 1) then                  ! age results at start of new increment
+             CPFEM_Lp_old            = CPFEM_Lp_new
+             CPFEM_Fp_old            = CPFEM_Fp_new
+             constitutive_state_old  = constitutive_state_new
+           endif
+           debug_cutbackDistribution   = 0_pInt       ! initialize debugging data
+           debug_InnerLoopDistribution = 0_pInt
+           debug_OuterLoopDistribution = 0_pInt
+!
+!******************************************************************************************************
+! parallelization moved down to material point and single crystallite
+!******************************************************************************************************
+!!$OMP PARALLEL DO
+!           do e=1,mesh_NcpElems                       ! ## this shall be done in a parallel loop in the future ##
+!               do i=1,FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
+!                  debugger = (e==1 .and. i==1)        ! switch on debugging for first IP in first element
+                  call CPFEM_MaterialPoint(CPFEM_updateJaco, CPFEM_dt, 0, 0)
+!               enddo
+!           enddo
+!!$OMP END PARALLEL DO
+           call debug_info()                          ! output of debugging/performance statistics
+           CPFEM_calc_done = .true.                   ! now calc is done
+         endif    
+!       translate from P and dP/dF to CS and dCS/dE
+!!$OMP CRITICAL (evilmatmul)
+         Kirchhoff_bar = math_mul33x33(CPFEM_PK1_bar(:,:,CPFEM_in, cp_en),transpose(CPFEM_ffn1_bar(:,:,CPFEM_in, cp_en)))
+!!$OMP END CRITICAL (evilmatmul)
+         J_inverse  = 1.0_pReal/math_det3x3(CPFEM_ffn1_bar(:,:,CPFEM_in, cp_en))
+         CPFEM_stress_bar(1:CPFEM_ngens,CPFEM_in,cp_en) = math_Mandel33to6(J_inverse*Kirchhoff_bar)
+!
+         H_bar = 0.0_pReal
+         forall(i=1:3,j=1:3,k=1:3,l=1:3,m=1:3,n=1:3) &
+           H_bar(i,j,k,l) = H_bar(i,j,k,l) + &
+                          CPFEM_ffn1_bar(j,m,CPFEM_in,cp_en) * &
+                          CPFEM_ffn1_bar(l,n,CPFEM_in,cp_en) * &
+                          CPFEM_dPdF_bar(i,m,k,n,CPFEM_in,cp_en) - &
+                          math_I3(j,l)*CPFEM_ffn1_bar(i,m,CPFEM_in,cp_en)*CPFEM_PK1_bar(k,m,CPFEM_in,cp_en) + &
+                          0.5_pReal*(math_I3(i,k)*Kirchhoff_bar(j,l) + math_I3(j,l)*Kirchhoff_bar(i,k) + &
+                                     math_I3(i,l)*Kirchhoff_bar(j,k) + math_I3(j,k)*Kirchhoff_bar(i,l))
+         forall(i=1:3,j=1:3,k=1:3,l=1:3) &
+            H_bar_sym(i,j,k,l)= 0.25_pReal*(H_bar(i,j,k,l) +H_bar(j,i,k,l) +H_bar(i,j,l,k) +H_bar(j,i,l,k))
+         CPFEM_jaco_bar(1:CPFEM_ngens,1:CPFEM_ngens,CPFEM_in,cp_en) = math_Mandel3333to66(J_inverse*H_bar)
+! if (CPFEM_in==8 .and. cp_en==80) then
+!   do e=1,80
+!       do i=1,8
+!       write(6,*)
+!       write(6,*) e, i
+!       write(6,*) CPFEM_stress_bar(1:CPFEM_ngens,i,e)
+!       write(6,*)
+!       write(6,*) CPFEM_jaco_bar(1:CPFEM_ngens,1:CPFEM_ngens,i,e)
+!       enddo
+!   enddo
+! endif
+!
+      endif
+    case (3)    ! collect and return odd result
+       CPFEM_Temperature(CPFEM_in,cp_en)  = Temperature
+       CPFEM_ffn_bar(:,:,CPFEM_in,cp_en)  = ffn
+       CPFEM_ffn1_bar(:,:,CPFEM_in,cp_en) = ffn1
+       CPFEM_stress_bar(1:CPFEM_ngens,CPFEM_in,cp_en) = CPFEM_odd_stress
+       CPFEM_jaco_bar(1:CPFEM_ngens,1:CPFEM_ngens,CPFEM_in,cp_en) = CPFEM_odd_jacobian*math_identity2nd(CPFEM_ngens)
+       CPFEM_calc_done = .false.
+! if (CPFEM_in==8 .and. cp_en==80) then
+!   do e=1,80
+!       do i=1,8
+!       write(6,*)
+!       write(6,*) e, i
+!       write(6,*) ffn1
+!       enddo
+!   enddo
+! endif
+
+    case (4)    ! do nothing since we can recycle the former results (MARC specialty)
+    case (5)    ! record consistent tangent at beginning of new increment
+       CPFEM_jaco_knownGood = CPFEM_jaco_bar
+    case (6)    ! restore consistent tangent after cutback
+       CPFEM_jaco_bar = CPFEM_jaco_knownGood
+ end select
+!
+! return the local stress and the jacobian from storage
+ CPFEM_stress(1:CPFEM_ngens) = CPFEM_stress_bar(1:CPFEM_ngens,CPFEM_in,cp_en)
+ CPFEM_jaco(1:CPFEM_ngens,1:CPFEM_ngens) = CPFEM_jaco_bar(1:CPFEM_ngens,1:CPFEM_ngens,CPFEM_in,cp_en)
+!
+ return
+!
+ END SUBROUTINE
+!
+!
+!**********************************************************
+!***      calculate the material point behaviour        ***
+!**********************************************************
+ SUBROUTINE CPFEM_MaterialPoint(&
+     updateJaco,&     ! flag to initiate Jacobian updating
+     CPFEM_dt,&       ! Time increment (dt)
+     CPFEM_in,&       ! Integration point number
+     cp_en)           ! Element number
+!
+ use prec
+ use FEsolving, only: theCycle
+ use debug
+ use math, only: math_pDecomposition,math_RtoEuler,inDeg,math_I3,math_invert3x3,math_permut,math_invert,math_delta
+ use IO,   only: IO_error
+ use mesh, only: mesh_element, mesh_NcpElems, FE_Nips
+! use crystallite
+ use constitutive
+ implicit none
+!
+ integer(pInt) cp_en,CPFEM_in,g,i,e
+ integer(pInt) el_start, el_end, ip_start, ip_end
+ logical updateJaco,error
+ real(pReal) CPFEM_dt,volfrac
+ real(pReal), dimension(3,3)        :: U,R !,Fe1
+! real(pReal), dimension(3,3)        :: PK1
+! real(pReal), dimension(3,3,3,3)    :: dPdF,dPdF_bar_old
+!
+ CPFEM_PK1_bar = 0.0_pReal                         ! zero out average first PK stress
+!initialize element loop
+ if (cp_en /= 0_pInt) then
+    el_start = cp_en
+    el_end = cp_en
+ else
+    el_start = 1_pInt
+    el_end = mesh_NcpElems
+ endif
+! prescribe FFN and FFN1 depending on homogenization scheme
+!$OMP PARALLEL DO
+ do e=el_start,el_end
+    if(CPFEM_in /= 0_pInt) then
+        ip_start = CPFEM_in
+        ip_end = CPFEM_in
+    else
+        ip_start = 1
+        ip_end = FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
+    endif
+    do i=ip_start,ip_end
+        do g=1,texture_Ngrains(mesh_element(4,e))
+            CPFEM_ffn(:,:,g,i,e) = CPFEM_ffn_bar(:,:,i,e)    !Taylor homogenization
+            CPFEM_ffn1(:,:,g,i,e) = CPFEM_ffn1_bar(:,:,i,e)  !Taylor homogenization
+        end do
+    end do
+ end do
+!$OMP END PARALLEL DO
+! calculate stress, update state and update jacobian in case needed for all or one ip
+ if (updateJaco) then
+   CPFEM_dPdF_bar_old = CPFEM_dPdF_bar               ! remember former average consistent tangent
+   CPFEM_dPdF_bar = 0.0_pReal                        ! zero out avg consistent tangent for later assembly
+ endif
+ call SingleCrystallite(updateJaco,CPFEM_dt,el_start,el_end,CPFEM_in)
+!******************************************************************************************************
+! check convergence of homogenization in case needed
+!******************************************************************************************************
+! calculate average quantities per ip and post results
+!$OMP PARALLEL DO
+ do e=el_start,el_end
+    if(CPFEM_in /= 0_pInt) then
+        ip_start = CPFEM_in
+        ip_end = CPFEM_in
+    else
+        ip_start = 1
+        ip_end = FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
+    endif
+    do i=ip_start,ip_end
+        do g=1,texture_Ngrains(mesh_element(4,e))
+            volfrac = constitutive_matVolFrac(g,i,e)*constitutive_texVolFrac(g,i,e)
+            CPFEM_PK1_bar(:,:,i,e) = CPFEM_PK1_bar(:,:,i,e) + volfrac * CPFEM_PK1(:,:,g,i,e)
+            if (updateJaco) CPFEM_dPdF_bar(:,:,:,:,i,e) = &
+                   CPFEM_dPdF_bar(:,:,:,:,i,e) + volfrac * CPFEM_dPdF(:,:,:,:,g,i,e)   ! add up crystallite stiffnesses
+				                                                                       ! (may have "holes" corresponding 
+				                                                                       ! to former avg tangent)
+!   update results plotted in MENTAT
+            call math_pDecomposition(CPFEM_Fe1(:,:,g,i,e),U,R,error) ! polar decomposition
+            if (error) then
+!$OMP CRITICAL (write2out)
+                write(6,*) 'polar decomposition of', CPFEM_Fe1(:,:,g,i,e)
+                write(6,*) 'Grain:             ',g
+                write(6,*) 'Integration point: ',i
+                write(6,*) 'Element:           ',mesh_element(1,e)
+!$OMP END CRITICAL (write2out)
+                call IO_error(650)
+                return
+            endif
+            CPFEM_results(1:3,g,i,e) = math_RtoEuler(transpose(R))*inDeg        ! orientation
+            CPFEM_results(4  ,g,i,e) = volfrac                                  ! volume fraction of orientation
+        end do
+    end do
+ end do
+!$OMP END PARALLEL DO
+!
+ return
+!
+ END SUBROUTINE
+!
+!
+!********************************************************************
+! Initialize crystallite
+!********************************************************************
+ subroutine crystallite_init()
+ use mesh, only: mesh_maxNips,mesh_NcpElems
+ use constitutive, only: constitutive_maxNgrains
+
+ implicit none
+
+ allocate(crystallite_converged(constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems)); crystallite_converged = .false.
+!
+!    *** Output to MARC output file ***
+!$OMP CRITICAL (write2out)
+ write(6,*)
+ write(6,*) 'crystallite Initialization'
+ write(6,*)
+ write(6,*) 'crystallite_converged:      ', shape(crystallite_converged)
+ write(6,*)
+ call flush(6)
+!$OMP END CRITICAL (write2out)
+ return
+!
+ end subroutine
+!
+!
+!********************************************************************
+! Calculates the stress and jacobi (if wanted) for all or a single component
+!********************************************************************
+ subroutine SingleCrystallite(&
+     updateJaco,& ! update of Jacobian required
+     dt,&         ! time increment
+     el_start,&   ! first element in element loop
+     el_end,&     ! last element in element loop
+     CPFEM_in)    ! IP number
+!
+ use prec, only: pReal,pInt,pert_Fg,subStepMin, nCutback
+ use debug
+ use constitutive
+ use mesh, only: mesh_element, FE_Nips
+ use math
+ use IO,   only: IO_error
+! use CPFEM
+
+ implicit none
+!
+ logical updateJaco, JacoOK
+ real(preal) dt
+ real(pReal), dimension(3,3) :: Fg_pert,Lp_pert, P_pert, Fp_pert, Fe_pert
+ real(pReal), dimension(6) :: Tstar_v     
+ real(pReal), dimension(constitutive_maxNstatevars) :: state_pert
+ integer(pInt) el_start, el_end, CPFEM_in, ip_start, ip_end, g, i, e, k, l, iOuter
+!
+ crystallite_converged=.true.
+!$OMP PARALLEL DO
+    do e=el_start,el_end
+        if(CPFEM_in /= 0_pInt) then
+            ip_start = CPFEM_in
+            ip_end = CPFEM_in
+        else
+            ip_start = 1
+            ip_end = FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
+        endif
+        do i=ip_start,ip_end
+            do g=1,texture_Ngrains(mesh_element(4,e))
+                crystallite_converged(g,i,e)=.false.
+            end do
+        end do
+    end do
+!$OMP END PARALLEL DO
+ constitutive_state_new=constitutive_state_old
+ CPFEM_Lp_new = CPFEM_Lp_old
+ iOuter = 0_pInt
+ do while(any(crystallite_converged(:,:,el_start:el_end))==.false.)
+!$OMP PARALLEL DO
+    do e=el_start,el_end
+        if(CPFEM_in /= 0_pInt) then
+            ip_start = CPFEM_in
+            ip_end = CPFEM_in
+        else
+            ip_start = 1
+            ip_end = FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
+        endif
+        do i=ip_start,ip_end
+            do g=1,texture_Ngrains(mesh_element(4,e))
+                if(.not.crystallite_converged(g,i,e))&
+                    call IntegrateStress(CPFEM_Tstar_v(:,g,i,e), CPFEM_PK1(:,:,g,i,e), CPFEM_ffn1(:,:,g,i,e),&
+                     CPFEM_Fp_new(:,:,g,i,e), CPFEM_Fe1(:,:,g,i,e), CPFEM_Lp_new(:,:,g,i,e),&
+                     constitutive_state_new(:,g,i,e), dt, g, i, e)
+            end do
+        end do
+    end do
+!$OMP END PARALLEL DO
+!$OMP PARALLEL DO
+    do e=el_start,el_end
+        if(CPFEM_in /= 0_pInt) then
+            ip_start = CPFEM_in
+            ip_end = CPFEM_in
+        else
+            ip_start = 1
+            ip_end = FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
+        endif
+        do i=ip_start,ip_end
+            do g=1,texture_Ngrains(mesh_element(4,e))
+                if(.not.crystallite_converged(g,i,e))& 
+                    call UpdateState(CPFEM_Tstar_v(:,g,i,e),constitutive_state_new(:,g,i,e),dt,g,i,e)
+            end do
+        end do
+    end do
+!$OMP END PARALLEL DO
+    iOuter = iOuter + 1_pInt
+    if (iOuter==Nouter) then
+!$OMP CRITICAL (write2out)
+        write (6,*) 'Terminated outer loop at el,ip,grain',e,i,g
+!$OMP CRITICAL (out)
+        debug_OuterLoopDistribution(iOuter) = debug_OuterLoopDistribution(iOuter)+1
+!$OMP END CRITICAL (out)
+        call IO_error(600)
+!$OMP END CRITICAL (write2out)
+    endif
+ end do
+!$OMP CRITICAL (out)
+ debug_OuterLoopDistribution(iOuter) = debug_OuterLoopDistribution(iOuter)+1
+!$OMP END CRITICAL (out)
+
+ if (wantsConstitutiveResults) then                                ! get the post_results upon request
+!$OMP PARALLEL DO
+    do e=el_start,el_end
+        if(CPFEM_in /= 0_pInt) then
+            ip_start = CPFEM_in
+            ip_end = CPFEM_in
+        else
+            ip_start = 1
+            ip_end = FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
+        endif
+        do i=ip_start,ip_end
+            do g=1,texture_Ngrains(mesh_element(4,e))
+                CPFEM_results(CPFEM_Nresults+1:CPFEM_Nresults+constitutive_Nresults(g,i,e),g,i,e) =&
+                 constitutive_post_results(CPFEM_Tstar_v(:,g,i,e),constitutive_state_new(:,g,i,e),&
+                 CPFEM_Temperature(i,e),dt,g,i,e)
+            end do
+        end do
+    end do
+!$OMP END PARALLEL DO
+ endif
+!
+!***** Calculate Jacobian *****
+ if(updateJaco) then
+    if (debugger) then
+!$OMP CRITICAL (write2out)
+        write (6,*) 'Jacobian calc'
+!$OMP END CRITICAL (write2out)
+    endif   
+!    crystallite_converged=.false.
+!$OMP PARALLEL DO
+    do e=el_start,el_end
+        if(CPFEM_in /= 0_pInt) then
+            ip_start = CPFEM_in
+            ip_end = CPFEM_in
+        else
+            ip_start = 1
+            ip_end = FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
+        endif
+        do i=ip_start,ip_end
+            do g=1,texture_Ngrains(mesh_element(4,e))
+                do k=1,3
+                    do l=1,3
+                        crystallite_converged(g,i,e)=.false.
+                        JacoOK=.true.
+                        Fg_pert = CPFEM_ffn1(:,:,g,i,e)                                   ! initialize perturbed Fg
+                        Fg_pert(k,l) = Fg_pert(k,l) + pert_Fg                             ! perturb single component
+                        Lp_pert = CPFEM_Lp_new(:,:,g,i,e)                                 ! initialize Lp
+                        Fp_pert = CPFEM_Fp_new(:,:,g,i,e)                                 ! initialize Fp
+                        state_pert = constitutive_state_new(:,g,i,e)                      ! initial guess from end of time step
+                        iOuter=0_pInt
+                        do while(.not.crystallite_converged(g,i,e))
+                            call IntegrateStress(Tstar_v, P_pert, Fg_pert, Fp_pert, Fe_pert, Lp_pert, state_pert, dt, g, i, e)
+                            call UpdateState(Tstar_v,state_pert,dt,g,i,e)
+                            iOuter = iOuter + 1_pInt
+                            if (iOuter==Nouter) then
+                                JacoOK=.false.
+                                exit
+                            endif
+                        end do
+!$OMP CRITICAL (out)
+                        debug_OuterLoopDistribution(iOuter) = debug_OuterLoopDistribution(iOuter)+1
+!$OMP END CRITICAL (out)
+                        if (JacoOK) &
+                        CPFEM_dPdF(:,:,k,l,g,i,e) = (P_pert-CPFEM_PK1(:,:,g,i,e))/pert_Fg ! constructing tangent dP_ij/dFg_kl only if valid forward difference
+                                                                                          ! otherwise leave component unchanged
+                     end do
+                end do
+            end do
+        end do
+    end do
+!$OMP END PARALLEL DO
+ endif
+!
+ return
+!
+ end subroutine
+!
+!********************************************************************
+! Update the state for a single component
+!********************************************************************
+ subroutine UpdateState(&
+   Tstar_v,&        ! stress
+   state,&          ! state  
+   dt,&             ! time increment
+   g,&              ! grain number
+   i,&              ! integration point number
+   e&               ! element number
+ )
+ use prec, only: pReal,pInt,reltol_Outer
+ use constitutive, only: constitutive_dotState, constitutive_state_old, constitutive_Nstatevars
+! use CPFEM, only: CPFEM_Temperature
+!
+ integer(pInt) g, i, e
+ real(pReal), dimension(6) :: Tstar_v
+ real(pReal), dimension(constitutive_Nstatevars(g, i, e)) :: state, ROuter
+ real(pReal) dt
+!
+ ROuter = state - constitutive_state_old(:,g,i,e) - &
+                dt*constitutive_dotState(Tstar_v,state,CPFEM_Temperature(i,e),&
+                                         g,i,e)          ! residuum from evolution of microstructure
+ state = state - ROuter                                           ! update of microstructure
+ if (maxval(abs(ROuter/state),state /= 0.0_pReal) < reltol_Outer) crystallite_converged(g,i,e) = .true.
+!
+ return
+!
+ end subroutine
+!
+!
+!********************************************************************
+! Calculates the stress for a single component
+!********************************************************************
+!***********************************************************************
+!***     calculation of stress (P), stiffness (dPdF),                ***
+!***     and announcment of any                  ***
+!***     acceleration of the Newton-Raphson correction               ***
+!***********************************************************************
+ subroutine IntegrateStress(&
+     Tstar_v,&    ! Stress vector
+     P,&          ! first PK stress
+     Fg_new,&     ! new global deformation gradient
+     Fp_new,&     ! new plastic deformation gradient
+     Fe_new,&     ! new "elastic" deformation gradient
+     Lp,&         ! plastic velocity gradient
+     state_new,&  ! new state variable array
+     dt,&         ! time increment
+     g,&          ! grain number
+     i,&          ! integration point number
+     e)           ! element number
+
+!     post_results,& ! plot results from constitutive model
+!     Fp_new,&     ! new plastic deformation gradient
+!     updateJaco,& ! update of Jacobian required
+!     Temperature,& ! temperature of crystallite
+!     Fg_old,&     ! old global deformation gradient
+!     Fp_old,&     ! old plastic deformation gradient
+!     state_old)   ! old state variable array
+!
+ use prec, only: pReal,pInt,pert_Fg,subStepMin, nCutback
+ use debug
+ use constitutive, only: constitutive_Nstatevars,constitutive_Nresults,constitutive_state_old
+ use math
+! use CPFEM
+!
+ implicit none
+!
+ character(len=128) msg
+ logical error,success
+ integer(pInt) e,i,g, nCutbacks, maxCutbacks
+ real(pReal) Temperature
+ real(pReal) dt,dt_aim,subFrac,subStep,det
+ real(pReal), dimension(3,3)     :: Lp,Lp_interpolated,inv
+ real(pReal), dimension(3,3)     :: Fg_current,Fg_new,Fg_aim,deltaFg
+ real(pReal), dimension(3,3)     :: Fp_current,Fp_new
+ real(pReal), dimension(3,3)     :: Fe_current,Fe_new
+ real(pReal), dimension(3,3)     :: P
+ real(pReal), dimension(6) :: Tstar_v
+ real(pReal), dimension(constitutive_Nstatevars(g,i,e)) :: state_new
+! real(pReal), dimension(constitutive_Nstatevars(g,i,e)) :: state_current
+! 
+! debugger= e==1.and.i==1
+ deltaFg = Fg_new - CPFEM_ffn(:,:,g,i,e)
+ subFrac = 0.0_pReal
+ subStep = 1.0_pReal
+ nCutbacks = 0_pInt
+ maxCutbacks = 0_pInt
+ Fg_current = CPFEM_ffn(:,:,g,i,e)                                 ! initialize to start of inc
+ Fp_current = CPFEM_Fp_old(:,:,g,i,e)
+ call math_invert3x3(Fp_current,inv,det,error)
+ Fe_current = math_mul33x33(Fg_current,inv)
+! state_current = state_new
+ success = .false.                                                 ! pretend cutback
+ dt_aim = 0.0_pReal                                                ! prevent initial Lp interpolation
+ Temperature=CPFEM_Temperature(i,e)
+! 
+! begin the cutback loop
+ do while (subStep > subStepMin)                                   ! continue until finished or too much cut backing
+   if (success) then                                               ! wind forward
+     Fg_current = Fg_aim
+     Fe_current = Fe_new
+     Fp_current = Fp_new
+!     state_current = state_new
+   elseif (dt_aim > 0.0_pReal) then
+     call math_invert3x3(Fg_aim,inv,det,error)                     !  inv of Fg_aim
+     Lp_interpolated = 0.5_pReal*Lp + &
+                       0.5_pReal*(math_I3 -  math_mul33x33(Fp_current,&
+                                  math_mul33x33(inv,Fe_current)))/dt_aim  ! interpolate Lp  and L
+     if (debugger) then
+!$OMP CRITICAL (write2out)
+       write (6,*) 'Lp interpolation'
+       write (6,'(a,/,3(3(f12.7,x)/))') 'from',Lp(1:3,:)
+       write (6,'(a,/,3(3(f12.7,x)/))') 'to',Lp_interpolated(1:3,:)
+!$OMP END CRITICAL (write2out)
+     endif
+     Lp = Lp_interpolated
+   endif
+!
+   Fg_aim = Fg_current + subStep*deltaFg                           ! aim for Fg
+   dt_aim = subStep*dt                                             ! aim for dt
+   if (debugger) then
+!$OMP CRITICAL (write2out)
+     write (6,*) 'using these values'
+!     write (6,'(a,/,3(4(f9.3,x)/))') 'state current / MPa',state_current/1e6_pReal
+     write (6,'(a,/,3(4(f9.3,x)/))') 'state new / MPa',state_new/1e6_pReal
+     write (6,'(a,/,3(3(f12.7,x)/))') 'Fe current',Fe_current(1:3,:)
+     write (6,'(a,/,3(3(f12.7,x)/))') 'Fp current',Fp_current(1:3,:)
+     write (6,'(a,/,3(3(f12.7,x)/))') 'Lp (old=new guess)',Lp(1:3,:)
+     write (6,'(a20,f,x,a2,x,f)') 'integrating from ',subFrac,'to',(subFrac+subStep)
+!$OMP END CRITICAL (write2out)
+   endif
+!
+   call TimeIntegration(msg,Lp,Fp_new,Fe_new,Tstar_v,P,state_new,dt_aim,e,i,g,Temperature,Fg_aim,Fp_current)
+!
+
+   if (msg == 'ok') then
+     subFrac = subFrac + subStep
+     subStep = min(1.0_pReal-subFrac, subStep*2.0_pReal) ! accelerate
+     nCutbacks = 0_pInt                   ! reset cutback counter
+     success = .true.                     ! keep current Lp
+   else
+     nCutbacks = nCutbacks + 1            ! record additional cutback
+     maxCutbacks = max(nCutbacks,maxCutbacks)! remember maximum number of cutbacks
+     subStep = subStep / 2.0_pReal        ! cut time step in half
+     success = .false.                    ! force Lp interpolation
+!     if (debugger) then
+!$OMP CRITICAL (write2out)
+       write (6,*) '>>>>>>>>>>>>>>>>>>>> cutback <<<<<<<<<<<<<<<<<<<<<<'
+       write (6,*) 'Element, Ip:', e, i
+       write (6,*) msg
+!$OMP END CRITICAL (write2out)
+!     endif
+!
+   endif
+ enddo  ! potential substepping
+!
+!$OMP CRITICAL (cutback)
+ debug_cutbackDistribution(min(nCutback,maxCutbacks)+1) = debug_cutbackDistribution(min(nCutback,maxCutbacks)+1)+1
+!$OMP END CRITICAL (cutback)
+!
+! debugger = .false.
+ return
+ end subroutine
+
+!
+!***********************************************************************
+!***     fully-implicit two-level time integration                   ***
+!***     based on a residuum in Lp and intermediate                  ***
+!***     acceleration of the Newton-Raphson correction               ***
+!***********************************************************************
+ SUBROUTINE TimeIntegration(&
+     msg,&              ! return message
+     Lpguess,&          ! guess of plastic velocity gradient
+     Fp_new,&           ! new plastic deformation gradient
+     Fe_new,&           ! new "elastic" deformation gradient
+     Tstar_v,&          ! Stress vector
+     P,&                ! 1nd PK stress (taken as initial guess if /= 0)
+     state,&            ! current microstructure at end of time inc (taken as guess if /= 0)
+     dt,&               ! time increment
+     cp_en,&            ! element number
+     ip,&               ! integration point number
+     grain,&            ! grain number
+     Temperature,&      ! temperature
+     Fg_new,&           ! new total def gradient
+     Fp_old)            ! former plastic def gradient
+!     state_current)         ! former microstructure
+ use prec
+ use debug
+ use mesh, only: mesh_element
+ use constitutive, only: constitutive_Nstatevars,constitutive_Microstructure,&
+                         constitutive_homogenizedC,constitutive_LpAndItsTangent
+ use math
+ use IO
+ implicit none
+!
+ character(len=*) msg
+ logical failed
+ integer(pInt) cp_en, ip, grain
+ integer(pInt) iInner,dummy, i,j,k,l,m,n
+ real(pReal) dt, Temperature, det, p_hydro, leapfrog,maxleap
+ real(pReal), dimension(6) :: Tstar_v
+ real(pReal), dimension(9,9) :: dLp,dTdLp,dRdLp,invdRdLp,eye2
+ real(pReal), dimension(6,6) :: C_66
+ real(pReal), dimension(3,3) :: Fg_new,Fp_new,invFp_new,Fp_old,invFp_old,Fe_new
+ real(pReal), dimension(3,3) :: P !,Tstar
+ real(pReal), dimension(3,3) :: Lp,Lpguess,Lpguess_old,Rinner,Rinner_old,A,B,BT,AB,BTA
+ real(pReal), dimension(3,3,3,3) :: C
+ real(pReal), dimension(constitutive_Nstatevars(grain, ip, cp_en)) :: state
+!
+ msg = 'ok'  ! error-free so far
+ eye2 = math_identity2nd(9)
+
+ call math_invert3x3(Fp_old,invFp_old,det,failed) ! inversion of Fp_old
+ if (failed) then
+    msg = 'inversion Fp_old'
+    return
+ endif
+
+ A = math_mul33x33(transpose(invFp_old), math_mul33x33(transpose(Fg_new),math_mul33x33(Fg_new,invFp_old)))
+!
+! if (all(state == 0.0_pReal)) state = state_current ! former state guessed, if none specified
+! iOuter = 0_pInt                                    ! outer counter
+!
+ if (debugger) then
+!$OMP CRITICAL (write2out)
+   write (6,'(a,/,3(3(f12.7,x)/))') 'Fg to be calculated',Fg_new
+!$OMP END CRITICAL (write2out)
+ endif
+!
+!Outer: do                ! outer iteration: State
+!         iOuter = iOuter+1
+!         if (debugger) then
+!!$OMP CRITICAL (write2out)
+!           write (6,'(a,i3)') '---outer ',iOuter
+!           write (6,'(a,/,3(4(f9.3,x)/))') 'state old / MPa',state_old/1e6_pReal
+!           write (6,'(a,/,3(4(f9.3,x)/))') 'state / MPa',state/1e6_pReal
+!           write (6,'(a,/,3(3(f12.7,x)/))') 'Lpguess',Lpguess(1:3,:)
+!!$OMP END CRITICAL (write2out)
+!         endif
+!
+!         if (iOuter > nOuter) then
+!           msg = 'limit Outer iteration'
+!!$OMP CRITICAL (out)
+!           debug_OuterLoopDistribution(nOuter) = debug_OuterLoopDistribution(nOuter)+1
+!!$OMP END CRITICAL (out)
+!           return
+!         endif
+         call constitutive_Microstructure(state,Temperature,grain,ip,cp_en)
+         C_66 = constitutive_HomogenizedC(state, grain, ip, cp_en)
+         C = math_Mandel66to3333(C_66)       ! 4th rank elasticity tensor
+!
+         iInner = 0_pInt
+         leapfrog = 1.0_pReal                ! correction as suggested by invdRdLp-step
+         maxleap = 1024.0_pReal              ! preassign maximum acceleration level
+!
+		 Lpguess_old = Lpguess               ! consider present Lpguess good
+!
+Inner: do              ! inner iteration: Lp
+         iInner = iInner+1
+!         if (debugger) then
+!!$OMP CRITICAL (write2out)
+!           write (6,'(a,i3)') 'inner ',iInner
+!		   if (iInner < 3) then
+!             write (6,'(a,/,3(3(f12.7,x)/))') 'Lpguess',Lpguess(1:3,:)
+!		   endif
+!!$OMP END CRITICAL (write2out)
+!         endif
+         if (iInner > nInner) then           ! too many loops required
+           Lpguess = Lpguess_old             ! do not trust the last update but resort to former one
+           msg = 'limit Inner iteration'
+!$OMP CRITICAL (in)
+           debug_InnerLoopDistribution(nInner) = debug_InnerLoopDistribution(nInner)+1
+!$OMP END CRITICAL (in)
+           return
+         endif
+!
+         B = math_i3 - dt*Lpguess
+         BT = transpose(B)
+         AB = math_mul33x33(A,B)
+         BTA = math_mul33x33(BT,A)
+         Tstar_v = 0.5_pReal*math_mul66x6(C_66,math_mandel33to6(math_mul33x33(BT,AB)-math_I3))
+!         Tstar = math_Mandel6to33(Tstar_v)
+         p_hydro=(Tstar_v(1)+Tstar_v(2)+Tstar_v(3))/3.0_pReal
+         forall(i=1:3) Tstar_v(i) = Tstar_v(i)-p_hydro                ! subtract hydrostatic pressure
+         call constitutive_LpAndItsTangent(Lp,dLp, &
+                                           Tstar_v,state,Temperature,grain,ip,cp_en)
+!			    
+         Rinner = Lpguess - Lp                                        ! update current residuum
+!
+         if (.not.(any(Rinner/=Rinner)) .and. &                       ! exclude any NaN in residuum
+             ( (maxval(abs(Rinner)) < abstol_Inner) .or. &            ! below abs tol .or.
+               ( any(abs(dt*Lpguess) > relevantStrain) .and. &        ! worth checking? .and.
+                 maxval(abs(Rinner/Lpguess),abs(dt*Lpguess) > relevantStrain) < reltol_Inner &  ! below rel tol
+               ) &
+             )   &
+            )    &
+            exit Inner                                                ! convergence
+!
+!          check for acceleration/deceleration in Newton--Raphson correction
+!
+         if (any(Rinner/=Rinner) .and. &                              ! NaN occured at regular speed
+		     leapfrog == 1.0) then
+			Lpguess = Lpguess_old                                     ! restore known good guess
+		    msg = 'NaN present'                                       ! croak for cutback
+			return
+
+         elseif (leapfrog > 1.0_pReal .and. &                         ! at fast pace ?
+             (sum(Rinner*Rinner) > sum(Rinner_old*Rinner_old) .or. &  ! worse residuum
+              sum(Rinner*Rinner_old) < 0.0_pReal) .or. &              ! residuum changed sign (overshoot)
+			  any(Rinner/=Rinner) ) then                              ! NaN
+           maxleap = 0.5_pReal * leapfrog                             ! limit next acceleration
+           leapfrog = 1.0_pReal                                       ! grinding halt
+
+         else                                                         ! better residuum
+           dTdLp = 0.0_pReal                                          ! calc dT/dLp
+           forall (i=1:3,j=1:3,k=1:3,l=1:3,m=1:3,n=1:3) &
+             dTdLp(3*(i-1)+j,3*(k-1)+l) = dTdLp(3*(i-1)+j,3*(k-1)+l) + &
+             C(i,j,l,n)*AB(k,n)+C(i,j,m,l)*BTA(m,k)
+           dTdLp = -0.5_pReal*dt*dTdLp
+           dRdLp = eye2 - math_mul99x99(dLp,dTdLp)                    ! calc dR/dLp
+           invdRdLp = 0.0_pReal
+           call math_invert(9,dRdLp,invdRdLp,dummy,failed)            ! invert dR/dLp --> dLp/dR
+           if (failed) then
+             msg = 'inversion dR/dLp'
+               if (debugger) then
+!$OMP CRITICAL (write2out)
+                 write (6,*) msg
+                 write (6,'(a,/,9(9(e9.3,x)/))') 'dRdLp', dRdLp(1:9,:)
+                 write (6,'(a,/,3(4(f9.3,x)/))') 'state / MPa',state/1e6_pReal
+                 write (6,'(a,/,3(3(f12.7,x)/))') 'Lpguess',Lpguess(1:3,:)
+                 write (6,'(a,/,3(3(e12.7,x)/))') 'Lp',Lp(1:3,:)
+                 write (6,'(a,/,6(f9.3,x))') 'Tstar / MPa',Tstar_v/1e6_pReal
+!$OMP END CRITICAL (write2out)
+               endif 
+             return
+           endif
+!
+           Rinner_old = Rinner                                        ! remember current residuum
+           Lpguess_old = Lpguess                                      ! remember current Lp guess 
+           if (iInner > 1 .and. leapfrog < maxleap) &
+		     leapfrog = 2.0_pReal * leapfrog                          ! accelerate if ok
+         endif
+!
+         Lpguess = Lpguess_old                                        ! start from current guess                                       
+         Rinner  = Rinner_old                                         ! use current residuum
+         forall (i=1:3,j=1:3,k=1:3,l=1:3) &                           ! leapfrog to updated Lpguess 
+           Lpguess(i,j) = Lpguess(i,j) - leapfrog*invdRdLp(3*(i-1)+j,3*(k-1)+l)*Rinner(k,l)
+       enddo Inner
+!
+!$OMP CRITICAL (in)
+       debug_InnerLoopDistribution(iInner) = debug_InnerLoopDistribution(iInner)+1
+!$OMP END CRITICAL (in)
+!       ROuter = state - state_old - &
+!                dt*constitutive_dotState(Tstar_v,state,Temperature,&
+!                                         grain,ip,cp_en)          ! residuum from evolution of microstructure
+!       state = state - ROuter                                           ! update of microstructure
+!
+!	   if (iOuter==nOuter) then
+!!$OMP CRITICAL (write2out)
+!	      write (6,*) 'Terminated outer loop at el,ip,grain',cp_en,ip,grain
+!!$OMP END CRITICAL (write2out)
+!	      exit Outer
+!	   endif
+!       if (maxval(abs(Router/state),state /= 0.0_pReal) < reltol_Outer) exit Outer
+!     enddo Outer
+!
+!!$OMP CRITICAL (out)
+! debug_OuterLoopDistribution(iOuter) = debug_OuterLoopDistribution(iOuter)+1
+!!$OMP END CRITICAL (out)
+ invFp_new = math_mul33x33(invFp_old,B)
+ call math_invert3x3(invFp_new,Fp_new,det,failed)
+ if (failed) then
+   msg = 'inversion Fp_new^-1'
+   return
+ endif
+!
+! if (wantsConstitutiveResults) then     ! get the post_results upon request
+!   results = 0.0_pReal
+!   results = constitutive_post_results(Tstar_v,state,Temperature,dt,grain,ip,cp_en)
+! endif
+!
+ Fp_new = Fp_new*det**(1.0_pReal/3.0_pReal)     ! regularize Fp by det = det(InvFp_new) !!
+ forall (i=1:3) Tstar_v(i) = Tstar_v(i)+p_hydro ! add hydrostatic component back
+ Fe_new = math_mul33x33(Fg_new,invFp_new)              ! calc resulting Fe
+! P = math_mul33x33(Fe_new,math_mul33x33(Tstar,transpose(invFp_new)))    ! first PK stress
+ P = math_mul33x33(Fe_new,math_mul33x33(math_Mandel6to33(Tstar_v),transpose(invFp_new)))    ! first PK stress
+
+ return
+!
+ END SUBROUTINE
+!
+ END MODULE
+!##############################################################
+
diff --git a/trunk/CPFEM_Taylor_sequential.f90 b/trunk/CPFEM_Taylor_sequential.f90
index 11e1e22b7..026f86c39 100644
--- a/trunk/CPFEM_Taylor_sequential.f90
+++ b/trunk/CPFEM_Taylor_sequential.f90
@@ -240,712 +240,711 @@
  CPFEM_stress(1:CPFEM_ngens) = CPFEM_stress_bar(1:CPFEM_ngens,CPFEM_in,cp_en)
  CPFEM_jaco(1:CPFEM_ngens,1:CPFEM_ngens) = CPFEM_jaco_bar(1:CPFEM_ngens,1:CPFEM_ngens,CPFEM_in,cp_en)
  if (debugger) write (6,'(a,/,6(6(f9.3,x)/))') 'stiffness / GPa',CPFEM_jaco(1:CPFEM_ngens,:)/1e9_pReal
-
- 
 !
  return
 !
  END SUBROUTINE
 !
 !
-!**********************************************************
-!***      calculate the material point behaviour        ***
-!**********************************************************
- SUBROUTINE CPFEM_MaterialPoint(&
-     updateJaco,&     ! flag to initiate Jacobian updating
-     CPFEM_dt,&       ! Time increment (dt)
-     CPFEM_in,&       ! Integration point number
-     cp_en)           ! Element number
-!
- use prec
- use FEsolving, only: theCycle
- use debug
- use math, only: math_pDecomposition,math_RtoEuler,inDeg,math_I3,math_invert3x3,math_permut,math_invert,math_delta
- use IO,   only: IO_error
- use mesh, only: mesh_element, mesh_NcpElems, FE_Nips
-! use crystallite
- use constitutive
- implicit none
-!
- integer(pInt) cp_en,CPFEM_in,g,i,e
- integer(pInt) el_start, el_end, ip_start, ip_end
- logical updateJaco,error
- real(pReal) CPFEM_dt,volfrac
- real(pReal), dimension(3,3)        :: U,R !,Fe1
-! real(pReal), dimension(3,3)        :: PK1
-! real(pReal), dimension(3,3,3,3)    :: dPdF,dPdF_bar_old
-!
- CPFEM_PK1_bar = 0.0_pReal                         ! zero out average first PK stress
-!initialize element loop
- if (cp_en /= 0_pInt) then
-    el_start = cp_en
-    el_end = cp_en
- else
-    el_start = 1_pInt
-    el_end = mesh_NcpElems
- endif
-! prescribe FFN and FFN1 depending on homogenization scheme
-!$OMP PARALLEL DO
- do e=el_start,el_end
-    if(CPFEM_in /= 0_pInt) then
-        ip_start = CPFEM_in
-        ip_end = CPFEM_in
-    else
-        ip_start = 1
-        ip_end = FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
-    endif
-    do i=ip_start,ip_end
-        do g=1,texture_Ngrains(mesh_element(4,e))
-            CPFEM_ffn(:,:,g,i,e) = CPFEM_ffn_bar(:,:,i,e)    !Taylor homogenization
-            CPFEM_ffn1(:,:,g,i,e) = CPFEM_ffn1_bar(:,:,i,e)  !Taylor homogenization
-        end do
-    end do
- end do
-!$OMP END PARALLEL DO
-! calculate stress, update state and update jacobian in case needed for all or one ip
- if (updateJaco) then
-   CPFEM_dPdF_bar_old = CPFEM_dPdF_bar               ! remember former average consistent tangent
-   CPFEM_dPdF_bar = 0.0_pReal                        ! zero out avg consistent tangent for later assembly
- endif
- call SingleCrystallite(updateJaco,CPFEM_dt,el_start,el_end,CPFEM_in)
-!******************************************************************************************************
-! check convergence of homogenization in case needed
-!******************************************************************************************************
-! calculate average quantities per ip and post results
-!$OMP PARALLEL DO
- do e=el_start,el_end
-    if(CPFEM_in /= 0_pInt) then
-        ip_start = CPFEM_in
-        ip_end = CPFEM_in
-    else
-        ip_start = 1
-        ip_end = FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
-    endif
-    do i=ip_start,ip_end
-        do g=1,texture_Ngrains(mesh_element(4,e))
-            volfrac = constitutive_matVolFrac(g,i,e)*constitutive_texVolFrac(g,i,e)
-            CPFEM_PK1_bar(:,:,i,e) = CPFEM_PK1_bar(:,:,i,e) + volfrac * CPFEM_PK1(:,:,g,i,e)
-            if (updateJaco) CPFEM_dPdF_bar(:,:,:,:,i,e) = &
-                   CPFEM_dPdF_bar(:,:,:,:,i,e) + volfrac * CPFEM_dPdF(:,:,:,:,g,i,e)   ! add up crystallite stiffnesses
-				                                                                       ! (may have "holes" corresponding 
-				                                                                       ! to former avg tangent)
-!   update results plotted in MENTAT
-            call math_pDecomposition(CPFEM_Fe1(:,:,g,i,e),U,R,error) ! polar decomposition
-            if (error) then
-!$OMP CRITICAL (write2out)
-                write(6,*) 'polar decomposition of', CPFEM_Fe1(:,:,g,i,e)
-                write(6,*) 'Grain:             ',g
-                write(6,*) 'Integration point: ',i
-                write(6,*) 'Element:           ',mesh_element(1,e)
-!$OMP END CRITICAL (write2out)
-                call IO_error(650)
-                return
-            endif
-            CPFEM_results(1:3,g,i,e) = math_RtoEuler(transpose(R))*inDeg        ! orientation
-            CPFEM_results(4  ,g,i,e) = volfrac                                  ! volume fraction of orientation
-        end do
-    end do
- end do
-!$OMP END PARALLEL DO
-!
- return
-!
- END SUBROUTINE
-!
-!
-!********************************************************************
-! Initialize crystallite
-!********************************************************************
- subroutine crystallite_init()
- use mesh, only: mesh_maxNips,mesh_NcpElems
- use constitutive, only: constitutive_maxNgrains
-
- implicit none
-
- allocate(crystallite_converged(constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems)); crystallite_converged = .false.
-!
-!    *** Output to MARC output file ***
-!$OMP CRITICAL (write2out)
- write(6,*)
- write(6,*) 'crystallite Initialization'
- write(6,*)
- write(6,*) 'crystallite_converged:      ', shape(crystallite_converged)
- write(6,*)
- call flush(6)
-!$OMP END CRITICAL (write2out)
- return
-!
- end subroutine
-!
-!
-!********************************************************************
-! Calculates the stress and jacobi (if wanted) for all or a single component
-!********************************************************************
- subroutine SingleCrystallite(&
-     updateJaco,& ! update of Jacobian required
-     dt,&         ! time increment
-     el_start,&   ! first element in element loop
-     el_end,&     ! last element in element loop
-     CPFEM_in)    ! IP number
-!
- use prec, only: pReal,pInt,pert_Fg,subStepMin, nCutback
- use debug
- use constitutive
- use mesh, only: mesh_element, FE_Nips
- use math
- use IO,   only: IO_error
-! use CPFEM
-
- implicit none
-!
- logical updateJaco, JacoOK
- real(preal) dt
- real(pReal), dimension(3,3) :: Fg_pert,Lp_pert, P_pert, Fp_pert, Fe_pert
- real(pReal), dimension(6) :: Tstar_v     
- real(pReal), dimension(constitutive_maxNstatevars) :: state_pert
- integer(pInt) el_start, el_end, CPFEM_in, ip_start, ip_end, g, i, e, k, l, iOuter
-!
- crystallite_converged=.true.
-!$OMP PARALLEL DO
-    do e=el_start,el_end
-        if(CPFEM_in /= 0_pInt) then
-            ip_start = CPFEM_in
-            ip_end = CPFEM_in
-        else
-            ip_start = 1
-            ip_end = FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
-        endif
-        do i=ip_start,ip_end
-            do g=1,texture_Ngrains(mesh_element(4,e))
-                crystallite_converged(g,i,e)=.false.
-            end do
-        end do
-    end do
-!$OMP END PARALLEL DO
- constitutive_state_new=constitutive_state_old
- CPFEM_Lp_new = CPFEM_Lp_old
- iOuter = 0_pInt
- do while(any(crystallite_converged(:,:,el_start:el_end))==.false.)
-!$OMP PARALLEL DO
-    do e=el_start,el_end
-        if(CPFEM_in /= 0_pInt) then
-            ip_start = CPFEM_in
-            ip_end = CPFEM_in
-        else
-            ip_start = 1
-            ip_end = FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
-        endif
-        do i=ip_start,ip_end
-            do g=1,texture_Ngrains(mesh_element(4,e))
-                if(.not.crystallite_converged(g,i,e))&
-                    call IntegrateStress(CPFEM_Tstar_v(:,g,i,e), CPFEM_PK1(:,:,g,i,e), CPFEM_ffn1(:,:,g,i,e),&
-                     CPFEM_Fp_new(:,:,g,i,e), CPFEM_Fe1(:,:,g,i,e), CPFEM_Lp_new(:,:,g,i,e),&
-                     constitutive_state_new(:,g,i,e), dt, g, i, e)
-            end do
-        end do
-    end do
-!$OMP END PARALLEL DO
-!$OMP PARALLEL DO
-    do e=el_start,el_end
-        if(CPFEM_in /= 0_pInt) then
-            ip_start = CPFEM_in
-            ip_end = CPFEM_in
-        else
-            ip_start = 1
-            ip_end = FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
-        endif
-        do i=ip_start,ip_end
-            do g=1,texture_Ngrains(mesh_element(4,e))
-                if(.not.crystallite_converged(g,i,e))& 
-                    call UpdateState(CPFEM_Tstar_v(:,g,i,e),constitutive_state_new(:,g,i,e),dt,g,i,e)
-            end do
-        end do
-    end do
-!$OMP END PARALLEL DO
-    iOuter = iOuter + 1_pInt
-    if (iOuter==Nouter) then
-!$OMP CRITICAL (write2out)
-        write (6,*) 'Terminated outer loop at el,ip,grain',e,i,g
-!$OMP CRITICAL (out)
-        debug_OuterLoopDistribution(iOuter) = debug_OuterLoopDistribution(iOuter)+1
-!$OMP END CRITICAL (out)
-        call IO_error(600)
-!$OMP END CRITICAL (write2out)
-    endif
- end do
-!$OMP CRITICAL (out)
- debug_OuterLoopDistribution(iOuter) = debug_OuterLoopDistribution(iOuter)+1
-!$OMP END CRITICAL (out)
-
- if (wantsConstitutiveResults) then                                ! get the post_results upon request
-!$OMP PARALLEL DO
-    do e=el_start,el_end
-        if(CPFEM_in /= 0_pInt) then
-            ip_start = CPFEM_in
-            ip_end = CPFEM_in
-        else
-            ip_start = 1
-            ip_end = FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
-        endif
-        do i=ip_start,ip_end
-            do g=1,texture_Ngrains(mesh_element(4,e))
-                CPFEM_results(CPFEM_Nresults+1:CPFEM_Nresults+constitutive_Nresults(g,i,e),g,i,e) =&
-                 constitutive_post_results(CPFEM_Tstar_v(:,g,i,e),constitutive_state_new(:,g,i,e),&
-                 CPFEM_Temperature(i,e),dt,g,i,e)
-            end do
-        end do
-    end do
-!$OMP END PARALLEL DO
- endif
-!
-!***** Calculate Jacobian *****
- if(updateJaco) then
-    if (debugger) then
-!$OMP CRITICAL (write2out)
-        write (6,*) 'Jacobian calc'
-!$OMP END CRITICAL (write2out)
-    endif   
-!    crystallite_converged=.false.
-!$OMP PARALLEL DO
-    do e=el_start,el_end
-        if(CPFEM_in /= 0_pInt) then
-            ip_start = CPFEM_in
-            ip_end = CPFEM_in
-        else
-            ip_start = 1
-            ip_end = FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
-        endif
-        do i=ip_start,ip_end
-            do g=1,texture_Ngrains(mesh_element(4,e))
-                do k=1,3
-                    do l=1,3
-                        crystallite_converged(g,i,e)=.false.
-                        JacoOK=.true.
-                        Fg_pert = CPFEM_ffn1(:,:,g,i,e)                                   ! initialize perturbed Fg
-                        Fg_pert(k,l) = Fg_pert(k,l) + pert_Fg                             ! perturb single component
-                        Lp_pert = CPFEM_Lp_new(:,:,g,i,e)                                 ! initialize Lp
-                        Fp_pert = CPFEM_Fp_new(:,:,g,i,e)                                 ! initialize Fp
-                        state_pert = constitutive_state_new(:,g,i,e)                      ! initial guess from end of time step
-                        iOuter=0_pInt
-                        do while(.not.crystallite_converged(g,i,e))
-                            call IntegrateStress(Tstar_v, P_pert, Fg_pert, Fp_pert, Fe_pert, Lp_pert, state_pert, dt, g, i, e)
-                            call UpdateState(Tstar_v,state_pert,dt,g,i,e)
-                            iOuter = iOuter + 1_pInt
-                            if (iOuter==Nouter) then
-                                JacoOK=.false.
-                                exit
-                            endif
-                        end do
-!$OMP CRITICAL (out)
-                        debug_OuterLoopDistribution(iOuter) = debug_OuterLoopDistribution(iOuter)+1
-!$OMP END CRITICAL (out)
-                        if (JacoOK) &
-                        CPFEM_dPdF(:,:,k,l,g,i,e) = (P_pert-CPFEM_PK1(:,:,g,i,e))/pert_Fg ! constructing tangent dP_ij/dFg_kl only if valid forward difference
-                                                                                          ! otherwise leave component unchanged
-                     end do
-                end do
-            end do
-        end do
-    end do
-!$OMP END PARALLEL DO
- endif
-!
- return
-!
- end subroutine
-!
-!********************************************************************
-! Update the state for a single component
-!********************************************************************
- subroutine UpdateState(&
-   Tstar_v,&        ! stress
-   state,&          ! state  
-   dt,&             ! time increment
-   g,&              ! grain number
-   i,&              ! integration point number
-   e&               ! element number
- )
- use prec, only: pReal,pInt,reltol_Outer
- use constitutive, only: constitutive_dotState, constitutive_state_old, constitutive_Nstatevars
-! use CPFEM, only: CPFEM_Temperature
-!
- integer(pInt) g, i, e
- real(pReal), dimension(6) :: Tstar_v
- real(pReal), dimension(constitutive_Nstatevars(g, i, e)) :: state, ROuter
- real(pReal) dt
-!
- ROuter = state - constitutive_state_old(:,g,i,e) - &
-                dt*constitutive_dotState(Tstar_v,state,CPFEM_Temperature(i,e),&
-                                         g,i,e)          ! residuum from evolution of microstructure
- state = state - ROuter                                           ! update of microstructure
- if (maxval(abs(ROuter/state),state /= 0.0_pReal) < reltol_Outer) crystallite_converged(g,i,e) = .true.
-!
- return
-!
- end subroutine
-!
-!
-!********************************************************************
-! Calculates the stress for a single component
-!********************************************************************
-!***********************************************************************
-!***     calculation of stress (P), stiffness (dPdF),                ***
-!***     and announcment of any                  ***
-!***     acceleration of the Newton-Raphson correction               ***
-!***********************************************************************
- subroutine IntegrateStress(&
-     Tstar_v,&    ! Stress vector
-     P,&          ! first PK stress
-     Fg_new,&     ! new global deformation gradient
-     Fp_new,&     ! new plastic deformation gradient
-     Fe_new,&     ! new "elastic" deformation gradient
-     Lp,&         ! plastic velocity gradient
-     state_new,&  ! new state variable array
-     dt,&         ! time increment
-     g,&          ! grain number
-     i,&          ! integration point number
-     e)           ! element number
-
-!     post_results,& ! plot results from constitutive model
-!     Fp_new,&     ! new plastic deformation gradient
-!     updateJaco,& ! update of Jacobian required
-!     Temperature,& ! temperature of crystallite
-!     Fg_old,&     ! old global deformation gradient
-!     Fp_old,&     ! old plastic deformation gradient
-!     state_old)   ! old state variable array
-!
- use prec, only: pReal,pInt,pert_Fg,subStepMin, nCutback
- use debug
- use constitutive, only: constitutive_Nstatevars,constitutive_Nresults,constitutive_state_old
- use math
-! use CPFEM
-!
- implicit none
-!
- character(len=128) msg
- logical error,success
- integer(pInt) e,i,g, nCutbacks, maxCutbacks
- real(pReal) Temperature
- real(pReal) dt,dt_aim,subFrac,subStep,det
- real(pReal), dimension(3,3)     :: Lp,Lp_interpolated,inv
- real(pReal), dimension(3,3)     :: Fg_current,Fg_new,Fg_aim,deltaFg
- real(pReal), dimension(3,3)     :: Fp_current,Fp_new
- real(pReal), dimension(3,3)     :: Fe_current,Fe_new
- real(pReal), dimension(3,3)     :: P
- real(pReal), dimension(6) :: Tstar_v
- real(pReal), dimension(constitutive_Nstatevars(g,i,e)) :: state_new
-! real(pReal), dimension(constitutive_Nstatevars(g,i,e)) :: state_current
-! 
-! debugger= e==1.and.i==1
- deltaFg = Fg_new - CPFEM_ffn(:,:,g,i,e)
- subFrac = 0.0_pReal
- subStep = 1.0_pReal
- nCutbacks = 0_pInt
- maxCutbacks = 0_pInt
- Fg_current = CPFEM_ffn(:,:,g,i,e)                                 ! initialize to start of inc
- Fp_current = CPFEM_Fp_old(:,:,g,i,e)
- call math_invert3x3(Fp_current,inv,det,error)
- Fe_current = math_mul33x33(Fg_current,inv)
-! state_current = state_new
- success = .false.                                                 ! pretend cutback
- dt_aim = 0.0_pReal                                                ! prevent initial Lp interpolation
- Temperature=CPFEM_Temperature(i,e)
-! 
-! begin the cutback loop
- do while (subStep > subStepMin)                                   ! continue until finished or too much cut backing
-   if (success) then                                               ! wind forward
-     Fg_current = Fg_aim
-     Fe_current = Fe_new
-     Fp_current = Fp_new
-!     state_current = state_new
-   elseif (dt_aim > 0.0_pReal) then
-     call math_invert3x3(Fg_aim,inv,det,error)                     !  inv of Fg_aim
-     Lp_interpolated = 0.5_pReal*Lp + &
-                       0.5_pReal*(math_I3 -  math_mul33x33(Fp_current,&
-                                  math_mul33x33(inv,Fe_current)))/dt_aim  ! interpolate Lp  and L
-     if (debugger) then
-!$OMP CRITICAL (write2out)
-       write (6,*) 'Lp interpolation'
-       write (6,'(a,/,3(3(f12.7,x)/))') 'from',Lp(1:3,:)
-       write (6,'(a,/,3(3(f12.7,x)/))') 'to',Lp_interpolated(1:3,:)
-!$OMP END CRITICAL (write2out)
-     endif
-     Lp = Lp_interpolated
-   endif
-!
-   Fg_aim = Fg_current + subStep*deltaFg                           ! aim for Fg
-   dt_aim = subStep*dt                                             ! aim for dt
-   if (debugger) then
-!$OMP CRITICAL (write2out)
-     write (6,*) 'using these values'
-!     write (6,'(a,/,3(4(f9.3,x)/))') 'state current / MPa',state_current/1e6_pReal
-     write (6,'(a,/,3(4(f9.3,x)/))') 'state new / MPa',state_new/1e6_pReal
-     write (6,'(a,/,3(3(f12.7,x)/))') 'Fe current',Fe_current(1:3,:)
-     write (6,'(a,/,3(3(f12.7,x)/))') 'Fp current',Fp_current(1:3,:)
-     write (6,'(a,/,3(3(f12.7,x)/))') 'Lp (old=new guess)',Lp(1:3,:)
-     write (6,'(a20,f,x,a2,x,f)') 'integrating from ',subFrac,'to',(subFrac+subStep)
-!$OMP END CRITICAL (write2out)
-   endif
-!
-   call TimeIntegration(msg,Lp,Fp_new,Fe_new,Tstar_v,P,state_new,dt_aim,e,i,g,Temperature,Fg_aim,Fp_current)
-!
-
-   if (msg == 'ok') then
-     subFrac = subFrac + subStep
-     subStep = min(1.0_pReal-subFrac, subStep*2.0_pReal) ! accelerate
-     nCutbacks = 0_pInt                   ! reset cutback counter
-     success = .true.                     ! keep current Lp
-   else
-     nCutbacks = nCutbacks + 1            ! record additional cutback
-     maxCutbacks = max(nCutbacks,maxCutbacks)! remember maximum number of cutbacks
-     subStep = subStep / 2.0_pReal        ! cut time step in half
-     success = .false.                    ! force Lp interpolation
-!     if (debugger) then
-!$OMP CRITICAL (write2out)
-       write (6,*) '>>>>>>>>>>>>>>>>>>>> cutback <<<<<<<<<<<<<<<<<<<<<<'
-       write (6,*) 'Element, Ip:', e, i
-       write (6,*) msg
-!$OMP END CRITICAL (write2out)
-!     endif
-!
-   endif
- enddo  ! potential substepping
-!
-!$OMP CRITICAL (cutback)
- debug_cutbackDistribution(min(nCutback,maxCutbacks)+1) = debug_cutbackDistribution(min(nCutback,maxCutbacks)+1)+1
-!$OMP END CRITICAL (cutback)
-!
-! debugger = .false.
- return
- end subroutine
-
-!
-!***********************************************************************
-!***     fully-implicit two-level time integration                   ***
-!***     based on a residuum in Lp and intermediate                  ***
-!***     acceleration of the Newton-Raphson correction               ***
-!***********************************************************************
- SUBROUTINE TimeIntegration(&
-     msg,&              ! return message
-     Lpguess,&          ! guess of plastic velocity gradient
-     Fp_new,&           ! new plastic deformation gradient
-     Fe_new,&           ! new "elastic" deformation gradient
-     Tstar_v,&          ! Stress vector
-     P,&                ! 1nd PK stress (taken as initial guess if /= 0)
-     state,&            ! current microstructure at end of time inc (taken as guess if /= 0)
-     dt,&               ! time increment
-     cp_en,&            ! element number
-     ip,&               ! integration point number
-     grain,&            ! grain number
-     Temperature,&      ! temperature
-     Fg_new,&           ! new total def gradient
-     Fp_old)            ! former plastic def gradient
-!     state_current)         ! former microstructure
- use prec
- use debug
- use mesh, only: mesh_element
- use constitutive, only: constitutive_Nstatevars,constitutive_Microstructure,&
-                         constitutive_homogenizedC,constitutive_LpAndItsTangent
- use math
- use IO
- implicit none
-!
- character(len=*) msg
- logical failed
- integer(pInt) cp_en, ip, grain
- integer(pInt) iInner,dummy, i,j,k,l,m,n
- real(pReal) dt, Temperature, det, p_hydro, leapfrog,maxleap
- real(pReal), dimension(6) :: Tstar_v
- real(pReal), dimension(9,9) :: dLp,dTdLp,dRdLp,invdRdLp,eye2
- real(pReal), dimension(6,6) :: C_66
- real(pReal), dimension(3,3) :: Fg_new,Fp_new,invFp_new,Fp_old,invFp_old,Fe_new
- real(pReal), dimension(3,3) :: P !,Tstar
- real(pReal), dimension(3,3) :: Lp,Lpguess,Lpguess_old,Rinner,Rinner_old,A,B,BT,AB,BTA
- real(pReal), dimension(3,3,3,3) :: C
- real(pReal), dimension(constitutive_Nstatevars(grain, ip, cp_en)) :: state
-!
- msg = 'ok'  ! error-free so far
- eye2 = math_identity2nd(9)
-
- call math_invert3x3(Fp_old,invFp_old,det,failed) ! inversion of Fp_old
- if (failed) then
-    msg = 'inversion Fp_old'
-    return
- endif
-
- A = math_mul33x33(transpose(invFp_old), math_mul33x33(transpose(Fg_new),math_mul33x33(Fg_new,invFp_old)))
-!
-! if (all(state == 0.0_pReal)) state = state_current ! former state guessed, if none specified
-! iOuter = 0_pInt                                    ! outer counter
-!
- if (debugger) then
-!$OMP CRITICAL (write2out)
-   write (6,'(a,/,3(3(f12.7,x)/))') 'Fg to be calculated',Fg_new
-!$OMP END CRITICAL (write2out)
- endif
-!
-!Outer: do                ! outer iteration: State
-!         iOuter = iOuter+1
-!         if (debugger) then
-!!$OMP CRITICAL (write2out)
-!           write (6,'(a,i3)') '---outer ',iOuter
-!           write (6,'(a,/,3(4(f9.3,x)/))') 'state old / MPa',state_old/1e6_pReal
-!           write (6,'(a,/,3(4(f9.3,x)/))') 'state / MPa',state/1e6_pReal
-!           write (6,'(a,/,3(3(f12.7,x)/))') 'Lpguess',Lpguess(1:3,:)
-!!$OMP END CRITICAL (write2out)
-!         endif
-!
-!         if (iOuter > nOuter) then
-!           msg = 'limit Outer iteration'
-!!$OMP CRITICAL (out)
-!           debug_OuterLoopDistribution(nOuter) = debug_OuterLoopDistribution(nOuter)+1
-!!$OMP END CRITICAL (out)
-!           return
-!         endif
-         call constitutive_Microstructure(state,Temperature,grain,ip,cp_en)
-         C_66 = constitutive_HomogenizedC(state, grain, ip, cp_en)
-         C = math_Mandel66to3333(C_66)       ! 4th rank elasticity tensor
-!
-         iInner = 0_pInt
-         leapfrog = 1.0_pReal                ! correction as suggested by invdRdLp-step
-         maxleap = 1024.0_pReal              ! preassign maximum acceleration level
-!
-		 Lpguess_old = Lpguess               ! consider present Lpguess good
-!
-Inner: do              ! inner iteration: Lp
-         iInner = iInner+1
-!         if (debugger) then
-!!$OMP CRITICAL (write2out)
-!           write (6,'(a,i3)') 'inner ',iInner
-!		   if (iInner < 3) then
-!             write (6,'(a,/,3(3(f12.7,x)/))') 'Lpguess',Lpguess(1:3,:)
-!		   endif
-!!$OMP END CRITICAL (write2out)
-!         endif
-         if (iInner > nInner) then           ! too many loops required
-           Lpguess = Lpguess_old             ! do not trust the last update but resort to former one
-           msg = 'limit Inner iteration'
-!$OMP CRITICAL (in)
-           debug_InnerLoopDistribution(nInner) = debug_InnerLoopDistribution(nInner)+1
-!$OMP END CRITICAL (in)
-           return
-         endif
-!
-         B = math_i3 - dt*Lpguess
-         BT = transpose(B)
-         AB = math_mul33x33(A,B)
-         BTA = math_mul33x33(BT,A)
-         Tstar_v = 0.5_pReal*math_mul66x6(C_66,math_mandel33to6(math_mul33x33(BT,AB)-math_I3))
-!         Tstar = math_Mandel6to33(Tstar_v)
-         p_hydro=(Tstar_v(1)+Tstar_v(2)+Tstar_v(3))/3.0_pReal
-         forall(i=1:3) Tstar_v(i) = Tstar_v(i)-p_hydro                ! subtract hydrostatic pressure
-         call constitutive_LpAndItsTangent(Lp,dLp, &
-                                           Tstar_v,state,Temperature,grain,ip,cp_en)
-!			    
-         Rinner = Lpguess - Lp                                        ! update current residuum
-!
-         if (.not.(any(Rinner/=Rinner)) .and. &                       ! exclude any NaN in residuum
-             ( (maxval(abs(Rinner)) < abstol_Inner) .or. &            ! below abs tol .or.
-               ( any(abs(dt*Lpguess) > relevantStrain) .and. &        ! worth checking? .and.
-                 maxval(abs(Rinner/Lpguess),abs(dt*Lpguess) > relevantStrain) < reltol_Inner &  ! below rel tol
-               ) &
-             )   &
-            )    &
-            exit Inner                                                ! convergence
-!
-!          check for acceleration/deceleration in Newton--Raphson correction
-!
-         if (any(Rinner/=Rinner) .and. &                              ! NaN occured at regular speed
-		     leapfrog == 1.0) then
-			Lpguess = Lpguess_old                                     ! restore known good guess
-		    msg = 'NaN present'                                       ! croak for cutback
-			return
-
-         elseif (leapfrog > 1.0_pReal .and. &                         ! at fast pace ?
-             (sum(Rinner*Rinner) > sum(Rinner_old*Rinner_old) .or. &  ! worse residuum
-              sum(Rinner*Rinner_old) < 0.0_pReal) .or. &              ! residuum changed sign (overshoot)
-			  any(Rinner/=Rinner) ) then                              ! NaN
-           maxleap = 0.5_pReal * leapfrog                             ! limit next acceleration
-           leapfrog = 1.0_pReal                                       ! grinding halt
-
-         else                                                         ! better residuum
-           dTdLp = 0.0_pReal                                          ! calc dT/dLp
-           forall (i=1:3,j=1:3,k=1:3,l=1:3,m=1:3,n=1:3) &
-             dTdLp(3*(i-1)+j,3*(k-1)+l) = dTdLp(3*(i-1)+j,3*(k-1)+l) + &
-             C(i,j,l,n)*AB(k,n)+C(i,j,m,l)*BTA(m,k)
-           dTdLp = -0.5_pReal*dt*dTdLp
-           dRdLp = eye2 - math_mul99x99(dLp,dTdLp)                    ! calc dR/dLp
-           invdRdLp = 0.0_pReal
-           call math_invert(9,dRdLp,invdRdLp,dummy,failed)            ! invert dR/dLp --> dLp/dR
-           if (failed) then
-             msg = 'inversion dR/dLp'
-               if (debugger) then
-!$OMP CRITICAL (write2out)
-                 write (6,*) msg
-                 write (6,'(a,/,9(9(e9.3,x)/))') 'dRdLp', dRdLp(1:9,:)
-                 write (6,'(a,/,3(4(f9.3,x)/))') 'state / MPa',state/1e6_pReal
-                 write (6,'(a,/,3(3(f12.7,x)/))') 'Lpguess',Lpguess(1:3,:)
-                 write (6,'(a,/,3(3(e12.7,x)/))') 'Lp',Lp(1:3,:)
-                 write (6,'(a,/,6(f9.3,x))') 'Tstar / MPa',Tstar_v/1e6_pReal
-!$OMP END CRITICAL (write2out)
-               endif 
-             return
-           endif
-!
-           Rinner_old = Rinner                                        ! remember current residuum
-           Lpguess_old = Lpguess                                      ! remember current Lp guess 
-           if (iInner > 1 .and. leapfrog < maxleap) &
-		     leapfrog = 2.0_pReal * leapfrog                          ! accelerate if ok
-         endif
-!
-         Lpguess = Lpguess_old                                        ! start from current guess                                       
-         Rinner  = Rinner_old                                         ! use current residuum
-         forall (i=1:3,j=1:3,k=1:3,l=1:3) &                           ! leapfrog to updated Lpguess 
-           Lpguess(i,j) = Lpguess(i,j) - leapfrog*invdRdLp(3*(i-1)+j,3*(k-1)+l)*Rinner(k,l)
-       enddo Inner
-!
-!$OMP CRITICAL (in)
-       debug_InnerLoopDistribution(iInner) = debug_InnerLoopDistribution(iInner)+1
-!$OMP END CRITICAL (in)
-!       ROuter = state - state_old - &
-!                dt*constitutive_dotState(Tstar_v,state,Temperature,&
-!                                         grain,ip,cp_en)          ! residuum from evolution of microstructure
-!       state = state - ROuter                                           ! update of microstructure
-!
-!	   if (iOuter==nOuter) then
-!!$OMP CRITICAL (write2out)
-!	      write (6,*) 'Terminated outer loop at el,ip,grain',cp_en,ip,grain
-!!$OMP END CRITICAL (write2out)
-!	      exit Outer
-!	   endif
-!       if (maxval(abs(Router/state),state /= 0.0_pReal) < reltol_Outer) exit Outer
-!     enddo Outer
-!
-!!$OMP CRITICAL (out)
-! debug_OuterLoopDistribution(iOuter) = debug_OuterLoopDistribution(iOuter)+1
-!!$OMP END CRITICAL (out)
- invFp_new = math_mul33x33(invFp_old,B)
- call math_invert3x3(invFp_new,Fp_new,det,failed)
- if (failed) then
-   msg = 'inversion Fp_new^-1'
-   return
- endif
-!
-! if (wantsConstitutiveResults) then     ! get the post_results upon request
-!   results = 0.0_pReal
-!   results = constitutive_post_results(Tstar_v,state,Temperature,dt,grain,ip,cp_en)
-! endif
-!
- Fp_new = Fp_new*det**(1.0_pReal/3.0_pReal)     ! regularize Fp by det = det(InvFp_new) !!
- forall (i=1:3) Tstar_v(i) = Tstar_v(i)+p_hydro ! add hydrostatic component back
- Fe_new = math_mul33x33(Fg_new,invFp_new)              ! calc resulting Fe
-! P = math_mul33x33(Fe_new,math_mul33x33(Tstar,transpose(invFp_new)))    ! first PK stress
- P = math_mul33x33(Fe_new,math_mul33x33(math_Mandel6to33(Tstar_v),transpose(invFp_new)))    ! first PK stress
-
- return
-!
- END SUBROUTINE
-!
- END MODULE
-!##############################################################
-
+!**********************************************************
+!***      calculate the material point behaviour        ***
+!**********************************************************
+ SUBROUTINE CPFEM_MaterialPoint(&
+     updateJaco,&     ! flag to initiate Jacobian updating
+     CPFEM_dt,&       ! Time increment (dt)
+     CPFEM_in,&       ! Integration point number
+     cp_en)           ! Element number
+!
+ use prec
+ use FEsolving, only: theCycle
+ use debug
+ use math, only: math_pDecomposition,math_RtoEuler,inDeg,math_I3,math_invert3x3,math_permut,math_invert,math_delta
+ use IO,   only: IO_error
+ use mesh, only: mesh_element, mesh_NcpElems, FE_Nips
+! use crystallite
+ use constitutive
+ implicit none
+
+!
+ integer(pInt) cp_en,CPFEM_in,g,i,e
+ integer(pInt) el_start, el_end, ip_start, ip_end
+ logical updateJaco,error
+ real(pReal) CPFEM_dt,volfrac
+ real(pReal), dimension(3,3)        :: U,R !,Fe1
+! real(pReal), dimension(3,3)        :: PK1
+! real(pReal), dimension(3,3,3,3)    :: dPdF,dPdF_bar_old
+!
+ CPFEM_PK1_bar = 0.0_pReal                         ! zero out average first PK stress
+!initialize element loop
+ if (cp_en /= 0_pInt) then
+    el_start = cp_en
+    el_end = cp_en
+ else
+    el_start = 1_pInt
+    el_end = mesh_NcpElems
+ endif
+! prescribe FFN and FFN1 depending on homogenization scheme
+!$OMP PARALLEL DO
+ do e=el_start,el_end
+    if(CPFEM_in /= 0_pInt) then
+        ip_start = CPFEM_in
+        ip_end = CPFEM_in
+    else
+        ip_start = 1
+        ip_end = FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
+    endif
+    do i=ip_start,ip_end
+        do g=1,texture_Ngrains(mesh_element(4,e))
+            CPFEM_ffn(:,:,g,i,e) = CPFEM_ffn_bar(:,:,i,e)    !Taylor homogenization
+            CPFEM_ffn1(:,:,g,i,e) = CPFEM_ffn1_bar(:,:,i,e)  !Taylor homogenization
+        end do
+    end do
+ end do
+!$OMP END PARALLEL DO
+! calculate stress, update state and update jacobian in case needed for all or one ip
+ if (updateJaco) then
+   CPFEM_dPdF_bar_old = CPFEM_dPdF_bar               ! remember former average consistent tangent
+   CPFEM_dPdF_bar = 0.0_pReal                        ! zero out avg consistent tangent for later assembly
+ endif
+ call SingleCrystallite(updateJaco,CPFEM_dt,el_start,el_end,CPFEM_in)
+!******************************************************************************************************
+! check convergence of homogenization in case needed
+!******************************************************************************************************
+! calculate average quantities per ip and post results
+!$OMP PARALLEL DO
+ do e=el_start,el_end
+    if(CPFEM_in /= 0_pInt) then
+        ip_start = CPFEM_in
+        ip_end = CPFEM_in
+    else
+        ip_start = 1
+        ip_end = FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
+    endif
+    do i=ip_start,ip_end
+        do g=1,texture_Ngrains(mesh_element(4,e))
+            volfrac = constitutive_matVolFrac(g,i,e)*constitutive_texVolFrac(g,i,e)
+            CPFEM_PK1_bar(:,:,i,e) = CPFEM_PK1_bar(:,:,i,e) + volfrac * CPFEM_PK1(:,:,g,i,e)
+            if (updateJaco) CPFEM_dPdF_bar(:,:,:,:,i,e) = &
+                   CPFEM_dPdF_bar(:,:,:,:,i,e) + volfrac * CPFEM_dPdF(:,:,:,:,g,i,e)   ! add up crystallite stiffnesses
+				                                                                       ! (may have "holes" corresponding 
+				                                                                       ! to former avg tangent)
+!   update results plotted in MENTAT
+            call math_pDecomposition(CPFEM_Fe1(:,:,g,i,e),U,R,error) ! polar decomposition
+            if (error) then
+!$OMP CRITICAL (write2out)
+                write(6,*) 'polar decomposition of', CPFEM_Fe1(:,:,g,i,e)
+                write(6,*) 'Grain:             ',g
+                write(6,*) 'Integration point: ',i
+                write(6,*) 'Element:           ',mesh_element(1,e)
+!$OMP END CRITICAL (write2out)
+                call IO_error(650)
+                return
+            endif
+            CPFEM_results(1:3,g,i,e) = math_RtoEuler(transpose(R))*inDeg        ! orientation
+            CPFEM_results(4  ,g,i,e) = volfrac                                  ! volume fraction of orientation
+        end do
+    end do
+ end do
+!$OMP END PARALLEL DO
+!
+ return
+!
+ END SUBROUTINE
+!
+!
+!********************************************************************
+! Initialize crystallite
+!********************************************************************
+ subroutine crystallite_init()
+ use mesh, only: mesh_maxNips,mesh_NcpElems
+ use constitutive, only: constitutive_maxNgrains
+
+ implicit none
+
+ allocate(crystallite_converged(constitutive_maxNgrains,mesh_maxNips,mesh_NcpElems)); crystallite_converged = .false.
+!
+!    *** Output to MARC output file ***
+!$OMP CRITICAL (write2out)
+ write(6,*)
+ write(6,*) 'crystallite Initialization'
+ write(6,*)
+ write(6,*) 'crystallite_converged:      ', shape(crystallite_converged)
+ write(6,*)
+ call flush(6)
+!$OMP END CRITICAL (write2out)
+ return
+!
+ end subroutine
+!
+!
+!********************************************************************
+! Calculates the stress and jacobi (if wanted) for all or a single component
+!********************************************************************
+ subroutine SingleCrystallite(&
+     updateJaco,& ! update of Jacobian required
+     dt,&         ! time increment
+     el_start,&   ! first element in element loop
+     el_end,&     ! last element in element loop
+     CPFEM_in)    ! IP number
+!
+ use prec, only: pReal,pInt,pert_Fg,subStepMin, nCutback
+ use debug
+ use constitutive
+ use mesh, only: mesh_element, FE_Nips
+ use math
+ use IO,   only: IO_error
+! use CPFEM
+
+ implicit none
+!
+ logical updateJaco, JacoOK
+ real(preal) dt
+ real(pReal), dimension(3,3) :: Fg_pert,Lp_pert, P_pert, Fp_pert, Fe_pert
+ real(pReal), dimension(6) :: Tstar_v     
+ real(pReal), dimension(constitutive_maxNstatevars) :: state_pert
+ integer(pInt) el_start, el_end, CPFEM_in, ip_start, ip_end, g, i, e, k, l, iOuter
+!
+ crystallite_converged=.true.
+!$OMP PARALLEL DO
+    do e=el_start,el_end
+        if(CPFEM_in /= 0_pInt) then
+            ip_start = CPFEM_in
+            ip_end = CPFEM_in
+        else
+            ip_start = 1
+            ip_end = FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
+        endif
+        do i=ip_start,ip_end
+            do g=1,texture_Ngrains(mesh_element(4,e))
+                crystallite_converged(g,i,e)=.false.
+            end do
+        end do
+    end do
+!$OMP END PARALLEL DO
+ constitutive_state_new=constitutive_state_old
+ CPFEM_Lp_new = CPFEM_Lp_old
+ iOuter = 0_pInt
+ do while(any(crystallite_converged(:,:,el_start:el_end))==.false.)
+!$OMP PARALLEL DO
+    do e=el_start,el_end
+        if(CPFEM_in /= 0_pInt) then
+            ip_start = CPFEM_in
+            ip_end = CPFEM_in
+        else
+            ip_start = 1
+            ip_end = FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
+        endif
+        do i=ip_start,ip_end
+            do g=1,texture_Ngrains(mesh_element(4,e))
+                if(.not.crystallite_converged(g,i,e))&
+                    call IntegrateStress(CPFEM_Tstar_v(:,g,i,e), CPFEM_PK1(:,:,g,i,e), CPFEM_ffn1(:,:,g,i,e),&
+                     CPFEM_Fp_new(:,:,g,i,e), CPFEM_Fe1(:,:,g,i,e), CPFEM_Lp_new(:,:,g,i,e),&
+                     constitutive_state_new(:,g,i,e), dt, g, i, e)
+            end do
+        end do
+    end do
+!$OMP END PARALLEL DO
+!$OMP PARALLEL DO
+    do e=el_start,el_end
+        if(CPFEM_in /= 0_pInt) then
+            ip_start = CPFEM_in
+            ip_end = CPFEM_in
+        else
+            ip_start = 1
+            ip_end = FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
+        endif
+        do i=ip_start,ip_end
+            do g=1,texture_Ngrains(mesh_element(4,e))
+                if(.not.crystallite_converged(g,i,e))& 
+                    call UpdateState(CPFEM_Tstar_v(:,g,i,e),constitutive_state_new(:,g,i,e),dt,g,i,e)
+            end do
+        end do
+    end do
+!$OMP END PARALLEL DO
+    iOuter = iOuter + 1_pInt
+    if (iOuter==Nouter) then
+!$OMP CRITICAL (write2out)
+        write (6,*) 'Terminated outer loop at el,ip,grain',e,i,g
+!$OMP CRITICAL (out)
+        debug_OuterLoopDistribution(iOuter) = debug_OuterLoopDistribution(iOuter)+1
+!$OMP END CRITICAL (out)
+        call IO_error(600)
+!$OMP END CRITICAL (write2out)
+    endif
+ end do
+!$OMP CRITICAL (out)
+ debug_OuterLoopDistribution(iOuter) = debug_OuterLoopDistribution(iOuter)+1
+!$OMP END CRITICAL (out)
+
+ if (wantsConstitutiveResults) then                                ! get the post_results upon request
+!$OMP PARALLEL DO
+    do e=el_start,el_end
+        if(CPFEM_in /= 0_pInt) then
+            ip_start = CPFEM_in
+            ip_end = CPFEM_in
+        else
+            ip_start = 1
+            ip_end = FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
+        endif
+        do i=ip_start,ip_end
+            do g=1,texture_Ngrains(mesh_element(4,e))
+                CPFEM_results(CPFEM_Nresults+1:CPFEM_Nresults+constitutive_Nresults(g,i,e),g,i,e) =&
+                 constitutive_post_results(CPFEM_Tstar_v(:,g,i,e),constitutive_state_new(:,g,i,e),&
+                 CPFEM_Temperature(i,e),dt,g,i,e)
+            end do
+        end do
+    end do
+!$OMP END PARALLEL DO
+ endif
+!
+!***** Calculate Jacobian *****
+ if(updateJaco) then
+    if (debugger) then
+!$OMP CRITICAL (write2out)
+        write (6,*) 'Jacobian calc'
+!$OMP END CRITICAL (write2out)
+    endif   
+!    crystallite_converged=.false.
+!$OMP PARALLEL DO
+    do e=el_start,el_end
+        if(CPFEM_in /= 0_pInt) then
+            ip_start = CPFEM_in
+            ip_end = CPFEM_in
+        else
+            ip_start = 1
+            ip_end = FE_Nips(mesh_element(2,e))      ! iterate over all IPs of this element's type
+        endif
+        do i=ip_start,ip_end
+            do g=1,texture_Ngrains(mesh_element(4,e))
+                do k=1,3
+                    do l=1,3
+                        crystallite_converged(g,i,e)=.false.
+                        JacoOK=.true.
+                        Fg_pert = CPFEM_ffn1(:,:,g,i,e)                                   ! initialize perturbed Fg
+                        Fg_pert(k,l) = Fg_pert(k,l) + pert_Fg                             ! perturb single component
+                        Lp_pert = CPFEM_Lp_new(:,:,g,i,e)                                 ! initialize Lp
+                        Fp_pert = CPFEM_Fp_new(:,:,g,i,e)                                 ! initialize Fp
+                        state_pert = constitutive_state_new(:,g,i,e)                      ! initial guess from end of time step
+                        iOuter=0_pInt
+                        do while(.not.crystallite_converged(g,i,e))
+                            call IntegrateStress(Tstar_v, P_pert, Fg_pert, Fp_pert, Fe_pert, Lp_pert, state_pert, dt, g, i, e)
+                            call UpdateState(Tstar_v,state_pert,dt,g,i,e)
+                            iOuter = iOuter + 1_pInt
+                            if (iOuter==Nouter) then
+                                JacoOK=.false.
+                                exit
+                            endif
+                        end do
+!$OMP CRITICAL (out)
+                        debug_OuterLoopDistribution(iOuter) = debug_OuterLoopDistribution(iOuter)+1
+!$OMP END CRITICAL (out)
+                        if (JacoOK) &
+                        CPFEM_dPdF(:,:,k,l,g,i,e) = (P_pert-CPFEM_PK1(:,:,g,i,e))/pert_Fg ! constructing tangent dP_ij/dFg_kl only if valid forward difference
+                                                                                          ! otherwise leave component unchanged
+                     end do
+                end do
+            end do
+        end do
+    end do
+!$OMP END PARALLEL DO
+ endif
+!
+ return
+!
+ end subroutine
+!
+!********************************************************************
+! Update the state for a single component
+!********************************************************************
+ subroutine UpdateState(&
+   Tstar_v,&        ! stress
+   state,&          ! state  
+   dt,&             ! time increment
+   g,&              ! grain number
+   i,&              ! integration point number
+   e&               ! element number
+ )
+ use prec, only: pReal,pInt,reltol_Outer
+ use constitutive, only: constitutive_dotState, constitutive_state_old, constitutive_Nstatevars
+! use CPFEM, only: CPFEM_Temperature
+!
+ integer(pInt) g, i, e
+ real(pReal), dimension(6) :: Tstar_v
+ real(pReal), dimension(constitutive_Nstatevars(g, i, e)) :: state, ROuter
+ real(pReal) dt
+!
+ ROuter = state - constitutive_state_old(:,g,i,e) - &
+                dt*constitutive_dotState(Tstar_v,state,CPFEM_Temperature(i,e),&
+                                         g,i,e)          ! residuum from evolution of microstructure
+ state = state - ROuter                                           ! update of microstructure
+ if (maxval(abs(ROuter/state),state /= 0.0_pReal) < reltol_Outer) crystallite_converged(g,i,e) = .true.
+!
+ return
+!
+ end subroutine
+!
+!
+!********************************************************************
+! Calculates the stress for a single component
+!********************************************************************
+!***********************************************************************
+!***     calculation of stress (P), stiffness (dPdF),                ***
+!***     and announcment of any                  ***
+!***     acceleration of the Newton-Raphson correction               ***
+!***********************************************************************
+ subroutine IntegrateStress(&
+     Tstar_v,&    ! Stress vector
+     P,&          ! first PK stress
+     Fg_new,&     ! new global deformation gradient
+     Fp_new,&     ! new plastic deformation gradient
+     Fe_new,&     ! new "elastic" deformation gradient
+     Lp,&         ! plastic velocity gradient
+     state_new,&  ! new state variable array
+     dt,&         ! time increment
+     g,&          ! grain number
+     i,&          ! integration point number
+     e)           ! element number
+
+!     post_results,& ! plot results from constitutive model
+!     Fp_new,&     ! new plastic deformation gradient
+!     updateJaco,& ! update of Jacobian required
+!     Temperature,& ! temperature of crystallite
+!     Fg_old,&     ! old global deformation gradient
+!     Fp_old,&     ! old plastic deformation gradient
+!     state_old)   ! old state variable array
+!
+ use prec, only: pReal,pInt,pert_Fg,subStepMin, nCutback
+ use debug
+ use constitutive, only: constitutive_Nstatevars,constitutive_Nresults,constitutive_state_old
+ use math
+! use CPFEM
+!
+ implicit none
+!
+ character(len=128) msg
+ logical error,success
+ integer(pInt) e,i,g, nCutbacks, maxCutbacks
+ real(pReal) Temperature
+ real(pReal) dt,dt_aim,subFrac,subStep,det
+ real(pReal), dimension(3,3)     :: Lp,Lp_interpolated,inv
+ real(pReal), dimension(3,3)     :: Fg_current,Fg_new,Fg_aim,deltaFg
+ real(pReal), dimension(3,3)     :: Fp_current,Fp_new
+ real(pReal), dimension(3,3)     :: Fe_current,Fe_new
+ real(pReal), dimension(3,3)     :: P
+ real(pReal), dimension(6) :: Tstar_v
+ real(pReal), dimension(constitutive_Nstatevars(g,i,e)) :: state_new
+! real(pReal), dimension(constitutive_Nstatevars(g,i,e)) :: state_current
+! 
+! debugger= e==1.and.i==1
+ deltaFg = Fg_new - CPFEM_ffn(:,:,g,i,e)
+ subFrac = 0.0_pReal
+ subStep = 1.0_pReal
+ nCutbacks = 0_pInt
+ maxCutbacks = 0_pInt
+ Fg_current = CPFEM_ffn(:,:,g,i,e)                                 ! initialize to start of inc
+ Fp_current = CPFEM_Fp_old(:,:,g,i,e)
+ call math_invert3x3(Fp_current,inv,det,error)
+ Fe_current = math_mul33x33(Fg_current,inv)
+! state_current = state_new
+ success = .false.                                                 ! pretend cutback
+ dt_aim = 0.0_pReal                                                ! prevent initial Lp interpolation
+ Temperature=CPFEM_Temperature(i,e)
+! 
+! begin the cutback loop
+ do while (subStep > subStepMin)                                   ! continue until finished or too much cut backing
+   if (success) then                                               ! wind forward
+     Fg_current = Fg_aim
+     Fe_current = Fe_new
+     Fp_current = Fp_new
+!     state_current = state_new
+   elseif (dt_aim > 0.0_pReal) then
+     call math_invert3x3(Fg_aim,inv,det,error)                     !  inv of Fg_aim
+     Lp_interpolated = 0.5_pReal*Lp + &
+                       0.5_pReal*(math_I3 -  math_mul33x33(Fp_current,&
+                                  math_mul33x33(inv,Fe_current)))/dt_aim  ! interpolate Lp  and L
+     if (debugger) then
+!$OMP CRITICAL (write2out)
+       write (6,*) 'Lp interpolation'
+       write (6,'(a,/,3(3(f12.7,x)/))') 'from',Lp(1:3,:)
+       write (6,'(a,/,3(3(f12.7,x)/))') 'to',Lp_interpolated(1:3,:)
+!$OMP END CRITICAL (write2out)
+     endif
+     Lp = Lp_interpolated
+   endif
+!
+   Fg_aim = Fg_current + subStep*deltaFg                           ! aim for Fg
+   dt_aim = subStep*dt                                             ! aim for dt
+   if (debugger) then
+!$OMP CRITICAL (write2out)
+     write (6,*) 'using these values'
+!     write (6,'(a,/,3(4(f9.3,x)/))') 'state current / MPa',state_current/1e6_pReal
+     write (6,'(a,/,3(4(f9.3,x)/))') 'state new / MPa',state_new/1e6_pReal
+     write (6,'(a,/,3(3(f12.7,x)/))') 'Fe current',Fe_current(1:3,:)
+     write (6,'(a,/,3(3(f12.7,x)/))') 'Fp current',Fp_current(1:3,:)
+     write (6,'(a,/,3(3(f12.7,x)/))') 'Lp (old=new guess)',Lp(1:3,:)
+     write (6,'(a20,f,x,a2,x,f)') 'integrating from ',subFrac,'to',(subFrac+subStep)
+!$OMP END CRITICAL (write2out)
+   endif
+!
+   call TimeIntegration(msg,Lp,Fp_new,Fe_new,Tstar_v,P,state_new,dt_aim,e,i,g,Temperature,Fg_aim,Fp_current)
+!
+
+   if (msg == 'ok') then
+     subFrac = subFrac + subStep
+     subStep = min(1.0_pReal-subFrac, subStep*2.0_pReal) ! accelerate
+     nCutbacks = 0_pInt                   ! reset cutback counter
+     success = .true.                     ! keep current Lp
+   else
+     nCutbacks = nCutbacks + 1            ! record additional cutback
+     maxCutbacks = max(nCutbacks,maxCutbacks)! remember maximum number of cutbacks
+     subStep = subStep / 2.0_pReal        ! cut time step in half
+     success = .false.                    ! force Lp interpolation
+!     if (debugger) then
+!$OMP CRITICAL (write2out)
+       write (6,*) '>>>>>>>>>>>>>>>>>>>> cutback <<<<<<<<<<<<<<<<<<<<<<'
+       write (6,*) 'Element, Ip:', e, i
+       write (6,*) msg
+!$OMP END CRITICAL (write2out)
+!     endif
+!
+   endif
+ enddo  ! potential substepping
+!
+!$OMP CRITICAL (cutback)
+ debug_cutbackDistribution(min(nCutback,maxCutbacks)+1) = debug_cutbackDistribution(min(nCutback,maxCutbacks)+1)+1
+!$OMP END CRITICAL (cutback)
+!
+! debugger = .false.
+ return
+ end subroutine
+
+!
+!***********************************************************************
+!***     fully-implicit two-level time integration                   ***
+!***     based on a residuum in Lp and intermediate                  ***
+!***     acceleration of the Newton-Raphson correction               ***
+!***********************************************************************
+ SUBROUTINE TimeIntegration(&
+     msg,&              ! return message
+     Lpguess,&          ! guess of plastic velocity gradient
+     Fp_new,&           ! new plastic deformation gradient
+     Fe_new,&           ! new "elastic" deformation gradient
+     Tstar_v,&          ! Stress vector
+     P,&                ! 1nd PK stress (taken as initial guess if /= 0)
+     state,&            ! current microstructure at end of time inc (taken as guess if /= 0)
+     dt,&               ! time increment
+     cp_en,&            ! element number
+     ip,&               ! integration point number
+     grain,&            ! grain number
+     Temperature,&      ! temperature
+     Fg_new,&           ! new total def gradient
+     Fp_old)            ! former plastic def gradient
+!     state_current)         ! former microstructure
+ use prec
+ use debug
+ use mesh, only: mesh_element
+ use constitutive, only: constitutive_Nstatevars,constitutive_Microstructure,&
+                         constitutive_homogenizedC,constitutive_LpAndItsTangent
+ use math
+ use IO
+ implicit none
+!
+ character(len=*) msg
+ logical failed
+ integer(pInt) cp_en, ip, grain
+ integer(pInt) iInner,dummy, i,j,k,l,m,n
+ real(pReal) dt, Temperature, det, p_hydro, leapfrog,maxleap
+ real(pReal), dimension(6) :: Tstar_v
+ real(pReal), dimension(9,9) :: dLp,dTdLp,dRdLp,invdRdLp,eye2
+ real(pReal), dimension(6,6) :: C_66
+ real(pReal), dimension(3,3) :: Fg_new,Fp_new,invFp_new,Fp_old,invFp_old,Fe_new
+ real(pReal), dimension(3,3) :: P !,Tstar
+ real(pReal), dimension(3,3) :: Lp,Lpguess,Lpguess_old,Rinner,Rinner_old,A,B,BT,AB,BTA
+ real(pReal), dimension(3,3,3,3) :: C
+ real(pReal), dimension(constitutive_Nstatevars(grain, ip, cp_en)) :: state
+!
+ msg = 'ok'  ! error-free so far
+ eye2 = math_identity2nd(9)
+
+ call math_invert3x3(Fp_old,invFp_old,det,failed) ! inversion of Fp_old
+ if (failed) then
+    msg = 'inversion Fp_old'
+    return
+ endif
+
+ A = math_mul33x33(transpose(invFp_old), math_mul33x33(transpose(Fg_new),math_mul33x33(Fg_new,invFp_old)))
+!
+! if (all(state == 0.0_pReal)) state = state_current ! former state guessed, if none specified
+! iOuter = 0_pInt                                    ! outer counter
+!
+ if (debugger) then
+!$OMP CRITICAL (write2out)
+   write (6,'(a,/,3(3(f12.7,x)/))') 'Fg to be calculated',Fg_new
+!$OMP END CRITICAL (write2out)
+ endif
+!
+!Outer: do                ! outer iteration: State
+!         iOuter = iOuter+1
+!         if (debugger) then
+!!$OMP CRITICAL (write2out)
+!           write (6,'(a,i3)') '---outer ',iOuter
+!           write (6,'(a,/,3(4(f9.3,x)/))') 'state old / MPa',state_old/1e6_pReal
+!           write (6,'(a,/,3(4(f9.3,x)/))') 'state / MPa',state/1e6_pReal
+!           write (6,'(a,/,3(3(f12.7,x)/))') 'Lpguess',Lpguess(1:3,:)
+!!$OMP END CRITICAL (write2out)
+!         endif
+!
+!         if (iOuter > nOuter) then
+!           msg = 'limit Outer iteration'
+!!$OMP CRITICAL (out)
+!           debug_OuterLoopDistribution(nOuter) = debug_OuterLoopDistribution(nOuter)+1
+!!$OMP END CRITICAL (out)
+!           return
+!         endif
+         call constitutive_Microstructure(state,Temperature,grain,ip,cp_en)
+         C_66 = constitutive_HomogenizedC(state, grain, ip, cp_en)
+         C = math_Mandel66to3333(C_66)       ! 4th rank elasticity tensor
+!
+         iInner = 0_pInt
+         leapfrog = 1.0_pReal                ! correction as suggested by invdRdLp-step
+         maxleap = 1024.0_pReal              ! preassign maximum acceleration level
+!
+		 Lpguess_old = Lpguess               ! consider present Lpguess good
+!
+Inner: do              ! inner iteration: Lp
+         iInner = iInner+1
+!         if (debugger) then
+!!$OMP CRITICAL (write2out)
+!           write (6,'(a,i3)') 'inner ',iInner
+!		   if (iInner < 3) then
+!             write (6,'(a,/,3(3(f12.7,x)/))') 'Lpguess',Lpguess(1:3,:)
+!		   endif
+!!$OMP END CRITICAL (write2out)
+!         endif
+         if (iInner > nInner) then           ! too many loops required
+           Lpguess = Lpguess_old             ! do not trust the last update but resort to former one
+           msg = 'limit Inner iteration'
+!$OMP CRITICAL (in)
+           debug_InnerLoopDistribution(nInner) = debug_InnerLoopDistribution(nInner)+1
+!$OMP END CRITICAL (in)
+           return
+         endif
+!
+         B = math_i3 - dt*Lpguess
+         BT = transpose(B)
+         AB = math_mul33x33(A,B)
+         BTA = math_mul33x33(BT,A)
+         Tstar_v = 0.5_pReal*math_mul66x6(C_66,math_mandel33to6(math_mul33x33(BT,AB)-math_I3))
+!         Tstar = math_Mandel6to33(Tstar_v)
+         p_hydro=(Tstar_v(1)+Tstar_v(2)+Tstar_v(3))/3.0_pReal
+         forall(i=1:3) Tstar_v(i) = Tstar_v(i)-p_hydro                ! subtract hydrostatic pressure
+         call constitutive_LpAndItsTangent(Lp,dLp, &
+                                           Tstar_v,state,Temperature,grain,ip,cp_en)
+!			    
+         Rinner = Lpguess - Lp                                        ! update current residuum
+!
+         if (.not.(any(Rinner/=Rinner)) .and. &                       ! exclude any NaN in residuum
+             ( (maxval(abs(Rinner)) < abstol_Inner) .or. &            ! below abs tol .or.
+               ( any(abs(dt*Lpguess) > relevantStrain) .and. &        ! worth checking? .and.
+                 maxval(abs(Rinner/Lpguess),abs(dt*Lpguess) > relevantStrain) < reltol_Inner &  ! below rel tol
+               ) &
+             )   &
+            )    &
+            exit Inner                                                ! convergence
+!
+!          check for acceleration/deceleration in Newton--Raphson correction
+!
+         if (any(Rinner/=Rinner) .and. &                              ! NaN occured at regular speed
+		     leapfrog == 1.0) then
+			Lpguess = Lpguess_old                                     ! restore known good guess
+		    msg = 'NaN present'                                       ! croak for cutback
+			return
+
+         elseif (leapfrog > 1.0_pReal .and. &                         ! at fast pace ?
+             (sum(Rinner*Rinner) > sum(Rinner_old*Rinner_old) .or. &  ! worse residuum
+              sum(Rinner*Rinner_old) < 0.0_pReal) .or. &              ! residuum changed sign (overshoot)
+			  any(Rinner/=Rinner) ) then                              ! NaN
+           maxleap = 0.5_pReal * leapfrog                             ! limit next acceleration
+           leapfrog = 1.0_pReal                                       ! grinding halt
+
+         else                                                         ! better residuum
+           dTdLp = 0.0_pReal                                          ! calc dT/dLp
+           forall (i=1:3,j=1:3,k=1:3,l=1:3,m=1:3,n=1:3) &
+             dTdLp(3*(i-1)+j,3*(k-1)+l) = dTdLp(3*(i-1)+j,3*(k-1)+l) + &
+             C(i,j,l,n)*AB(k,n)+C(i,j,m,l)*BTA(m,k)
+           dTdLp = -0.5_pReal*dt*dTdLp
+           dRdLp = eye2 - math_mul99x99(dLp,dTdLp)                    ! calc dR/dLp
+           invdRdLp = 0.0_pReal
+           call math_invert(9,dRdLp,invdRdLp,dummy,failed)            ! invert dR/dLp --> dLp/dR
+           if (failed) then
+             msg = 'inversion dR/dLp'
+               if (debugger) then
+!$OMP CRITICAL (write2out)
+                 write (6,*) msg
+                 write (6,'(a,/,9(9(e9.3,x)/))') 'dRdLp', dRdLp(1:9,:)
+                 write (6,'(a,/,3(4(f9.3,x)/))') 'state / MPa',state/1e6_pReal
+                 write (6,'(a,/,3(3(f12.7,x)/))') 'Lpguess',Lpguess(1:3,:)
+                 write (6,'(a,/,3(3(e12.7,x)/))') 'Lp',Lp(1:3,:)
+                 write (6,'(a,/,6(f9.3,x))') 'Tstar / MPa',Tstar_v/1e6_pReal
+!$OMP END CRITICAL (write2out)
+               endif 
+             return
+           endif
+!
+           Rinner_old = Rinner                                        ! remember current residuum
+           Lpguess_old = Lpguess                                      ! remember current Lp guess 
+           if (iInner > 1 .and. leapfrog < maxleap) &
+		     leapfrog = 2.0_pReal * leapfrog                          ! accelerate if ok
+         endif
+!
+         Lpguess = Lpguess_old                                        ! start from current guess                                       
+         Rinner  = Rinner_old                                         ! use current residuum
+         forall (i=1:3,j=1:3,k=1:3,l=1:3) &                           ! leapfrog to updated Lpguess 
+           Lpguess(i,j) = Lpguess(i,j) - leapfrog*invdRdLp(3*(i-1)+j,3*(k-1)+l)*Rinner(k,l)
+       enddo Inner
+!
+!$OMP CRITICAL (in)
+       debug_InnerLoopDistribution(iInner) = debug_InnerLoopDistribution(iInner)+1
+!$OMP END CRITICAL (in)
+!       ROuter = state - state_old - &
+!                dt*constitutive_dotState(Tstar_v,state,Temperature,&
+!                                         grain,ip,cp_en)          ! residuum from evolution of microstructure
+!       state = state - ROuter                                           ! update of microstructure
+!
+!	   if (iOuter==nOuter) then
+!!$OMP CRITICAL (write2out)
+!	      write (6,*) 'Terminated outer loop at el,ip,grain',cp_en,ip,grain
+!!$OMP END CRITICAL (write2out)
+!	      exit Outer
+!	   endif
+!       if (maxval(abs(Router/state),state /= 0.0_pReal) < reltol_Outer) exit Outer
+!     enddo Outer
+!
+!!$OMP CRITICAL (out)
+! debug_OuterLoopDistribution(iOuter) = debug_OuterLoopDistribution(iOuter)+1
+!!$OMP END CRITICAL (out)
+ invFp_new = math_mul33x33(invFp_old,B)
+ call math_invert3x3(invFp_new,Fp_new,det,failed)
+ if (failed) then
+   msg = 'inversion Fp_new^-1'
+   return
+ endif
+!
+! if (wantsConstitutiveResults) then     ! get the post_results upon request
+!   results = 0.0_pReal
+!   results = constitutive_post_results(Tstar_v,state,Temperature,dt,grain,ip,cp_en)
+! endif
+!
+ Fp_new = Fp_new*det**(1.0_pReal/3.0_pReal)     ! regularize Fp by det = det(InvFp_new) !!
+ forall (i=1:3) Tstar_v(i) = Tstar_v(i)+p_hydro ! add hydrostatic component back
+ Fe_new = math_mul33x33(Fg_new,invFp_new)              ! calc resulting Fe
+! P = math_mul33x33(Fe_new,math_mul33x33(Tstar,transpose(invFp_new)))    ! first PK stress
+ P = math_mul33x33(Fe_new,math_mul33x33(math_Mandel6to33(Tstar_v),transpose(invFp_new)))    ! first PK stress
+
+ return
+!
+ END SUBROUTINE
+!
+ END MODULE
+!##############################################################
+
diff --git a/trunk/FEsolving.f90 b/trunk/FEsolving.f90
index e53541de1..21f519a3f 100644
--- a/trunk/FEsolving.f90
+++ b/trunk/FEsolving.f90
@@ -10,44 +10,45 @@
  integer(pInt) theInc,theCycle,theLovl
  real(pReal)   theTime
  logical :: lastIncConverged = .false.,outdatedByNewInc = .false., outdatedFFN1 = .false.
- logical :: symmetricSolver = .false. 
-
- CONTAINS
-
-!***********************************************************
-! determine wether a symmetric solver is used 
-!***********************************************************
- subroutine FE_get_solverSymmetry(unit)
- 
- use prec, only: pInt
- use IO
- implicit none
- 
- integer(pInt) unit
- integer(pInt), dimension (133) :: pos
- character*300 line
- 
-610 FORMAT(A300)
- 
- rewind(unit)
- do
-   read (unit,610,END=630) line
-   pos = IO_stringPos(line,1)
-   if( IO_lc(IO_stringValue(line,pos,1)) == 'solver' ) then
-     read (unit,610,END=630) line  ! Garbage line
-     pos = IO_stringPos(line,2)  ! limit to 64 nodes max (plus ID, type)
-     if(IO_intValue(line,pos,2) /= 1_pInt) then
-        symmetricSolver = .true.
-!$OMP CRITICAL (write2out)
-        write (6,*)
-        write (6,*) 'Symmetric solver detected. d-Matrix will be symmetrized!'
-!$OMP END CRITICAL (write2out)
-     endif
-   endif
- enddo
-
-630 return
-
- end subroutine
+ logical :: symmetricSolver = .false. 
+
+
+ CONTAINS
+
+!***********************************************************
+! determine wether a symmetric solver is used 
+!***********************************************************
+ subroutine FE_get_solverSymmetry(unit)
+ 
+ use prec, only: pInt
+ use IO
+ implicit none
+ 
+ integer(pInt) unit
+ integer(pInt), dimension (133) :: pos
+ character*300 line
+ 
+610 FORMAT(A300)
+ 
+ rewind(unit)
+ do
+   read (unit,610,END=630) line
+   pos = IO_stringPos(line,1)
+   if( IO_lc(IO_stringValue(line,pos,1)) == 'solver' ) then
+     read (unit,610,END=630) line  ! Garbage line
+     pos = IO_stringPos(line,2)  ! limit to 64 nodes max (plus ID, type)
+     if(IO_intValue(line,pos,2) /= 1_pInt) then
+        symmetricSolver = .true.
+!$OMP CRITICAL (write2out)
+        write (6,*)
+        write (6,*) 'Symmetric solver detected. d-Matrix will be symmetrized!'
+!$OMP END CRITICAL (write2out)
+     endif
+   endif
+ enddo
+
+630 return
+
+ end subroutine
 
  END MODULE FEsolving
diff --git a/trunk/IO.f90 b/trunk/IO.f90
index 1f7d40704..702908630 100644
--- a/trunk/IO.f90
+++ b/trunk/IO.f90
@@ -256,8 +256,8 @@
 
  character(len=*), intent(in) :: line
  character(len=*), parameter :: sep=achar(32)//achar(9)//achar(10)//achar(13) ! whitespaces
- integer(pInt), intent(in) :: N
- integer(pInt)  part
+ integer(pInt), intent(in) :: N
+ integer(pInt)  part
  integer(pInt) IO_stringPos(1+N*2)
 
  IO_stringPos = -1
@@ -324,7 +324,7 @@
  
  character(len=*), intent(in) :: line
  integer(pInt), intent(in) :: positions(*),pos
- real(pReal) IO_floatValue
+ real(pReal) IO_floatValue
 
  if (positions(1) >= pos) then
    read(UNIT=line(positions(pos*2):positions(pos*2+1)),ERR=100,FMT=*) IO_floatValue
@@ -346,7 +346,7 @@
  
  character(len=*), intent(in) :: line
  integer(pInt), intent(in) :: ends(*),pos
- real(pReal) IO_fixedFloatValue
+ real(pReal) IO_fixedFloatValue
 
  read(UNIT=line(ends(pos-1)+1:ends(pos)),ERR=100,FMT=*) IO_fixedFloatValue
  return
@@ -365,9 +365,9 @@
  implicit none
  
  character(len=*), intent(in) :: line
- integer(pInt), intent(in) :: ends(*),pos
- integer(pInt) pos_exp,expon
- real(pReal) IO_fixedNoEFloatValue,base
+ integer(pInt), intent(in) :: ends(*),pos
+ integer(pInt) pos_exp,expon
+ real(pReal) IO_fixedNoEFloatValue,base
  
  pos_exp = scan(line(ends(pos)+1:ends(pos+1)),'+-',back=.true.)
  if (pos_exp > 1) then
@@ -395,7 +395,7 @@
  
  character(len=*), intent(in) :: line
  integer(pInt), intent(in) :: positions(*),pos
- integer(pInt) IO_intValue
+ integer(pInt) IO_intValue
 
  if (positions(1) >= pos) then
    read(UNIT=line(positions(pos*2):positions(pos*2+1)),ERR=100,FMT=*) IO_intValue
@@ -417,7 +417,7 @@
  
  character(len=*), intent(in) :: line
  integer(pInt), intent(in) :: ends(*),pos
- integer(pInt) IO_fixedIntValue
+ integer(pInt) IO_fixedIntValue
 
  read(UNIT=line(ends(pos)+1:ends(pos+1)),ERR=100,FMT=*) IO_fixedIntValue
  return
@@ -595,19 +595,18 @@
  case default
    msg='Unknown error number'
  end select
- 
+ 
  !$OMP CRITICAL (write2out)
  write(6,*) 'MPIE Material Routine Ver. 0.0 by the coding team'
  write(6,*)
  write(6,*) msg
-
  write(6,*)
+
  call debug_info()
-
-
  call flush(6)
  call quit(9000+ID)
-!$OMP END CRITICAL (write2out)
+!$OMP END CRITICAL (write2out)
+
 ! ABAQUS returns in some cases
  return
 
diff --git a/trunk/concom2008r1 b/trunk/concom2008r1
index bf384ed35..a638edd9d 100644
--- a/trunk/concom2008r1
+++ b/trunk/concom2008r1
@@ -1,186 +1,186 @@
-! reformated to free format
-!***********************************************************************
-!
-!        File: concom.cmn
-!
-!        MSC.Marc include file
-!
- integer(pInt) &
-       iacous, iasmbl, iautth,    ibear,  icompl,    iconj,  icreep, ideva,     idyn,   idynt,&
-       ielas,  ielcma, ielect,    iform,  ifour,     iharm,  ihcps,  iheat,     iheatt, ihresp,&
-       ijoule, ilem,   ilnmom,    iloren, inc,       incext, incsub, ipass,     iplres, ipois,&
-       ipoist, irpflo, ismall,    ismalt, isoil,     ispect, ispnow, istore,    iswep,  ithcrp,&
-       itherm, iupblg, iupdat,    jacflg, jel,       jparks, largst, lfond,     loadup, loaduq,&
-       lodcor, lovl,   lsub,      magnet, ncycle,    newtnt, newton, noshr,     linear, ivscpl,&
-       icrpim, iradrt, ipshft,    itshr,  iangin,    iupmdr, iconjf, jincfl,    jpermg, jhour,&
-       isolvr, jritz,  jtable,    jshell, jdoubl,    jform,  jcentr, imini,     kautth, iautof,&
-       ibukty, iassum, icnstd,    icnstt, kmakmas,   imethvp,iradrte,iradrtp,   iupdate,iupdatp,&
-       ncycnt, marmen ,idynme,    ihavca, ispf,      kmini,  imixed, largtt,    kdoela, iautofg,&
-       ipshftp,idntrc, ipore,     jtablm, jtablc,    isnecma,itrnspo,imsdif,    jtrnspo,mcnear,&
-       imech,  imecht, ielcmat,   ielectt,magnett,   imsdift,noplas, jtabls,    jactch, jtablth,&
-       kgmsto ,jpzo,   ifricsh,   iremkin,iremfor,   ishearp,jspf,   machining, jlshell,icompsol,&
-       iupblgfo,jcondir,nstcrp,   nactive,ipassref,  nstspnt,ibeart,icheckmpc,  noline, icuring,&
-       ishrink,ioffsflg,isetoff,  ioffsetm,iharmt,   inc_incdat,iautspc,ibrake, icbush ,istream_input,&
-       iprsinp,ivlsinp,ifirst_time,ipin_m,jgnstr_glb,imarc_return,iqvcinp,nqvceid,istpnx,imicro1,&
-       iaxisymm,jbreakglue,iglstif,jfastasm,iwear,   iwearcf,  imixmeth,ielcmadyn,idinout,igena_meth
- integer(pInt) num_concom
- parameter(num_concom=219)
- common/marc_concom/&
-       iacous, iasmbl, iautth,    ibear,  icompl,    iconj,  icreep, ideva(50), idyn,   idynt,&
-       ielas,  ielcma, ielect,    iform,  ifour,     iharm,  ihcps,  iheat,     iheatt, ihresp,&
-       ijoule, ilem,   ilnmom,    iloren, inc,       incext, incsub, ipass,     iplres, ipois,&
-       ipoist, irpflo, ismall,    ismalt, isoil,     ispect, ispnow, istore,    iswep,  ithcrp,&
-       itherm, iupblg, iupdat,    jacflg, jel,       jparks, largst, lfond,     loadup, loaduq,&
-       lodcor, lovl,   lsub,      magnet, ncycle,    newtnt, newton, noshr,     linear, ivscpl,&
-       icrpim, iradrt, ipshft,    itshr,  iangin,    iupmdr, iconjf, jincfl,    jpermg, jhour,&
-       isolvr, jritz,  jtable,    jshell, jdoubl,    jform,  jcentr, imini,     kautth, iautof,&
-       ibukty, iassum, icnstd,    icnstt, kmakmas,   imethvp,iradrte,iradrtp,   iupdate,iupdatp,&
-       ncycnt, marmen ,idynme,    ihavca, ispf,      kmini,  imixed, largtt,    kdoela, iautofg,&
-       ipshftp,idntrc, ipore,     jtablm, jtablc,    isnecma,itrnspo,imsdif,    jtrnspo,mcnear,&
-       imech,  imecht, ielcmat,   ielectt,magnett,   imsdift,noplas, jtabls,    jactch, jtablth,&
-       kgmsto ,jpzo,   ifricsh,   iremkin,iremfor,   ishearp,jspf,   machining, jlshell,icompsol,&
-       iupblgfo,jcondir,nstcrp,   nactive,ipassref,  nstspnt,ibeart,icheckmpc,  noline, icuring,&
-       ishrink,ioffsflg,isetoff,  ioffsetm,iharmt,   inc_incdat,iautspc,ibrake, icbush ,istream_input,&
-       iprsinp,ivlsinp,ifirst_time,ipin_m,jgnstr_glb,imarc_return,iqvcinp,nqvceid,istpnx,imicro1,&
-       iaxisymm,jbreakglue,iglstif,jfastasm,iwear,   iwearcf, imixmeth,  ielcmadyn,idinout,igena_meth
-!
-! comments of variables:
-!
-! ideva(50) -   debug print out flag
-!       1       print element stiffness matrices, mass matrix
-!       2       output matrices used in tying
-!       3       force the solution of a nonpositive definite matrix
-!       4       print info of connections to each node
-!       5       info of gap convergence, internal heat generated, contact
-!               touching and separation 
-!       6       nodal value array during rezoning
-!       7       tying info in CONRAD GAP option, fluid element numbers in
-!               CHANNEL option
-!       8       output incremental displacements in local coord. system
-!       9       latent heat output
-!       10      stress-strain in local coord. system
-!       11      additional info on  interlaminar stress 
-!       12      output right hand side and solution vector
-!       13      info of CPU resources used and memory available on NT
-!       14      info of mesh adaption process, 2D outline information
-!               info of penetration checking for remeshing
-!               save .fem files after afmesh3d meshing
-!       15      surface energy balance flag  
-!       16      print info regarding pyrolysis   
-!       17      print info of "streamline topology"  
-!       18      print mesh data changes after remeshing
-!       19      print material flow stress data read in from *.mat file
-!               if unit flag is on, print out flow stress after conversion
-!       20      print information on table input
-!       21      print out information regarding kinematic boundary conditions
-!       22      print out information regarding dist loads, point loads, film 
-!               and foundations
-!       23      print out information about automatic domain decomposition
-!       24      print out iteration information in SuperForm status report file
-!       25      print out information for ablation
-!       26      print out information for films - Table input
-!       27      print out the tying forces
-!       28      print out for CASI solver, convection, 
-!       29      DDM single file debug printout
-!       30      print out cavity debug info
-!       31      print out welding related info
-!       32      prints categorized DDM memory usage
-!       33      print out the cutting info regarding machining feature
-!       34      print out the list of quantities which can be defined via a table
-!               and for each quantity the supported independent variables
-!       35      print out detailed coupling region info
-!       36      print out solver debug info level 1 (Least  Detailed)
-!       37      print out solver debug info level 1 (Medium Detailed)
-!       38      print out solver debug info level 1 (Very   Detailed)
-!       39      print detailed memory allocation info
-!       40      print out marc-adams debug info
-!       41      output rezone mapping post file for debugging
-!       42      output post file after calling oprofos() for debugging
-!       43      debug printout for vcct
-!       44      debug printout for progressive failure
-!       45      print out automatically generated midside node coordinates (arecrd)
-!       46      print out message about routine and location, where the ibort is raised (ibort_inc)
-!       47      print out summary message of element variables on a 
-!               group-basis after all the automatic changes have been 
-!               made (em_ellibp)
-!       48      Automatically generate check results based on max and min vals.
-!                These vals are stored in the checkr file, which is inserted 
-!                into the *dat file by the generate_check_results script from /marc/tools
-!       49      Automatically generate check results based on the real calculated values 
-!                at the sppecified check result locations.
-!                These vals are stored in the checkr file, which is inserted 
-!                into the *dat file by the update_check_results script from /marc/tools
-!
-!
-! jactch        = 1 or 2 if elements are activated or deactivated
-!               = 3 if elements are adaptively remeshed or rezoned
-!               = 0 normally / reset to 0 when assembly is done
-! ifricsh       = 0 call to fricsh in otest not needed
-!               = 1 call to fricsh (nodal friction) in otest needed
-! iremkin       = 0  remove deactivated kinematic boundary conditions 
-!                    immediately - only in new input format (this is default)
-!               = 1  remove deactivated kinematic boundary conditions 
-!                    gradually - only in new input format 
-! iremfor       = 0  remove force boundary conditions immediately - 
-!                    only in new input format (this is default)
-!               = 1  remove force boundary conditions gradually - 
-!                    only in new input format (this is default)
-! ishearp       set to 1 if shear panel elements are present in the model
-!
-! jspf          = 0  not in spf loadcase
-!               > 0 in spf loadcase (jspf=1 during first increment)
-! machining     = 1  if the metal cutting feature is used, for memory allocation purpose
-!               = 0  (default) if no metal cutting feature required
-!
-! jlshell       = 1 if there is a shell element in the mesh
-! icompsol      = 1 if there is a composite solid element in the mesh
-! iupblgfo      = 1 if follower force for point loads 
-! jcondir       = 1 if contact priority option is used
-! nstcrp        = 0 (default) steady state creep flag (undocumented feature. 
-!                    if not 0, turns off special ncycle = 0 code in radial.f)
-! nactive       = number of active passes, if =1 then it's not a coupled analysis
-! ipassref      = reference ipass, if not in a multiphysics pass ipass=ipassref
-! icheckmpc     = value of mpc-check parameter option
-! noline        = set to 1 in osolty if no line seacrh should be done in ogetst
-! icuring       = set to 1 if the curing is included for the heat transfer analysis.
-! ishrink       = set to 1 if shrinkage strain is included for mechancial analysis.
-! ioffsflg      =  1 for small displacement beam/shell offsets
-!               =  2 for large displacement beam/shell offsets
-! isetoff       =  0 - do not apply beam/shell offsets
-!               =  1 -  apply beam/shell offsets
-! ioffsetm      = min. value of offset flag
-! inc_incdat    = flag to record increment number of a new loadcase in incdat.f
-! iautspc       = flag for AutoSPC option
-! ibrake        = brake squeal in this increment
-! icbush        = set to 1 if cbush elements present in model
-! istream_input = set to 1 for streaming input calling Marc as library
-! iprsinp       = set to 1 if pressure input, introduced so other variables 
-!                 such as h could be a function of pressure
-! ivlsinp       = set to 1 if velocity input, introduced so other variables 
-!                 such as h could be a function of velocity
-! ipin_m        = # of beam element with PIN flag
-! jgnstr_glb    = global control over pre or fast integrated composite shells
-! imarc_return  = Marc return flag for streaming input control
-! iqvcimp       = if non-zero, then the number of QVECT boundary conditions
-! nqvceid       = number of QVECT boundary conditions, where emisivity/absorbtion id entered
-! istpnx        = 1 if to stop at end of increment
-! imicro1       = 1 if micro1 interface is used
-! iaxisymm      = set to 1 if axisymmetric analysis
-! jbreakglue    = set to 1 if breaking glued option is used
-! iglstif       = 1 if ddm and global stiffness matrix formed (sgi solver 6 or solver9)
-! jfastasm      = 1 do fast assembly using SuperForm code
-! iwear         = set to 1 if wear model, set to 2 if wear model and coordinates updated
-! iwearcf       = set to 1 to store nodal coefficient of friction for wear calculation
-! imixmeth      = set=1 then use nonlinear mixture material - allocate memory
-! ielcmadyn     = flag for magnetodynamics
-!                 0 - electromagnetics using newmark beta
-!                 1 - transient magnetics using backward euler
-! idinout       = flag to control if inside out elements should be deactivated
-! igena_meth    = 0  - generalized alpha parameters depend on whether or not contact
-!                      is flagged (dynamic,7) 
-!                 10 - generalized alpha parameters are optimized for a contact
-!                      analysis (dynamic,8)
-!                 11 - generalized alpha parameters are optimized for an analysis
-!                      without contact (dynamic,8)
-!
-!***********************************************************************
+! reformated to free format
+!***********************************************************************
+!
+!        File: concom.cmn
+!
+!        MSC.Marc include file
+!
+ integer(pInt) &
+       iacous, iasmbl, iautth,    ibear,  icompl,    iconj,  icreep, ideva,     idyn,   idynt,&
+       ielas,  ielcma, ielect,    iform,  ifour,     iharm,  ihcps,  iheat,     iheatt, ihresp,&
+       ijoule, ilem,   ilnmom,    iloren, inc,       incext, incsub, ipass,     iplres, ipois,&
+       ipoist, irpflo, ismall,    ismalt, isoil,     ispect, ispnow, istore,    iswep,  ithcrp,&
+       itherm, iupblg, iupdat,    jacflg, jel,       jparks, largst, lfond,     loadup, loaduq,&
+       lodcor, lovl,   lsub,      magnet, ncycle,    newtnt, newton, noshr,     linear, ivscpl,&
+       icrpim, iradrt, ipshft,    itshr,  iangin,    iupmdr, iconjf, jincfl,    jpermg, jhour,&
+       isolvr, jritz,  jtable,    jshell, jdoubl,    jform,  jcentr, imini,     kautth, iautof,&
+       ibukty, iassum, icnstd,    icnstt, kmakmas,   imethvp,iradrte,iradrtp,   iupdate,iupdatp,&
+       ncycnt, marmen ,idynme,    ihavca, ispf,      kmini,  imixed, largtt,    kdoela, iautofg,&
+       ipshftp,idntrc, ipore,     jtablm, jtablc,    isnecma,itrnspo,imsdif,    jtrnspo,mcnear,&
+       imech,  imecht, ielcmat,   ielectt,magnett,   imsdift,noplas, jtabls,    jactch, jtablth,&
+       kgmsto ,jpzo,   ifricsh,   iremkin,iremfor,   ishearp,jspf,   machining, jlshell,icompsol,&
+       iupblgfo,jcondir,nstcrp,   nactive,ipassref,  nstspnt,ibeart,icheckmpc,  noline, icuring,&
+       ishrink,ioffsflg,isetoff,  ioffsetm,iharmt,   inc_incdat,iautspc,ibrake, icbush ,istream_input,&
+       iprsinp,ivlsinp,ifirst_time,ipin_m,jgnstr_glb,imarc_return,iqvcinp,nqvceid,istpnx,imicro1,&
+       iaxisymm,jbreakglue,iglstif,jfastasm,iwear,   iwearcf,  imixmeth,ielcmadyn,idinout,igena_meth
+ integer(pInt) num_concom
+ parameter(num_concom=219)
+ common/marc_concom/&
+       iacous, iasmbl, iautth,    ibear,  icompl,    iconj,  icreep, ideva(50), idyn,   idynt,&
+       ielas,  ielcma, ielect,    iform,  ifour,     iharm,  ihcps,  iheat,     iheatt, ihresp,&
+       ijoule, ilem,   ilnmom,    iloren, inc,       incext, incsub, ipass,     iplres, ipois,&
+       ipoist, irpflo, ismall,    ismalt, isoil,     ispect, ispnow, istore,    iswep,  ithcrp,&
+       itherm, iupblg, iupdat,    jacflg, jel,       jparks, largst, lfond,     loadup, loaduq,&
+       lodcor, lovl,   lsub,      magnet, ncycle,    newtnt, newton, noshr,     linear, ivscpl,&
+       icrpim, iradrt, ipshft,    itshr,  iangin,    iupmdr, iconjf, jincfl,    jpermg, jhour,&
+       isolvr, jritz,  jtable,    jshell, jdoubl,    jform,  jcentr, imini,     kautth, iautof,&
+       ibukty, iassum, icnstd,    icnstt, kmakmas,   imethvp,iradrte,iradrtp,   iupdate,iupdatp,&
+       ncycnt, marmen ,idynme,    ihavca, ispf,      kmini,  imixed, largtt,    kdoela, iautofg,&
+       ipshftp,idntrc, ipore,     jtablm, jtablc,    isnecma,itrnspo,imsdif,    jtrnspo,mcnear,&
+       imech,  imecht, ielcmat,   ielectt,magnett,   imsdift,noplas, jtabls,    jactch, jtablth,&
+       kgmsto ,jpzo,   ifricsh,   iremkin,iremfor,   ishearp,jspf,   machining, jlshell,icompsol,&
+       iupblgfo,jcondir,nstcrp,   nactive,ipassref,  nstspnt,ibeart,icheckmpc,  noline, icuring,&
+       ishrink,ioffsflg,isetoff,  ioffsetm,iharmt,   inc_incdat,iautspc,ibrake, icbush ,istream_input,&
+       iprsinp,ivlsinp,ifirst_time,ipin_m,jgnstr_glb,imarc_return,iqvcinp,nqvceid,istpnx,imicro1,&
+       iaxisymm,jbreakglue,iglstif,jfastasm,iwear,   iwearcf, imixmeth,  ielcmadyn,idinout,igena_meth
+!
+! comments of variables:
+!
+! ideva(50) -   debug print out flag
+!       1       print element stiffness matrices, mass matrix
+!       2       output matrices used in tying
+!       3       force the solution of a nonpositive definite matrix
+!       4       print info of connections to each node
+!       5       info of gap convergence, internal heat generated, contact
+!               touching and separation 
+!       6       nodal value array during rezoning
+!       7       tying info in CONRAD GAP option, fluid element numbers in
+!               CHANNEL option
+!       8       output incremental displacements in local coord. system
+!       9       latent heat output
+!       10      stress-strain in local coord. system
+!       11      additional info on  interlaminar stress 
+!       12      output right hand side and solution vector
+!       13      info of CPU resources used and memory available on NT
+!       14      info of mesh adaption process, 2D outline information
+!               info of penetration checking for remeshing
+!               save .fem files after afmesh3d meshing
+!       15      surface energy balance flag  
+!       16      print info regarding pyrolysis   
+!       17      print info of "streamline topology"  
+!       18      print mesh data changes after remeshing
+!       19      print material flow stress data read in from *.mat file
+!               if unit flag is on, print out flow stress after conversion
+!       20      print information on table input
+!       21      print out information regarding kinematic boundary conditions
+!       22      print out information regarding dist loads, point loads, film 
+!               and foundations
+!       23      print out information about automatic domain decomposition
+!       24      print out iteration information in SuperForm status report file
+!       25      print out information for ablation
+!       26      print out information for films - Table input
+!       27      print out the tying forces
+!       28      print out for CASI solver, convection, 
+!       29      DDM single file debug printout
+!       30      print out cavity debug info
+!       31      print out welding related info
+!       32      prints categorized DDM memory usage
+!       33      print out the cutting info regarding machining feature
+!       34      print out the list of quantities which can be defined via a table
+!               and for each quantity the supported independent variables
+!       35      print out detailed coupling region info
+!       36      print out solver debug info level 1 (Least  Detailed)
+!       37      print out solver debug info level 1 (Medium Detailed)
+!       38      print out solver debug info level 1 (Very   Detailed)
+!       39      print detailed memory allocation info
+!       40      print out marc-adams debug info
+!       41      output rezone mapping post file for debugging
+!       42      output post file after calling oprofos() for debugging
+!       43      debug printout for vcct
+!       44      debug printout for progressive failure
+!       45      print out automatically generated midside node coordinates (arecrd)
+!       46      print out message about routine and location, where the ibort is raised (ibort_inc)
+!       47      print out summary message of element variables on a 
+!               group-basis after all the automatic changes have been 
+!               made (em_ellibp)
+!       48      Automatically generate check results based on max and min vals.
+!                These vals are stored in the checkr file, which is inserted 
+!                into the *dat file by the generate_check_results script from /marc/tools
+!       49      Automatically generate check results based on the real calculated values 
+!                at the sppecified check result locations.
+!                These vals are stored in the checkr file, which is inserted 
+!                into the *dat file by the update_check_results script from /marc/tools
+!
+!
+! jactch        = 1 or 2 if elements are activated or deactivated
+!               = 3 if elements are adaptively remeshed or rezoned
+!               = 0 normally / reset to 0 when assembly is done
+! ifricsh       = 0 call to fricsh in otest not needed
+!               = 1 call to fricsh (nodal friction) in otest needed
+! iremkin       = 0  remove deactivated kinematic boundary conditions 
+!                    immediately - only in new input format (this is default)
+!               = 1  remove deactivated kinematic boundary conditions 
+!                    gradually - only in new input format 
+! iremfor       = 0  remove force boundary conditions immediately - 
+!                    only in new input format (this is default)
+!               = 1  remove force boundary conditions gradually - 
+!                    only in new input format (this is default)
+! ishearp       set to 1 if shear panel elements are present in the model
+!
+! jspf          = 0  not in spf loadcase
+!               > 0 in spf loadcase (jspf=1 during first increment)
+! machining     = 1  if the metal cutting feature is used, for memory allocation purpose
+!               = 0  (default) if no metal cutting feature required
+!
+! jlshell       = 1 if there is a shell element in the mesh
+! icompsol      = 1 if there is a composite solid element in the mesh
+! iupblgfo      = 1 if follower force for point loads 
+! jcondir       = 1 if contact priority option is used
+! nstcrp        = 0 (default) steady state creep flag (undocumented feature. 
+!                    if not 0, turns off special ncycle = 0 code in radial.f)
+! nactive       = number of active passes, if =1 then it's not a coupled analysis
+! ipassref      = reference ipass, if not in a multiphysics pass ipass=ipassref
+! icheckmpc     = value of mpc-check parameter option
+! noline        = set to 1 in osolty if no line seacrh should be done in ogetst
+! icuring       = set to 1 if the curing is included for the heat transfer analysis.
+! ishrink       = set to 1 if shrinkage strain is included for mechancial analysis.
+! ioffsflg      =  1 for small displacement beam/shell offsets
+!               =  2 for large displacement beam/shell offsets
+! isetoff       =  0 - do not apply beam/shell offsets
+!               =  1 -  apply beam/shell offsets
+! ioffsetm      = min. value of offset flag
+! inc_incdat    = flag to record increment number of a new loadcase in incdat.f
+! iautspc       = flag for AutoSPC option
+! ibrake        = brake squeal in this increment
+! icbush        = set to 1 if cbush elements present in model
+! istream_input = set to 1 for streaming input calling Marc as library
+! iprsinp       = set to 1 if pressure input, introduced so other variables 
+!                 such as h could be a function of pressure
+! ivlsinp       = set to 1 if velocity input, introduced so other variables 
+!                 such as h could be a function of velocity
+! ipin_m        = # of beam element with PIN flag
+! jgnstr_glb    = global control over pre or fast integrated composite shells
+! imarc_return  = Marc return flag for streaming input control
+! iqvcimp       = if non-zero, then the number of QVECT boundary conditions
+! nqvceid       = number of QVECT boundary conditions, where emisivity/absorbtion id entered
+! istpnx        = 1 if to stop at end of increment
+! imicro1       = 1 if micro1 interface is used
+! iaxisymm      = set to 1 if axisymmetric analysis
+! jbreakglue    = set to 1 if breaking glued option is used
+! iglstif       = 1 if ddm and global stiffness matrix formed (sgi solver 6 or solver9)
+! jfastasm      = 1 do fast assembly using SuperForm code
+! iwear         = set to 1 if wear model, set to 2 if wear model and coordinates updated
+! iwearcf       = set to 1 to store nodal coefficient of friction for wear calculation
+! imixmeth      = set=1 then use nonlinear mixture material - allocate memory
+! ielcmadyn     = flag for magnetodynamics
+!                 0 - electromagnetics using newmark beta
+!                 1 - transient magnetics using backward euler
+! idinout       = flag to control if inside out elements should be deactivated
+! igena_meth    = 0  - generalized alpha parameters depend on whether or not contact
+!                      is flagged (dynamic,7) 
+!                 10 - generalized alpha parameters are optimized for a contact
+!                      analysis (dynamic,8)
+!                 11 - generalized alpha parameters are optimized for an analysis
+!                      without contact (dynamic,8)
+!
+!***********************************************************************
diff --git a/trunk/creeps2008r1 b/trunk/creeps2008r1
index f6b24f413..71cb7cf34 100644
--- a/trunk/creeps2008r1
+++ b/trunk/creeps2008r1
@@ -1,28 +1,28 @@
-! reformated to free format
-!***********************************************************************
-!
-!        File: creeps.cmn
-!
-!        MSC.Marc include file
-!
- real(pReal)  cptim,timinc,timinc_p,timinc_s,timincm,timinc_a,timinc_b,creept
- integer(pInt) icptim,icfte,icfst,icfeq,icftm,icetem,mcreep,jcreep,icpa,icftmp,icfstr,&
-         icfqcp,icfcpm,icrppr,icrcha,icpb,iicpmt,iicpa
- real(pReal)  time_beg_lcase,time_beg_inc,fractol,time_beg_pst
-!
- integer num_creepsr,num_creepsi,num_creeps2r
- parameter(num_creepsr=40)
- parameter(num_creepsi=18)
- parameter(num_creeps2r=4)
- common/marc_creeps/cptim,timinc,timinc_p,timinc_s,timincm,timinc_a,timinc_b,creept(33),icptim,icfte,icfst,&
-       icfeq,icftm,icetem,mcreep,jcreep,icpa,icftmp,icfstr,icfqcp,icfcpm,icrppr,icrcha,icpb,iicpmt,iicpa
- common/marc_creeps2/time_beg_lcase,time_beg_inc,fractol,time_beg_pst
-!
-!  time_beg_lcase  time at the beginning of the current load case
-!  time_beg_inc    time at the beginning of the current increment
-!  fractol         fraction of loadcase or increment time when we
-!                  consider it to be finished
-!  time_beg_pst    time corresponding to first increment to be
-!                  read in from thermal post file for auto step
-!
-!***********************************************************************
+! reformated to free format
+!***********************************************************************
+!
+!        File: creeps.cmn
+!
+!        MSC.Marc include file
+!
+ real(pReal)  cptim,timinc,timinc_p,timinc_s,timincm,timinc_a,timinc_b,creept
+ integer(pInt) icptim,icfte,icfst,icfeq,icftm,icetem,mcreep,jcreep,icpa,icftmp,icfstr,&
+         icfqcp,icfcpm,icrppr,icrcha,icpb,iicpmt,iicpa
+ real(pReal)  time_beg_lcase,time_beg_inc,fractol,time_beg_pst
+!
+ integer num_creepsr,num_creepsi,num_creeps2r
+ parameter(num_creepsr=40)
+ parameter(num_creepsi=18)
+ parameter(num_creeps2r=4)
+ common/marc_creeps/cptim,timinc,timinc_p,timinc_s,timincm,timinc_a,timinc_b,creept(33),icptim,icfte,icfst,&
+       icfeq,icftm,icetem,mcreep,jcreep,icpa,icftmp,icfstr,icfqcp,icfcpm,icrppr,icrcha,icpb,iicpmt,iicpa
+ common/marc_creeps2/time_beg_lcase,time_beg_inc,fractol,time_beg_pst
+!
+!  time_beg_lcase  time at the beginning of the current load case
+!  time_beg_inc    time at the beginning of the current increment
+!  fractol         fraction of loadcase or increment time when we
+!                  consider it to be finished
+!  time_beg_pst    time corresponding to first increment to be
+!                  read in from thermal post file for auto step
+!
+!***********************************************************************
diff --git a/trunk/lattice.f90 b/trunk/lattice.f90
index 77ffe208c..399fa0728 100644
--- a/trunk/lattice.f90
+++ b/trunk/lattice.f90
@@ -1,629 +1,629 @@
-
-!************************************
-!*         Module: LATTICE          *
-!************************************
-!* contains:                        *
-!* - Lattice structure definition   *
-!* - Slip system definition         *
-!* - Schmid matrices calculation    *
-!************************************
-
-MODULE lattice
-
-!*** Include other modules ***
-use prec, only: pReal,pInt
-implicit none
-
-!************************************
-!*      Lattice structures          *
-!************************************
-!* Number of lattice structures (1-FCC,2-BCC,3-HCP)
-integer(pInt), parameter :: lattice_MaxLatticeStructure = 3
-!* Total number of slip systems per lattice structure
-!* (has to be changed according the definition of slip systems)
-integer(pInt), dimension(lattice_MaxLatticeStructure), parameter :: lattice_MaxNslipOfStructure = &
-reshape((/12,48,24/),(/lattice_MaxLatticeStructure/))
-!* Total number of twin systems per lattice structure
-!* (has to be changed according the definition of twin systems)
-integer(pInt), dimension(lattice_MaxLatticeStructure), parameter :: lattice_MaxNtwinOfStructure = &
-reshape((/12,0,24/),(/lattice_MaxLatticeStructure/))
-!* Maximum number of slip systems over lattice structures
-integer(pInt), parameter :: lattice_MaxMaxNslipOfStructure = 48
-!* Maximum number of twin systems over lattice structures,  changed form 12 to 24 (yj.ro)
-integer(pInt), parameter :: lattice_MaxMaxNtwinOfStructure = 24
-!* Slip direction, slip normales and Schmid matrices
-real(pReal), dimension(3,3,lattice_MaxMaxNslipOfStructure,lattice_MaxLatticeStructure) :: lattice_Sslip
-real(pReal), dimension(6,lattice_MaxMaxNslipOfStructure,lattice_MaxLatticeStructure) :: lattice_Sslip_v
-real(pReal), dimension(3,lattice_MaxMaxNslipOfStructure,lattice_MaxLatticeStructure) :: lattice_sn
-real(pReal), dimension(3,lattice_MaxMaxNslipOfStructure,lattice_MaxLatticeStructure) :: lattice_sd
-real(pReal), dimension(3,lattice_MaxMaxNslipOfStructure,lattice_MaxLatticeStructure) :: lattice_st
-
-!* HCP - slip direction, slip normal (4 indices): Prof. Tom Bieler, Leeyun, YJRO 
-real(pReal), dimension(4,lattice_MaxMaxNslipOfStructure,lattice_MaxLatticeStructure) :: Hlattice_sn
-real(pReal), dimension(4,lattice_MaxMaxNslipOfStructure,lattice_MaxLatticeStructure) :: Hlattice_sd
-real(pReal), dimension(3,lattice_MaxMaxNslipOfStructure,lattice_MaxLatticeStructure) :: H_lattice_sn
-real(pReal), dimension(3,lattice_MaxMaxNslipOfStructure,lattice_MaxLatticeStructure) :: H_lattice_sd
-
-!* twin direction, twin normales, Schmid matrices and transformation matrices
-real(pReal), dimension(3,3,lattice_MaxMaxNtwinOfStructure,lattice_MaxLatticeStructure) :: lattice_Stwin
-real(pReal), dimension(6,lattice_MaxMaxNtwinOfStructure,lattice_MaxLatticeStructure) :: lattice_Stwin_v
-real(pReal), dimension(3,lattice_MaxMaxNtwinOfStructure,lattice_MaxLatticeStructure) :: lattice_tn
-real(pReal), dimension(3,lattice_MaxMaxNtwinOfStructure,lattice_MaxLatticeStructure) :: lattice_td
-real(pReal), dimension(3,lattice_MaxMaxNtwinOfStructure,lattice_MaxLatticeStructure) :: lattice_tt
-real(pReal), dimension(3,3,lattice_MaxMaxNtwinOfStructure,lattice_MaxLatticeStructure) :: lattice_Qtwin
-
-!* HCP - twin direction, twin normales for 4 indices: Prof. Tom Bieler, Leeyun, YJR 
-real(pReal), dimension(4,lattice_MaxMaxNtwinOfStructure,lattice_MaxLatticeStructure) :: Hlattice_tn
-real(pReal), dimension(4,lattice_MaxMaxNtwinOfStructure,lattice_MaxLatticeStructure) :: Hlattice_td
-real(pReal), dimension(3,lattice_MaxMaxNtwinOfStructure,lattice_MaxLatticeStructure) :: H_lattice_tn
-real(pReal), dimension(3,lattice_MaxMaxNtwinOfStructure,lattice_MaxLatticeStructure) :: H_lattice_td
-
-
-real(pReal), dimension(lattice_MaxLatticeStructure), parameter :: lattice_TwinShear = &
-reshape((/0.7071067812,0.7071067812,0.7071067812/),(/lattice_MaxLatticeStructure/)) ! Depends surely on c/a ratio for HCP
-
-
-!* Slip_slip interaction matrices
-integer(pInt), dimension(lattice_MaxMaxNslipOfStructure,lattice_MaxMaxNslipOfStructure,lattice_MaxLatticeStructure) :: &
-lattice_SlipIntType
-!* Slip_twin interaction matrices
-integer(pInt), dimension(lattice_MaxMaxNslipOfStructure,lattice_MaxMaxNtwinOfStructure,lattice_MaxLatticeStructure) :: &
-lattice_SlipTwinIntType
-!* Twin-twin interaction matrices
-integer(pInt), dimension(lattice_MaxMaxNtwinOfStructure,lattice_MaxMaxNtwinOfStructure,lattice_MaxLatticeStructure) :: &
-lattice_TwinIntType
-
-!*** Slip systems for FCC structures (1) ***
-!* System {111}<110>  Sort according Eisenlohr&Hantcherli
-data lattice_sd(:, 1,1)/ 0, 1,-1/ ; data lattice_sn(:, 1,1)/ 1, 1, 1/
-data lattice_sd(:, 2,1)/-1, 0, 1/ ; data lattice_sn(:, 2,1)/ 1, 1, 1/
-data lattice_sd(:, 3,1)/ 1,-1, 0/ ; data lattice_sn(:, 3,1)/ 1, 1, 1/
-data lattice_sd(:, 4,1)/ 0,-1,-1/ ; data lattice_sn(:, 4,1)/-1,-1, 1/
-data lattice_sd(:, 5,1)/ 1, 0, 1/ ; data lattice_sn(:, 5,1)/-1,-1, 1/
-data lattice_sd(:, 6,1)/-1, 1, 0/ ; data lattice_sn(:, 6,1)/-1,-1, 1/
-data lattice_sd(:, 7,1)/ 0,-1, 1/ ; data lattice_sn(:, 7,1)/ 1,-1,-1/
-data lattice_sd(:, 8,1)/-1, 0,-1/ ; data lattice_sn(:, 8,1)/ 1,-1,-1/
-data lattice_sd(:, 9,1)/ 1, 1, 0/ ; data lattice_sn(:, 9,1)/ 1,-1,-1/
-data lattice_sd(:,10,1)/ 0, 1, 1/ ; data lattice_sn(:,10,1)/-1, 1,-1/
-data lattice_sd(:,11,1)/ 1, 0,-1/ ; data lattice_sn(:,11,1)/-1, 1,-1/
-data lattice_sd(:,12,1)/-1,-1, 0/ ; data lattice_sn(:,12,1)/-1, 1,-1/
-
-!*** Twin systems for FCC structures (1) ***
-!* System {111}<112>  Sort according Eisenlohr&Hantcherli
-data lattice_td(:, 1,1)/-2, 1, 1/ ; data lattice_tn(:, 1,1)/ 1, 1, 1/
-data lattice_td(:, 2,1)/ 1,-2, 1/ ; data lattice_tn(:, 2,1)/ 1, 1, 1/
-data lattice_td(:, 3,1)/ 1, 1,-2/ ; data lattice_tn(:, 3,1)/ 1, 1, 1/
-data lattice_td(:, 4,1)/ 2,-1, 1/ ; data lattice_tn(:, 4,1)/-1,-1, 1/
-data lattice_td(:, 5,1)/-1, 2, 1/ ; data lattice_tn(:, 5,1)/-1,-1, 1/
-data lattice_td(:, 6,1)/-1,-1,-2/ ; data lattice_tn(:, 6,1)/-1,-1, 1/
-data lattice_td(:, 7,1)/-2,-1,-1/ ; data lattice_tn(:, 7,1)/ 1,-1,-1/
-data lattice_td(:, 8,1)/ 1, 2,-1/ ; data lattice_tn(:, 8,1)/ 1,-1,-1/
-data lattice_td(:, 9,1)/ 1,-1, 2/ ; data lattice_tn(:, 9,1)/ 1,-1,-1/
-data lattice_td(:,10,1)/ 2, 1,-1/ ; data lattice_tn(:,10,1)/-1, 1,-1/
-data lattice_td(:,11,1)/-1,-2,-1/ ; data lattice_tn(:,11,1)/-1, 1,-1/
-data lattice_td(:,12,1)/-1, 1, 2/ ; data lattice_tn(:,12,1)/-1, 1,-1/
-
-!*** Slip-Slip interactions for FCC structures (1) ***
-data lattice_SlipIntType( 1,1:lattice_MaxNslipOfStructure(1),1)/1,2,2,4,6,5,3,5,5,4,5,6/
-data lattice_SlipIntType( 2,1:lattice_MaxNslipOfStructure(1),1)/2,1,2,6,4,5,5,4,6,5,3,5/
-data lattice_SlipIntType( 3,1:lattice_MaxNslipOfStructure(1),1)/2,2,1,5,5,3,5,6,4,6,5,4/
-data lattice_SlipIntType( 4,1:lattice_MaxNslipOfStructure(1),1)/4,6,5,1,2,2,4,5,6,3,5,5/
-data lattice_SlipIntType( 5,1:lattice_MaxNslipOfStructure(1),1)/6,4,5,2,1,2,5,3,5,5,4,6/
-data lattice_SlipIntType( 6,1:lattice_MaxNslipOfStructure(1),1)/5,5,3,2,2,1,6,5,4,5,6,4/
-data lattice_SlipIntType( 7,1:lattice_MaxNslipOfStructure(1),1)/3,5,5,4,5,6,1,2,2,4,6,5/
-data lattice_SlipIntType( 8,1:lattice_MaxNslipOfStructure(1),1)/5,4,6,5,3,5,2,1,2,6,4,5/
-data lattice_SlipIntType( 9,1:lattice_MaxNslipOfStructure(1),1)/5,6,4,6,5,4,2,2,1,5,5,3/
-data lattice_SlipIntType(10,1:lattice_MaxNslipOfStructure(1),1)/4,5,6,3,5,5,4,6,5,1,2,2/
-data lattice_SlipIntType(11,1:lattice_MaxNslipOfStructure(1),1)/5,3,5,5,4,6,6,4,5,2,1,2/
-data lattice_SlipIntType(12,1:lattice_MaxNslipOfStructure(1),1)/6,5,4,5,6,4,5,5,3,2,2,1/
-
-!*** Slip-Twin interactions for FCC structures (1) ***
-data lattice_SlipTwinIntType( 1,1:lattice_MaxNtwinOfStructure(1),1)/0,0,0,1,1,1,0,0,0,1,1,1/
-data lattice_SlipTwinIntType( 2,1:lattice_MaxNtwinOfStructure(1),1)/0,0,0,1,1,1,1,1,1,0,0,0/
-data lattice_SlipTwinIntType( 3,1:lattice_MaxNtwinOfStructure(1),1)/0,0,0,0,0,0,1,1,1,1,1,1/
-data lattice_SlipTwinIntType( 4,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,0,0,0,1,1,1,0,0,0/
-data lattice_SlipTwinIntType( 5,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,0,0,0,0,0,0,1,1,1/
-data lattice_SlipTwinIntType( 6,1:lattice_MaxNtwinOfStructure(1),1)/0,0,0,0,0,0,1,1,1,1,1,1/
-data lattice_SlipTwinIntType( 7,1:lattice_MaxNtwinOfStructure(1),1)/0,0,0,1,1,1,0,0,0,1,1,1/
-data lattice_SlipTwinIntType( 8,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,0,0,0,0,0,0,1,1,1/
-data lattice_SlipTwinIntType( 9,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,1,1,1,0,0,0,0,0,0/
-data lattice_SlipTwinIntType(10,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,0,0,0,1,1,1,0,0,0/
-data lattice_SlipTwinIntType(11,1:lattice_MaxNtwinOfStructure(1),1)/0,0,0,1,1,1,1,1,1,0,0,0/
-data lattice_SlipTwinIntType(12,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,1,1,1,0,0,0,0,0,0/
-
-!*** Twin-Twin interactions for FCC structures (1) ***
-data lattice_TwinIntType( 1,1:lattice_MaxNtwinOfStructure(1),1)/0,0,0,1,1,1,1,1,1,1,1,1/
-data lattice_TwinIntType( 2,1:lattice_MaxNtwinOfStructure(1),1)/0,0,0,1,1,1,1,1,1,1,1,1/
-data lattice_TwinIntType( 3,1:lattice_MaxNtwinOfStructure(1),1)/0,0,0,1,1,1,1,1,1,1,1,1/
-data lattice_TwinIntType( 4,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,0,0,0,1,1,1,1,1,1/
-data lattice_TwinIntType( 5,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,0,0,0,1,1,1,1,1,1/
-data lattice_TwinIntType( 6,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,0,0,0,1,1,1,1,1,1/
-data lattice_TwinIntType( 7,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,1,1,1,0,0,0,1,1,1/
-data lattice_TwinIntType( 8,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,1,1,1,0,0,0,1,1,1/
-data lattice_TwinIntType( 9,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,1,1,1,0,0,0,1,1,1/
-data lattice_TwinIntType(10,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,1,1,1,1,1,1,0,0,0/
-data lattice_TwinIntType(11,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,1,1,1,1,1,1,0,0,0/
-data lattice_TwinIntType(12,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,1,1,1,1,1,1,0,0,0/
-
-!*** Slip systems for BCC structures (2) ***
-!* System {110}<111>
-!* Sort?
-data lattice_sd(:, 1,2)/ 1,-1, 1/ ; data lattice_sn(:, 1,2)/ 0, 1, 1/
-data lattice_sd(:, 2,2)/-1,-1, 1/ ; data lattice_sn(:, 2,2)/ 0, 1, 1/
-data lattice_sd(:, 3,2)/ 1, 1, 1/ ; data lattice_sn(:, 3,2)/ 0,-1, 1/
-data lattice_sd(:, 4,2)/-1, 1, 1/ ; data lattice_sn(:, 4,2)/ 0,-1, 1/
-data lattice_sd(:, 5,2)/-1, 1, 1/ ; data lattice_sn(:, 5,2)/ 1, 0, 1/
-data lattice_sd(:, 6,2)/-1,-1, 1/ ; data lattice_sn(:, 6,2)/ 1, 0, 1/
-data lattice_sd(:, 7,2)/ 1, 1, 1/ ; data lattice_sn(:, 7,2)/-1, 0, 1/
-data lattice_sd(:, 8,2)/ 1,-1, 1/ ; data lattice_sn(:, 8,2)/-1, 0, 1/
-data lattice_sd(:, 9,2)/-1, 1, 1/ ; data lattice_sn(:, 9,2)/ 1, 1, 0/
-data lattice_sd(:,10,2)/-1, 1,-1/ ; data lattice_sn(:,10,2)/ 1, 1, 0/
-data lattice_sd(:,11,2)/ 1, 1, 1/ ; data lattice_sn(:,11,2)/-1, 1, 0/
-data lattice_sd(:,12,2)/ 1, 1,-1/ ; data lattice_sn(:,12,2)/-1, 1, 0/
-!* System {112}<111>
-!* Sort?
-data lattice_sd(:,13,2)/-1, 1, 1/ ; data lattice_sn(:,13,2)/ 2, 1, 1/
-data lattice_sd(:,14,2)/ 1, 1, 1/ ; data lattice_sn(:,14,2)/-2, 1, 1/
-data lattice_sd(:,15,2)/ 1, 1,-1/ ; data lattice_sn(:,15,2)/ 2,-1, 1/
-data lattice_sd(:,16,2)/ 1,-1, 1/ ; data lattice_sn(:,16,2)/ 2, 1,-1/
-data lattice_sd(:,17,2)/ 1,-1, 1/ ; data lattice_sn(:,17,2)/ 1, 2, 1/
-data lattice_sd(:,18,2)/ 1, 1,-1/ ; data lattice_sn(:,18,2)/-1, 2, 1/
-data lattice_sd(:,19,2)/ 1, 1, 1/ ; data lattice_sn(:,19,2)/ 1,-2, 1/
-data lattice_sd(:,20,2)/-1, 1, 1/ ; data lattice_sn(:,20,2)/ 1, 2,-1/
-data lattice_sd(:,21,2)/ 1, 1,-1/ ; data lattice_sn(:,21,2)/ 1, 1, 2/
-data lattice_sd(:,22,2)/ 1,-1, 1/ ; data lattice_sn(:,22,2)/-1, 1, 2/
-data lattice_sd(:,23,2)/-1, 1, 1/ ; data lattice_sn(:,23,2)/ 1,-1, 2/
-data lattice_sd(:,24,2)/ 1, 1, 1/ ; data lattice_sn(:,24,2)/ 1, 1,-2/
-!* System {123}<111>
-!* Sort?
-data lattice_sd(:,25,2)/ 1, 1,-1/ ; data lattice_sn(:,25,2)/ 1, 2, 3/
-data lattice_sd(:,26,2)/ 1,-1, 1/ ; data lattice_sn(:,26,2)/-1, 2, 3/
-data lattice_sd(:,27,2)/-1, 1, 1/ ; data lattice_sn(:,27,2)/ 1,-2, 3/
-data lattice_sd(:,28,2)/ 1, 1, 1/ ; data lattice_sn(:,28,2)/ 1, 2,-3/
-data lattice_sd(:,29,2)/ 1,-1, 1/ ; data lattice_sn(:,29,2)/ 1, 3, 2/
-data lattice_sd(:,30,2)/ 1, 1,-1/ ; data lattice_sn(:,30,2)/-1, 3, 2/
-data lattice_sd(:,31,2)/ 1, 1, 1/ ; data lattice_sn(:,31,2)/ 1,-3, 2/
-data lattice_sd(:,32,2)/-1, 1, 1/ ; data lattice_sn(:,32,2)/ 1, 3,-2/
-data lattice_sd(:,33,2)/ 1, 1,-1/ ; data lattice_sn(:,33,2)/ 2, 1, 3/
-data lattice_sd(:,34,2)/ 1,-1, 1/ ; data lattice_sn(:,34,2)/-2, 1, 3/
-data lattice_sd(:,35,2)/-1, 1, 1/ ; data lattice_sn(:,35,2)/ 2,-1, 3/
-data lattice_sd(:,36,2)/ 1, 1, 1/ ; data lattice_sn(:,36,2)/ 2, 1,-3/
-data lattice_sd(:,37,2)/ 1,-1, 1/ ; data lattice_sn(:,37,2)/ 2, 3, 1/
-data lattice_sd(:,38,2)/ 1, 1,-1/ ; data lattice_sn(:,38,2)/-2, 3, 1/
-data lattice_sd(:,39,2)/ 1, 1, 1/ ; data lattice_sn(:,39,2)/ 2,-3, 1/
-data lattice_sd(:,40,2)/-1, 1, 1/ ; data lattice_sn(:,40,2)/ 2, 3,-1/
-data lattice_sd(:,41,2)/-1, 1, 1/ ; data lattice_sn(:,41,2)/ 3, 1, 2/
-data lattice_sd(:,42,2)/ 1, 1, 1/ ; data lattice_sn(:,42,2)/-3, 1, 2/
-data lattice_sd(:,43,2)/ 1, 1,-1/ ; data lattice_sn(:,43,2)/ 3,-1, 2/
-data lattice_sd(:,44,2)/ 1,-1, 1/ ; data lattice_sn(:,44,2)/ 3, 1,-2/
-data lattice_sd(:,45,2)/-1, 1, 1/ ; data lattice_sn(:,45,2)/ 3, 2, 1/
-data lattice_sd(:,46,2)/ 1, 1, 1/ ; data lattice_sn(:,46,2)/-3, 2, 1/
-data lattice_sd(:,47,2)/ 1, 1,-1/ ; data lattice_sn(:,47,2)/ 3,-2, 1/
-data lattice_sd(:,48,2)/ 1,-1, 1/ ; data lattice_sn(:,48,2)/ 3, 2,-1/
-
-!*** Twin systems for BCC structures (2) ***
-!* System {112}<111>
-!* Sort?
-!* MISSING: not implemented yet
-
-!*** Slip-Slip interactions for BCC structures (2) ***
-data lattice_SlipIntType( 1,:,2)/1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType( 2,:,2)/2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType( 3,:,2)/2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType( 4,:,2)/2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType( 5,:,2)/2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType( 6,:,2)/2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType( 7,:,2)/2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType( 8,:,2)/2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType( 9,:,2)/2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(10,:,2)/2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(11,:,2)/2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(12,:,2)/2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(13,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(14,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(15,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(16,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(17,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(18,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(19,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(20,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(21,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(22,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(23,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(24,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(25,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(26,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(27,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(28,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(29,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(30,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(31,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(32,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(33,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(34,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(35,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(36,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(37,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(38,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(39,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(40,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(41,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2/
-data lattice_SlipIntType(42,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2/
-data lattice_SlipIntType(43,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2/
-data lattice_SlipIntType(44,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2/
-data lattice_SlipIntType(45,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2/
-data lattice_SlipIntType(46,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2/
-data lattice_SlipIntType(47,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2/
-data lattice_SlipIntType(48,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1/
-
-!*** Slip-twin interactions for BCC structures (2) ***
-! MISSING: not implemented yet
-
-!*** Twin-twin interactions for BCC structures (2) ***
-! MISSING: not implemented yet
-
-!*** Slip systems for HCP structures (3) ***
-!* Basal systems {0001}<1120> (independent of c/a-ratio)
-!* 1- [2  -1  -1  0](0 0 0 1)
-!* 2- [-1  2  -1  0](0 0 0 1)
-!* 3- [-1 -1   2  0](0 0 0 1)
-!* Automatical transformation from Bravais (4 axes coorinate system) to Miller (in ortho-hexagonal coordinate system)
-!* not done for the moment
-!* Sort? Changed order of slip system and sign of Burges vector (Tom Bieler, yj.ro)
-data Hlattice_sd(:, 1,3)/ 2, -1, -1,  0/ ; data Hlattice_sn(:, 1,3)/ 0,  0,  0,  1/
-data Hlattice_sd(:, 2,3)/-1,  2, -1,  0/ ; data Hlattice_sn(:, 2,3)/ 0,  0,  0,  1/
-data Hlattice_sd(:, 3,3)/-1, -1,  2,  0/ ; data Hlattice_sn(:, 3,3)/ 0,  0,  0,  1/
-!* 1st type prismatic systems {1010}<1120>  (independent of c/a-ratio)
-!* 4- [ 2 -1 -1  0]( 0  1 -1  0)
-!* 5- [-1  2 -1  0]( 1  0 -1  0)
-!* 6- [-1 -1  2  0](-1  1  0  0)
-!* Sort? Changed order of slip system and sign of Burges vector (yj.ro)
-data Hlattice_sd(:, 4,3)/ 2, -1, -1,  0/ ; data Hlattice_sn(:, 4,3)/ 0,  1, -1,  0/
-data Hlattice_sd(:, 5,3)/-1,  2, -1,  0/ ; data Hlattice_sn(:, 5,3)/ 1,  0, -1,  0/
-data Hlattice_sd(:, 6,3)/-1, -1,  2,  0/ ; data Hlattice_sn(:, 6,3)/-1,  1,  0,  0/
-!* 1st type 1st order pyramidal systems {1011}<1120>
-!* plane normales depend on the c/a-ratio
-!*	7- [ 2 -1 -1  0]( 0  1 -1  1)
-!*  8- [-1  2 -1  0]( 1  0 -1  1)
-!*  9- [-1 -1  2  0](-1  1  0  1)
-!* 10- [ 2 -1 -1  0]( 0 -1  1  1)
-!* 11- [-1  2 -1  0](-1  0  1  1)
-!* 12- [-1 -1  2  0]( 1 -1  0  1)
-!* Sort? Changed order of slip system and sign of Burges vector (Tom Bieler, yj.ro)
-data Hlattice_sd(:, 7,3)/ 2, -1, -1,  0/ ; data Hlattice_sn(:, 7,3)/ 0,  1, -1,  1/
-data Hlattice_sd(:, 8,3)/-1,  2, -1,  0/ ; data Hlattice_sn(:, 8,3)/ 1,  0, -1,  1/
-data Hlattice_sd(:, 9,3)/-1, -1,  2,  0/ ; data Hlattice_sn(:, 9,3)/-1,  1,  0,  1/
-data Hlattice_sd(:,10,3)/ 2, -1, -1,  0/ ; data Hlattice_sn(:,10,3)/ 0, -1,  1,  1/
-data Hlattice_sd(:,11,3)/-1,  2, -1,  0/ ; data Hlattice_sn(:,11,3)/-1,  0,  1,  1/
-data Hlattice_sd(:,12,3)/-1, -1,  2,  0/ ; data Hlattice_sn(:,12,3)/ 1, -1,  0,  1/
-!* pyramidal system: c+a slip {1011}<2113>
-!* plane normales depend on the c/a-ratio
-!* added by Tom Bieler, yj.ro
-!* 13- [ 2 -1 -1 -3]( 1  0 -1  1)
-!* 14- [ 1  1 -2 -3]( 1  0 -1  1)
-!* 15- [ 1  1 -2 -3]( 0  1 -1  1)
-!* 16- [-1  2 -1 -3]( 0  1 -1  1)
-!* 17- [-1  2 -1 -3](-1  1  0  1)
-!* 18- [-2  1  1 -3](-1  1  0  1)
-!* 19- [-2  1  1 -3](-1  0  1  1)
-!* 20- [-1 -1  2 -3](-1  0  1  1)
-!* 21- [-1 -1  2 -3]( 0 -1  1  1)
-!* 22- [ 1 -2  1 -3]( 0 -1  1  1)
-!* 23- [ 1 -2  1 -3]( 1 -1  0  1)
-!* 24- [ 2 -1 -1 -3]( 1 -1  0  1)
-data Hlattice_sd(:,13,3)/ 2, -1, -1, -3/ ; data Hlattice_sn(:,13,3)/ 1,  0, -1,  1/
-data Hlattice_sd(:,14,3)/ 1,  1, -2, -3/ ; data Hlattice_sn(:,14,3)/ 1,  0, -1,  1/
-data Hlattice_sd(:,15,3)/ 1,  1, -2, -3/ ; data Hlattice_sn(:,15,3)/ 0,  1, -1,  1/
-data Hlattice_sd(:,16,3)/-1,  2, -1, -3/ ; data Hlattice_sn(:,16,3)/ 0,  1, -1,  1/
-data Hlattice_sd(:,17,3)/-1,  2, -1, -3/ ; data Hlattice_sn(:,17,3)/-1,  1,  0,  1/
-data Hlattice_sd(:,18,3)/-2,  1,  1, -3/ ; data Hlattice_sn(:,18,3)/-1,  1,  0,  1/
-data Hlattice_sd(:,19,3)/-2,  1,  1, -3/ ; data Hlattice_sn(:,19,3)/-1,  0,  1,  1/
-data Hlattice_sd(:,20,3)/-1, -1,  2, -3/ ; data Hlattice_sn(:,20,3)/-1,  0,  1,  1/
-data Hlattice_sd(:,21,3)/-1, -1,  2, -3/ ; data Hlattice_sn(:,21,3)/ 0, -1,  1,  1/
-data Hlattice_sd(:,22,3)/ 1, -2,  1, -3/ ; data Hlattice_sn(:,22,3)/ 0, -1,  1,  1/
-data Hlattice_sd(:,23,3)/ 1, -2,  1, -3/ ; data Hlattice_sn(:,23,3)/ 1, -1,  0,  1/
-data Hlattice_sd(:,24,3)/ 2, -1, -1, -3/ ; data Hlattice_sn(:,24,3)/ 1, -1,  0,  1/
-
-!*** Twin systems for HCP structures (3) ***
-!* Sort? Numbering of twin system follows Prof. Tom Bieler's scheme (to be consistent with his work); but numbering in data was restarted from 1 &
-!*(to be consistent with this code structure).
-!* MISSING: not implemented yet
-!* added by Tom Bieler, yj.ro
-
-!* (1012)<1011> Twin: shear 0.169 -1.26 compression
-!* 25- [-1  0  1  1]( 1  0 -1  2)
-!* 26- [ 0 -1  1  1]( 0  1 -1  2)
-!* 27- [ 1 -1  0  1](-1  1  0  2)
-!* 28- [ 1  0 -1  1](-1  0  1  2)
-!* 29- [ 0  1 -1  1]( 0 -1  1  2)
-!* 30- [-1  1  0  1]( 1 -1  0  2)
-data Hlattice_td(:, 1,3)/-1,  0,  1,  1/ ; data Hlattice_tn(:, 1,3)/ 1,  0, -1,  2/
-data Hlattice_td(:, 2,3)/ 0, -1,  1,  1/ ; data Hlattice_tn(:, 2,3)/ 0,  1, -1,  2/
-data Hlattice_td(:, 3,3)/ 1, -1,  0,  1/ ; data Hlattice_tn(:, 3,3)/-1,  1,  0,  2/
-data Hlattice_td(:, 4,3)/ 1,  0, -1,  1/ ; data Hlattice_tn(:, 4,3)/-1,  0,  1,  2/
-data Hlattice_td(:, 5,3)/ 0,  1, -1,  1/ ; data Hlattice_tn(:, 5,3)/ 0, -1,  1,  2/
-data Hlattice_td(:, 6,3)/-1,  1,  0,  1/ ; data Hlattice_tn(:, 6,3)/ 1, -1,  0,  2/
-
-
-!*(2112)<211-2> Twin: shear 0.224 1.19 tension
-!* 31- [ 2 -1 -1 -3]( 2 -1 -1  2)
-!* 32- [ 1  1 -2 -3]( 1  1 -2  2)
-!* 33- [-1  2 -1 -3](-1  2 -1  2)
-!* 34- [-2  1  1 -3](-2  1  1  2)
-!* 35- [-1 -1  2 -3](-1 -1  2  2)
-!* 36- [ 1 -2  1 -3]( 1 -2  1  2)
-data Hlattice_td(:, 7,3)/ 2, -1, -1, -3/ ; data Hlattice_tn(:, 7,3)/ 2, -1, -1,  2/
-data Hlattice_td(:, 8,3)/ 1,  1, -2, -3/ ; data Hlattice_tn(:, 8,3)/ 1,  1, -2,  2/
-data Hlattice_td(:, 9,3)/-1,  2, -1, -3/ ; data Hlattice_tn(:, 9,3)/-1,  2, -1,  2/
-data Hlattice_td(:,10,3)/-2,  1,  1, -3/ ; data Hlattice_tn(:,10,3)/-2,  1,  1,  2/
-data Hlattice_td(:,11,3)/-1, -1,  2, -3/ ; data Hlattice_tn(:,11,3)/-1, -1,  2,  2/
-data Hlattice_td(:,12,3)/1,  -2,  1, -3/ ; data Hlattice_tn(:,12,3)/ 1, -2,  1,  2/
-
-
-!* (2111)<211-6> Twin: shear 0.628 -0.39 compressio
-!* 37- [-2  1  1  6]( 2 -1 -1  1)
-!* 38- [-1 -1  2  6]( 1  1 -2  1)
-!* 39- [ 1 -2  1  6](-1  2 -1  1)
-!* 40- [ 2 -1 -1  6](-2  1  1  1)
-!* 41- [ 1  1 -2  6](-1 -1  2  1)
-!* 42- [-1  2 -1  6]( 1 -2  1  1)
-data Hlattice_td(:,13,3)/-2,  1,  1,  6/ ; data Hlattice_tn(:,13,3)/ 2, -1, -1,  1/
-data Hlattice_td(:,14,3)/-1, -1,  2,  6/ ; data Hlattice_tn(:,14,3)/ 1,  1, -2,  1/
-data Hlattice_td(:,15,3)/ 1, -2,  1,  6/ ; data Hlattice_tn(:,15,3)/-1,  2, -1,  1/
-data Hlattice_td(:,16,3)/ 2, -1, -1,  6/ ; data Hlattice_tn(:,16,3)/-2,  1,  1,  1/
-data Hlattice_td(:,17,3)/ 1,  1, -2,  6/ ; data Hlattice_tn(:,17,3)/-1, -1,  2,  1/
-data Hlattice_td(:,18,3)/-1,  2, -1,  6/ ; data Hlattice_tn(:,18,3)/ 1, -2,  1,  1/
-
-
-!* (1011)<101-2> Twin: shear 0.103 1.09 tension
-!* 43- [ 1  0 -1 -2]( 1  0 -1  1)
-!* 44- [-1  0  1 -2](-1  0  1  1)
-!* 45- [ 0  1 -1 -2]( 0  1 -1  1)
-!* 46- [ 0 -1  2 -2]( 0 -1  1  1)
-!* 47- [ 1 -1  0 -2]( 1 -1  0  1)
-!* 48- [-1  1  0 -2](-1  1  0  1)
-data Hlattice_td(:,19,3)/ 1,  0, -1, -2/ ; data Hlattice_tn(:,19,3)/ 1,  0, -1,  1/
-data Hlattice_td(:,20,3)/-1,  0,  1, -2/ ; data Hlattice_tn(:,20,3)/-1,  0,  1,  1/
-data Hlattice_td(:,21,3)/ 0,  1, -1, -2/ ; data Hlattice_tn(:,21,3)/ 0,  1, -1,  1/
-data Hlattice_td(:,22,3)/ 0, -1,  1, -2/ ; data Hlattice_tn(:,22,3)/ 0, -1,  1,  1/
-data Hlattice_td(:,23,3)/ 1, -1,  0, -2/ ; data Hlattice_tn(:,23,3)/ 1, -1,  0,  1/
-data Hlattice_td(:,24,3)/-1,  1,  0, -2/ ; data Hlattice_tn(:,24,3)/-1,  1,  0,  1/
-
-
-!*** Slip-Slip interactions for HCP structures (3) ***
-data lattice_SlipIntType( 1,1:lattice_MaxNslipOfStructure(3),3)/1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType( 2,1:lattice_MaxNslipOfStructure(3),3)/1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType( 3,1:lattice_MaxNslipOfStructure(3),3)/1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType( 4,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType( 5,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType( 6,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType( 7,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType( 8,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType( 9,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(10,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(11,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(12,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(13,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(14,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(15,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(16,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2/
-data lattice_SlipIntType(17,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2/
-data lattice_SlipIntType(18,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2/
-data lattice_SlipIntType(19,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2/
-data lattice_SlipIntType(20,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2/
-data lattice_SlipIntType(21,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2/
-data lattice_SlipIntType(22,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2/
-data lattice_SlipIntType(23,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2/
-data lattice_SlipIntType(24,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1/
-
-!*** slip-twin interactions for HCP structures (3) ***
-data lattice_SlipTwinIntType( 1,1:lattice_MaxNtwinOfStructure(3),3)/1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipTwinIntType( 2,1:lattice_MaxNtwinOfStructure(3),3)/2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipTwinIntType( 3,1:lattice_MaxNtwinOfStructure(3),3)/2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipTwinIntType( 4,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipTwinIntType( 5,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipTwinIntType( 6,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipTwinIntType( 7,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipTwinIntType( 8,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipTwinIntType( 9,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipTwinIntType(10,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipTwinIntType(11,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipTwinIntType(12,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipTwinIntType(13,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipTwinIntType(14,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2/
-data lattice_SlipTwinIntType(15,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2/
-data lattice_SlipTwinIntType(16,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2/
-data lattice_SlipTwinIntType(17,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2/
-data lattice_SlipTwinIntType(18,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2/
-data lattice_SlipTwinIntType(19,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2/
-data lattice_SlipTwinIntType(20,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2/
-data lattice_SlipTwinIntType(21,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2/
-data lattice_SlipTwinIntType(22,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2/
-data lattice_SlipTwinIntType(23,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2/
-data lattice_SlipTwinIntType(24,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1/
-
-!*** Twin-twin interactions for HCP structures (3) ***
-data lattice_TwinIntType( 1,1:lattice_MaxNtwinOfStructure(3),3)/1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_TwinIntType( 2,1:lattice_MaxNtwinOfStructure(3),3)/2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_TwinIntType( 3,1:lattice_MaxNtwinOfStructure(3),3)/2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_TwinIntType( 4,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_TwinIntType( 5,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_TwinIntType( 6,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_TwinIntType( 7,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_TwinIntType( 8,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_TwinIntType( 9,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_TwinIntType(10,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_TwinIntType(11,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_TwinIntType(12,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_TwinIntType(13,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2/
-data lattice_TwinIntType(14,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2/
-data lattice_TwinIntType(15,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2/
-data lattice_TwinIntType(16,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2/
-data lattice_TwinIntType(17,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2/
-data lattice_TwinIntType(18,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2/
-data lattice_TwinIntType(19,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2/
-data lattice_TwinIntType(20,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2/
-data lattice_TwinIntType(21,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2/
-data lattice_TwinIntType(22,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2/
-data lattice_TwinIntType(23,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2/
-data lattice_TwinIntType(24,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1/
-
-
-
-CONTAINS
-!****************************************
-!* - lattice_Init
-!* - lattice_SchmidMatrices
-!****************************************
-
-
-subroutine lattice_init()
-!**************************************
-!*      Module initialization         *
-!**************************************
-call lattice_SchmidMatrices()
-end subroutine
-
-
-subroutine lattice_SchmidMatrices()
-!**************************************
-!*   Calculation of Schmid matrices   *
-!**************************************
-use prec, only: pReal,pInt
-use math, only: math_I3,nrmMandel,mapMandel
-implicit none
-
-!* Definition of variables
-integer(pInt) i,j,k,l
-real(pReal) norm_d,norm_t,norm_n
-real(pReal) norm_sn, norm_sd, norm_tn, norm_td, ratio
-
-!*** Only HCP crystal: converting from 4 axes coordinate system (a1=a2=a3=c) to ortho-hexgonal system (a, b, c)
-!* Plane (hkil)->(h (h+2k)/sqrt(3) l/(c/a)): this has been changed to unit vector afterward.
-!* Direction [uvtw]->[3u/2 (u+2v)*sqrt(3)/2 w*(c/a)]: this has been changed to unit vector afterward.
-!* Equations provided by Prof. Tom Bieler
-!* need to input "c/a rati"o in somewhere in mattax.mpie file(I am not sure where to insert this value for now????).
-
-ratio = 1.56
-
-do i = 1,lattice_MaxNslipOfStructure(3)
-
-!* slip system conversion
-    H_lattice_sn(1,i,3) = Hlattice_sn(1,i,3)
-    H_lattice_sn(2,i,3) = (Hlattice_sn(1,i,3)+ 2.0*Hlattice_sn(2,i,3))/sqrt(3.0)
-    H_lattice_sn(3,i,3) = Hlattice_sn(4,i,3)/ratio
-    
-    norm_sn = dsqrt(H_lattice_sn(1,i,3)**2 + H_lattice_sn(2,i,3)**2 + H_lattice_sn(3,i,3)**2)
-    
-    lattice_sn(1,i,3) = H_lattice_sn(1,i,3)/norm_sn
-    lattice_sn(2,i,3) = H_lattice_sn(2,i,3)/norm_sn
-    lattice_sn(3,i,3) = H_lattice_sn(3,i,3)/norm_sn
-    
-    H_lattice_sd(1,i,3) = 1.5*Hlattice_sd(1,i,3)
-    H_lattice_sd(2,i,3) = (Hlattice_sd(1,i,3) + 2.0*Hlattice_sd(2,i,3))*(sqrt(3.0)/2.0)
-    H_lattice_sd(3,i,3) = Hlattice_sd(4,i,3)*ratio
-
-    norm_sd = dsqrt(H_lattice_sd(1,i,3)**2 + H_lattice_sd(2,i,3)**2 + H_lattice_sd(3,i,3)**2)
-    
-    lattice_sd(1,i,3) = H_lattice_sd(1,i,3)/norm_sd
-    lattice_sd(2,i,3) = H_lattice_sd(2,i,3)/norm_sd
-    lattice_sd(3,i,3) = H_lattice_sd(3,i,3)/norm_sd
-
-!* twin system conversion
-    H_lattice_tn(1,i,3) = Hlattice_tn(1,i,3)
-    H_lattice_tn(2,i,3) = (Hlattice_tn(1,i,3)+ 2.0*Hlattice_tn(2,i,3))/sqrt(3.0)
-    H_lattice_tn(3,i,3) = Hlattice_tn(4,i,3)/ratio
-    
-    norm_tn = dsqrt(H_lattice_tn(1,i,3)**2 + H_lattice_tn(2,i,3)**2 + H_lattice_tn(3,i,3)**2)
-    
-    lattice_tn(1,i,3) = H_lattice_tn(1,i,3)/norm_tn
-    lattice_tn(2,i,3) = H_lattice_tn(2,i,3)/norm_tn
-    lattice_tn(3,i,3) = H_lattice_tn(3,i,3)/norm_tn
-    
-    H_lattice_td(1,i,3) = 1.5*Hlattice_td(1,i,3)
-    H_lattice_td(2,i,3) = (Hlattice_td(1,i,3)+ 2.0*Hlattice_td(2,i,3))*(sqrt(3.0)/2.0)
-    H_lattice_td(3,i,3) = Hlattice_td(4,i,3)*ratio
-    
-    norm_td = dsqrt(H_lattice_td(1,i,3)**2 + H_lattice_td(2,i,3)**2 + H_lattice_td(3,i,3)**2)
-    
-    lattice_td(1,i,3) = H_lattice_td(1,i,3)/norm_td
-    lattice_td(2,i,3) = H_lattice_td(2,i,3)/norm_td
-    lattice_td(3,i,3) = H_lattice_td(3,i,3)/norm_td
-    
-enddo
-
-!* Iteration over the lattice structures
-do l=1,lattice_MaxLatticeStructure
-!* Iteration over the slip systems
-   do k=1,lattice_MaxNslipOfStructure(l)
-!* Definition of transverse direction st for the frame (sd,st,sn)
-      lattice_st(1,k,l)=lattice_sn(2,k,l)*lattice_sd(3,k,l)-lattice_sn(3,k,l)*lattice_sd(2,k,l)
-	  lattice_st(2,k,l)=lattice_sn(3,k,l)*lattice_sd(1,k,l)-lattice_sn(1,k,l)*lattice_sd(3,k,l)
-	  lattice_st(3,k,l)=lattice_sn(1,k,l)*lattice_sd(2,k,l)-lattice_sn(2,k,l)*lattice_sd(1,k,l)
-	  norm_d=dsqrt(lattice_sd(1,k,l)**2+lattice_sd(2,k,l)**2+lattice_sd(3,k,l)**2)
-      norm_t=dsqrt(lattice_st(1,k,l)**2+lattice_st(2,k,l)**2+lattice_st(3,k,l)**2)
-      norm_n=dsqrt(lattice_sn(1,k,l)**2+lattice_sn(2,k,l)**2+lattice_sn(3,k,l)**2)
-      lattice_sd(:,k,l)=lattice_sd(:,k,l)/norm_d
-	  lattice_st(:,k,l)=lattice_st(:,k,l)/norm_t
-	  lattice_sn(:,k,l)=lattice_sn(:,k,l)/norm_n
-!* Defintion of Schmid matrix
-      forall (i=1:3,j=1:3) lattice_Sslip(i,j,k,l)=lattice_sd(i,k,l)*lattice_sn(j,k,l)
-!* Vectorization of normalized Schmid matrix
-      forall (i=1:6) lattice_Sslip_v(i,k,l) = nrmMandel(i)/2.0_pReal * &
-                  (lattice_Sslip(mapMandel(1,i),mapMandel(2,i),k,l)+lattice_Sslip(mapMandel(2,i),mapMandel(1,i),k,l))
-   enddo
-
-!* Iteration over the twin systems
-   do k=1,lattice_MaxNtwinOfStructure(l)
-!* Definition of transverse direction tt for the frame (td,tt,tn)
-      lattice_tt(1,k,l)=lattice_tn(2,k,l)*lattice_td(3,k,l)-lattice_tn(3,k,l)*lattice_td(2,k,l)
-	  lattice_tt(2,k,l)=lattice_tn(3,k,l)*lattice_td(1,k,l)-lattice_tn(1,k,l)*lattice_td(3,k,l)
-	  lattice_tt(3,k,l)=lattice_tn(1,k,l)*lattice_td(2,k,l)-lattice_tn(2,k,l)*lattice_td(1,k,l)
-	  norm_d=dsqrt(lattice_td(1,k,l)**2+lattice_td(2,k,l)**2+lattice_td(3,k,l)**2)
-      norm_t=dsqrt(lattice_tt(1,k,l)**2+lattice_tt(2,k,l)**2+lattice_tt(3,k,l)**2)
-      norm_n=dsqrt(lattice_tn(1,k,l)**2+lattice_tn(2,k,l)**2+lattice_tn(3,k,l)**2)
-      lattice_td(:,k,l)=lattice_td(:,k,l)/norm_d
-	  lattice_tt(:,k,l)=lattice_tt(:,k,l)/norm_t
-	  lattice_tn(:,k,l)=lattice_tn(:,k,l)/norm_n
-!* Defintion of Schmid matrix and transformation matrices
-      lattice_Qtwin(:,:,k,l)=-math_I3
-      forall (i=1:3,j=1:3)
-	         lattice_Stwin(i,j,k,l)=lattice_td(i,k,l)*lattice_tn(j,k,l)
-			 lattice_Qtwin(i,j,k,l)=lattice_Qtwin(i,j,k,l)+2*lattice_tn(i,k,l)*lattice_tn(j,k,l)
-      endforall
-!* Vectorization of normalized Schmid matrix
-      lattice_Stwin_v(1,k,l)=lattice_Stwin(1,1,k,l)
-      lattice_Stwin_v(2,k,l)=lattice_Stwin(2,2,k,l)
-      lattice_Stwin_v(3,k,l)=lattice_Stwin(3,3,k,l)
-	  !* be compatible with Mandel notation of Tstar
-      lattice_Stwin_v(4,k,l)=(lattice_Stwin(1,2,k,l)+lattice_Stwin(2,1,k,l))/dsqrt(2.0_pReal)
-      lattice_Stwin_v(5,k,l)=(lattice_Stwin(2,3,k,l)+lattice_Stwin(3,2,k,l))/dsqrt(2.0_pReal)
-      lattice_Stwin_v(6,k,l)=(lattice_Stwin(1,3,k,l)+lattice_Stwin(3,1,k,l))/dsqrt(2.0_pReal)
-   enddo
-enddo
-
-!*** printout schmid matrix (0nly Hexagonal structure)to check if the conversion is correctly done.
-
-!* define the output location
-!open(7, FILE='slip.prn')
-!open(8, FILE='twin.prn')
-!
-!do k = 1,24
-!       write(7,*) k
-!        write(7,*) lattice_Sslip(1,1,k,3),lattice_Sslip(1,2,k,3),lattice_Sslip(1,3,k,3)
-!        write(7,*) lattice_Sslip(2,1,k,3),lattice_Sslip(2,2,k,3),lattice_Sslip(2,3,k,3)
-!        write(7,*) lattice_Sslip(3,1,k,3),lattice_Sslip(3,2,k,3),lattice_Sslip(3,3,k,3)
-!        write(7,*)
-!        write(8,*) k
-!        write(8,*) lattice_Stwin(1,1,k,3),lattice_Stwin(2,2,k,3),lattice_Stwin(3,3,k,3)
-!        write(8,*) lattice_Stwin(2,1,k,3),lattice_Stwin(2,2,k,3),lattice_Stwin(2,3,k,3)
-!        write(8,*) lattice_Stwin(3,1,k,3),lattice_Stwin(3,2,k,3),lattice_Stwin(3,3,k,3)
-!        write(8,*)
-!enddo
-
-end subroutine
-
-END MODULE
-
-	   
-         
+
+!************************************
+!*         Module: LATTICE          *
+!************************************
+!* contains:                        *
+!* - Lattice structure definition   *
+!* - Slip system definition         *
+!* - Schmid matrices calculation    *
+!************************************
+
+MODULE lattice
+
+!*** Include other modules ***
+use prec, only: pReal,pInt
+implicit none
+
+!************************************
+!*      Lattice structures          *
+!************************************
+!* Number of lattice structures (1-FCC,2-BCC,3-HCP)
+integer(pInt), parameter :: lattice_MaxLatticeStructure = 3
+!* Total number of slip systems per lattice structure
+!* (has to be changed according the definition of slip systems)
+integer(pInt), dimension(lattice_MaxLatticeStructure), parameter :: lattice_MaxNslipOfStructure = &
+reshape((/12,48,24/),(/lattice_MaxLatticeStructure/))
+!* Total number of twin systems per lattice structure
+!* (has to be changed according the definition of twin systems)
+integer(pInt), dimension(lattice_MaxLatticeStructure), parameter :: lattice_MaxNtwinOfStructure = &
+reshape((/12,0,24/),(/lattice_MaxLatticeStructure/))
+!* Maximum number of slip systems over lattice structures
+integer(pInt), parameter :: lattice_MaxMaxNslipOfStructure = 48
+!* Maximum number of twin systems over lattice structures,  changed form 12 to 24 (yj.ro)
+integer(pInt), parameter :: lattice_MaxMaxNtwinOfStructure = 24
+!* Slip direction, slip normales and Schmid matrices
+real(pReal), dimension(3,3,lattice_MaxMaxNslipOfStructure,lattice_MaxLatticeStructure) :: lattice_Sslip
+real(pReal), dimension(6,lattice_MaxMaxNslipOfStructure,lattice_MaxLatticeStructure) :: lattice_Sslip_v
+real(pReal), dimension(3,lattice_MaxMaxNslipOfStructure,lattice_MaxLatticeStructure) :: lattice_sn
+real(pReal), dimension(3,lattice_MaxMaxNslipOfStructure,lattice_MaxLatticeStructure) :: lattice_sd
+real(pReal), dimension(3,lattice_MaxMaxNslipOfStructure,lattice_MaxLatticeStructure) :: lattice_st
+
+!* HCP - slip direction, slip normal (4 indices): Prof. Tom Bieler, Leeyun, YJRO 
+real(pReal), dimension(4,lattice_MaxMaxNslipOfStructure,lattice_MaxLatticeStructure) :: Hlattice_sn
+real(pReal), dimension(4,lattice_MaxMaxNslipOfStructure,lattice_MaxLatticeStructure) :: Hlattice_sd
+real(pReal), dimension(3,lattice_MaxMaxNslipOfStructure,lattice_MaxLatticeStructure) :: H_lattice_sn
+real(pReal), dimension(3,lattice_MaxMaxNslipOfStructure,lattice_MaxLatticeStructure) :: H_lattice_sd
+
+!* twin direction, twin normales, Schmid matrices and transformation matrices
+real(pReal), dimension(3,3,lattice_MaxMaxNtwinOfStructure,lattice_MaxLatticeStructure) :: lattice_Stwin
+real(pReal), dimension(6,lattice_MaxMaxNtwinOfStructure,lattice_MaxLatticeStructure) :: lattice_Stwin_v
+real(pReal), dimension(3,lattice_MaxMaxNtwinOfStructure,lattice_MaxLatticeStructure) :: lattice_tn
+real(pReal), dimension(3,lattice_MaxMaxNtwinOfStructure,lattice_MaxLatticeStructure) :: lattice_td
+real(pReal), dimension(3,lattice_MaxMaxNtwinOfStructure,lattice_MaxLatticeStructure) :: lattice_tt
+real(pReal), dimension(3,3,lattice_MaxMaxNtwinOfStructure,lattice_MaxLatticeStructure) :: lattice_Qtwin
+
+!* HCP - twin direction, twin normales for 4 indices: Prof. Tom Bieler, Leeyun, YJR 
+real(pReal), dimension(4,lattice_MaxMaxNtwinOfStructure,lattice_MaxLatticeStructure) :: Hlattice_tn
+real(pReal), dimension(4,lattice_MaxMaxNtwinOfStructure,lattice_MaxLatticeStructure) :: Hlattice_td
+real(pReal), dimension(3,lattice_MaxMaxNtwinOfStructure,lattice_MaxLatticeStructure) :: H_lattice_tn
+real(pReal), dimension(3,lattice_MaxMaxNtwinOfStructure,lattice_MaxLatticeStructure) :: H_lattice_td
+
+
+real(pReal), dimension(lattice_MaxLatticeStructure), parameter :: lattice_TwinShear = &
+reshape((/0.7071067812,0.7071067812,0.7071067812/),(/lattice_MaxLatticeStructure/)) ! Depends surely on c/a ratio for HCP
+
+
+!* Slip_slip interaction matrices
+integer(pInt), dimension(lattice_MaxMaxNslipOfStructure,lattice_MaxMaxNslipOfStructure,lattice_MaxLatticeStructure) :: &
+lattice_SlipIntType
+!* Slip_twin interaction matrices
+integer(pInt), dimension(lattice_MaxMaxNslipOfStructure,lattice_MaxMaxNtwinOfStructure,lattice_MaxLatticeStructure) :: &
+lattice_SlipTwinIntType
+!* Twin-twin interaction matrices
+integer(pInt), dimension(lattice_MaxMaxNtwinOfStructure,lattice_MaxMaxNtwinOfStructure,lattice_MaxLatticeStructure) :: &
+lattice_TwinIntType
+
+!*** Slip systems for FCC structures (1) ***
+!* System {111}<110>  Sort according Eisenlohr&Hantcherli
+data lattice_sd(:, 1,1)/ 0, 1,-1/ ; data lattice_sn(:, 1,1)/ 1, 1, 1/
+data lattice_sd(:, 2,1)/-1, 0, 1/ ; data lattice_sn(:, 2,1)/ 1, 1, 1/
+data lattice_sd(:, 3,1)/ 1,-1, 0/ ; data lattice_sn(:, 3,1)/ 1, 1, 1/
+data lattice_sd(:, 4,1)/ 0,-1,-1/ ; data lattice_sn(:, 4,1)/-1,-1, 1/
+data lattice_sd(:, 5,1)/ 1, 0, 1/ ; data lattice_sn(:, 5,1)/-1,-1, 1/
+data lattice_sd(:, 6,1)/-1, 1, 0/ ; data lattice_sn(:, 6,1)/-1,-1, 1/
+data lattice_sd(:, 7,1)/ 0,-1, 1/ ; data lattice_sn(:, 7,1)/ 1,-1,-1/
+data lattice_sd(:, 8,1)/-1, 0,-1/ ; data lattice_sn(:, 8,1)/ 1,-1,-1/
+data lattice_sd(:, 9,1)/ 1, 1, 0/ ; data lattice_sn(:, 9,1)/ 1,-1,-1/
+data lattice_sd(:,10,1)/ 0, 1, 1/ ; data lattice_sn(:,10,1)/-1, 1,-1/
+data lattice_sd(:,11,1)/ 1, 0,-1/ ; data lattice_sn(:,11,1)/-1, 1,-1/
+data lattice_sd(:,12,1)/-1,-1, 0/ ; data lattice_sn(:,12,1)/-1, 1,-1/
+
+!*** Twin systems for FCC structures (1) ***
+!* System {111}<112>  Sort according Eisenlohr&Hantcherli
+data lattice_td(:, 1,1)/-2, 1, 1/ ; data lattice_tn(:, 1,1)/ 1, 1, 1/
+data lattice_td(:, 2,1)/ 1,-2, 1/ ; data lattice_tn(:, 2,1)/ 1, 1, 1/
+data lattice_td(:, 3,1)/ 1, 1,-2/ ; data lattice_tn(:, 3,1)/ 1, 1, 1/
+data lattice_td(:, 4,1)/ 2,-1, 1/ ; data lattice_tn(:, 4,1)/-1,-1, 1/
+data lattice_td(:, 5,1)/-1, 2, 1/ ; data lattice_tn(:, 5,1)/-1,-1, 1/
+data lattice_td(:, 6,1)/-1,-1,-2/ ; data lattice_tn(:, 6,1)/-1,-1, 1/
+data lattice_td(:, 7,1)/-2,-1,-1/ ; data lattice_tn(:, 7,1)/ 1,-1,-1/
+data lattice_td(:, 8,1)/ 1, 2,-1/ ; data lattice_tn(:, 8,1)/ 1,-1,-1/
+data lattice_td(:, 9,1)/ 1,-1, 2/ ; data lattice_tn(:, 9,1)/ 1,-1,-1/
+data lattice_td(:,10,1)/ 2, 1,-1/ ; data lattice_tn(:,10,1)/-1, 1,-1/
+data lattice_td(:,11,1)/-1,-2,-1/ ; data lattice_tn(:,11,1)/-1, 1,-1/
+data lattice_td(:,12,1)/-1, 1, 2/ ; data lattice_tn(:,12,1)/-1, 1,-1/
+
+!*** Slip-Slip interactions for FCC structures (1) ***
+data lattice_SlipIntType( 1,1:lattice_MaxNslipOfStructure(1),1)/1,2,2,4,6,5,3,5,5,4,5,6/
+data lattice_SlipIntType( 2,1:lattice_MaxNslipOfStructure(1),1)/2,1,2,6,4,5,5,4,6,5,3,5/
+data lattice_SlipIntType( 3,1:lattice_MaxNslipOfStructure(1),1)/2,2,1,5,5,3,5,6,4,6,5,4/
+data lattice_SlipIntType( 4,1:lattice_MaxNslipOfStructure(1),1)/4,6,5,1,2,2,4,5,6,3,5,5/
+data lattice_SlipIntType( 5,1:lattice_MaxNslipOfStructure(1),1)/6,4,5,2,1,2,5,3,5,5,4,6/
+data lattice_SlipIntType( 6,1:lattice_MaxNslipOfStructure(1),1)/5,5,3,2,2,1,6,5,4,5,6,4/
+data lattice_SlipIntType( 7,1:lattice_MaxNslipOfStructure(1),1)/3,5,5,4,5,6,1,2,2,4,6,5/
+data lattice_SlipIntType( 8,1:lattice_MaxNslipOfStructure(1),1)/5,4,6,5,3,5,2,1,2,6,4,5/
+data lattice_SlipIntType( 9,1:lattice_MaxNslipOfStructure(1),1)/5,6,4,6,5,4,2,2,1,5,5,3/
+data lattice_SlipIntType(10,1:lattice_MaxNslipOfStructure(1),1)/4,5,6,3,5,5,4,6,5,1,2,2/
+data lattice_SlipIntType(11,1:lattice_MaxNslipOfStructure(1),1)/5,3,5,5,4,6,6,4,5,2,1,2/
+data lattice_SlipIntType(12,1:lattice_MaxNslipOfStructure(1),1)/6,5,4,5,6,4,5,5,3,2,2,1/
+
+!*** Slip-Twin interactions for FCC structures (1) ***
+data lattice_SlipTwinIntType( 1,1:lattice_MaxNtwinOfStructure(1),1)/0,0,0,1,1,1,0,0,0,1,1,1/
+data lattice_SlipTwinIntType( 2,1:lattice_MaxNtwinOfStructure(1),1)/0,0,0,1,1,1,1,1,1,0,0,0/
+data lattice_SlipTwinIntType( 3,1:lattice_MaxNtwinOfStructure(1),1)/0,0,0,0,0,0,1,1,1,1,1,1/
+data lattice_SlipTwinIntType( 4,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,0,0,0,1,1,1,0,0,0/
+data lattice_SlipTwinIntType( 5,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,0,0,0,0,0,0,1,1,1/
+data lattice_SlipTwinIntType( 6,1:lattice_MaxNtwinOfStructure(1),1)/0,0,0,0,0,0,1,1,1,1,1,1/
+data lattice_SlipTwinIntType( 7,1:lattice_MaxNtwinOfStructure(1),1)/0,0,0,1,1,1,0,0,0,1,1,1/
+data lattice_SlipTwinIntType( 8,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,0,0,0,0,0,0,1,1,1/
+data lattice_SlipTwinIntType( 9,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,1,1,1,0,0,0,0,0,0/
+data lattice_SlipTwinIntType(10,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,0,0,0,1,1,1,0,0,0/
+data lattice_SlipTwinIntType(11,1:lattice_MaxNtwinOfStructure(1),1)/0,0,0,1,1,1,1,1,1,0,0,0/
+data lattice_SlipTwinIntType(12,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,1,1,1,0,0,0,0,0,0/
+
+!*** Twin-Twin interactions for FCC structures (1) ***
+data lattice_TwinIntType( 1,1:lattice_MaxNtwinOfStructure(1),1)/0,0,0,1,1,1,1,1,1,1,1,1/
+data lattice_TwinIntType( 2,1:lattice_MaxNtwinOfStructure(1),1)/0,0,0,1,1,1,1,1,1,1,1,1/
+data lattice_TwinIntType( 3,1:lattice_MaxNtwinOfStructure(1),1)/0,0,0,1,1,1,1,1,1,1,1,1/
+data lattice_TwinIntType( 4,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,0,0,0,1,1,1,1,1,1/
+data lattice_TwinIntType( 5,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,0,0,0,1,1,1,1,1,1/
+data lattice_TwinIntType( 6,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,0,0,0,1,1,1,1,1,1/
+data lattice_TwinIntType( 7,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,1,1,1,0,0,0,1,1,1/
+data lattice_TwinIntType( 8,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,1,1,1,0,0,0,1,1,1/
+data lattice_TwinIntType( 9,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,1,1,1,0,0,0,1,1,1/
+data lattice_TwinIntType(10,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,1,1,1,1,1,1,0,0,0/
+data lattice_TwinIntType(11,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,1,1,1,1,1,1,0,0,0/
+data lattice_TwinIntType(12,1:lattice_MaxNtwinOfStructure(1),1)/1,1,1,1,1,1,1,1,1,0,0,0/
+
+!*** Slip systems for BCC structures (2) ***
+!* System {110}<111>
+!* Sort?
+data lattice_sd(:, 1,2)/ 1,-1, 1/ ; data lattice_sn(:, 1,2)/ 0, 1, 1/
+data lattice_sd(:, 2,2)/-1,-1, 1/ ; data lattice_sn(:, 2,2)/ 0, 1, 1/
+data lattice_sd(:, 3,2)/ 1, 1, 1/ ; data lattice_sn(:, 3,2)/ 0,-1, 1/
+data lattice_sd(:, 4,2)/-1, 1, 1/ ; data lattice_sn(:, 4,2)/ 0,-1, 1/
+data lattice_sd(:, 5,2)/-1, 1, 1/ ; data lattice_sn(:, 5,2)/ 1, 0, 1/
+data lattice_sd(:, 6,2)/-1,-1, 1/ ; data lattice_sn(:, 6,2)/ 1, 0, 1/
+data lattice_sd(:, 7,2)/ 1, 1, 1/ ; data lattice_sn(:, 7,2)/-1, 0, 1/
+data lattice_sd(:, 8,2)/ 1,-1, 1/ ; data lattice_sn(:, 8,2)/-1, 0, 1/
+data lattice_sd(:, 9,2)/-1, 1, 1/ ; data lattice_sn(:, 9,2)/ 1, 1, 0/
+data lattice_sd(:,10,2)/-1, 1,-1/ ; data lattice_sn(:,10,2)/ 1, 1, 0/
+data lattice_sd(:,11,2)/ 1, 1, 1/ ; data lattice_sn(:,11,2)/-1, 1, 0/
+data lattice_sd(:,12,2)/ 1, 1,-1/ ; data lattice_sn(:,12,2)/-1, 1, 0/
+!* System {112}<111>
+!* Sort?
+data lattice_sd(:,13,2)/-1, 1, 1/ ; data lattice_sn(:,13,2)/ 2, 1, 1/
+data lattice_sd(:,14,2)/ 1, 1, 1/ ; data lattice_sn(:,14,2)/-2, 1, 1/
+data lattice_sd(:,15,2)/ 1, 1,-1/ ; data lattice_sn(:,15,2)/ 2,-1, 1/
+data lattice_sd(:,16,2)/ 1,-1, 1/ ; data lattice_sn(:,16,2)/ 2, 1,-1/
+data lattice_sd(:,17,2)/ 1,-1, 1/ ; data lattice_sn(:,17,2)/ 1, 2, 1/
+data lattice_sd(:,18,2)/ 1, 1,-1/ ; data lattice_sn(:,18,2)/-1, 2, 1/
+data lattice_sd(:,19,2)/ 1, 1, 1/ ; data lattice_sn(:,19,2)/ 1,-2, 1/
+data lattice_sd(:,20,2)/-1, 1, 1/ ; data lattice_sn(:,20,2)/ 1, 2,-1/
+data lattice_sd(:,21,2)/ 1, 1,-1/ ; data lattice_sn(:,21,2)/ 1, 1, 2/
+data lattice_sd(:,22,2)/ 1,-1, 1/ ; data lattice_sn(:,22,2)/-1, 1, 2/
+data lattice_sd(:,23,2)/-1, 1, 1/ ; data lattice_sn(:,23,2)/ 1,-1, 2/
+data lattice_sd(:,24,2)/ 1, 1, 1/ ; data lattice_sn(:,24,2)/ 1, 1,-2/
+!* System {123}<111>
+!* Sort?
+data lattice_sd(:,25,2)/ 1, 1,-1/ ; data lattice_sn(:,25,2)/ 1, 2, 3/
+data lattice_sd(:,26,2)/ 1,-1, 1/ ; data lattice_sn(:,26,2)/-1, 2, 3/
+data lattice_sd(:,27,2)/-1, 1, 1/ ; data lattice_sn(:,27,2)/ 1,-2, 3/
+data lattice_sd(:,28,2)/ 1, 1, 1/ ; data lattice_sn(:,28,2)/ 1, 2,-3/
+data lattice_sd(:,29,2)/ 1,-1, 1/ ; data lattice_sn(:,29,2)/ 1, 3, 2/
+data lattice_sd(:,30,2)/ 1, 1,-1/ ; data lattice_sn(:,30,2)/-1, 3, 2/
+data lattice_sd(:,31,2)/ 1, 1, 1/ ; data lattice_sn(:,31,2)/ 1,-3, 2/
+data lattice_sd(:,32,2)/-1, 1, 1/ ; data lattice_sn(:,32,2)/ 1, 3,-2/
+data lattice_sd(:,33,2)/ 1, 1,-1/ ; data lattice_sn(:,33,2)/ 2, 1, 3/
+data lattice_sd(:,34,2)/ 1,-1, 1/ ; data lattice_sn(:,34,2)/-2, 1, 3/
+data lattice_sd(:,35,2)/-1, 1, 1/ ; data lattice_sn(:,35,2)/ 2,-1, 3/
+data lattice_sd(:,36,2)/ 1, 1, 1/ ; data lattice_sn(:,36,2)/ 2, 1,-3/
+data lattice_sd(:,37,2)/ 1,-1, 1/ ; data lattice_sn(:,37,2)/ 2, 3, 1/
+data lattice_sd(:,38,2)/ 1, 1,-1/ ; data lattice_sn(:,38,2)/-2, 3, 1/
+data lattice_sd(:,39,2)/ 1, 1, 1/ ; data lattice_sn(:,39,2)/ 2,-3, 1/
+data lattice_sd(:,40,2)/-1, 1, 1/ ; data lattice_sn(:,40,2)/ 2, 3,-1/
+data lattice_sd(:,41,2)/-1, 1, 1/ ; data lattice_sn(:,41,2)/ 3, 1, 2/
+data lattice_sd(:,42,2)/ 1, 1, 1/ ; data lattice_sn(:,42,2)/-3, 1, 2/
+data lattice_sd(:,43,2)/ 1, 1,-1/ ; data lattice_sn(:,43,2)/ 3,-1, 2/
+data lattice_sd(:,44,2)/ 1,-1, 1/ ; data lattice_sn(:,44,2)/ 3, 1,-2/
+data lattice_sd(:,45,2)/-1, 1, 1/ ; data lattice_sn(:,45,2)/ 3, 2, 1/
+data lattice_sd(:,46,2)/ 1, 1, 1/ ; data lattice_sn(:,46,2)/-3, 2, 1/
+data lattice_sd(:,47,2)/ 1, 1,-1/ ; data lattice_sn(:,47,2)/ 3,-2, 1/
+data lattice_sd(:,48,2)/ 1,-1, 1/ ; data lattice_sn(:,48,2)/ 3, 2,-1/
+
+!*** Twin systems for BCC structures (2) ***
+!* System {112}<111>
+!* Sort?
+!* MISSING: not implemented yet
+
+!*** Slip-Slip interactions for BCC structures (2) ***
+data lattice_SlipIntType( 1,:,2)/1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType( 2,:,2)/2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType( 3,:,2)/2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType( 4,:,2)/2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType( 5,:,2)/2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType( 6,:,2)/2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType( 7,:,2)/2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType( 8,:,2)/2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType( 9,:,2)/2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(10,:,2)/2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(11,:,2)/2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(12,:,2)/2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(13,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(14,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(15,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(16,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(17,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(18,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(19,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(20,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(21,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(22,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(23,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(24,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(25,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(26,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(27,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(28,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(29,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(30,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(31,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(32,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(33,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(34,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(35,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(36,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(37,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(38,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(39,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(40,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(41,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2/
+data lattice_SlipIntType(42,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2/
+data lattice_SlipIntType(43,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2/
+data lattice_SlipIntType(44,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2/
+data lattice_SlipIntType(45,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2/
+data lattice_SlipIntType(46,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2/
+data lattice_SlipIntType(47,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2/
+data lattice_SlipIntType(48,:,2)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1/
+
+!*** Slip-twin interactions for BCC structures (2) ***
+! MISSING: not implemented yet
+
+!*** Twin-twin interactions for BCC structures (2) ***
+! MISSING: not implemented yet
+
+!*** Slip systems for HCP structures (3) ***
+!* Basal systems {0001}<1120> (independent of c/a-ratio)
+!* 1- [2  -1  -1  0](0 0 0 1)
+!* 2- [-1  2  -1  0](0 0 0 1)
+!* 3- [-1 -1   2  0](0 0 0 1)
+!* Automatical transformation from Bravais (4 axes coorinate system) to Miller (in ortho-hexagonal coordinate system)
+!* not done for the moment
+!* Sort? Changed order of slip system and sign of Burges vector (Tom Bieler, yj.ro)
+data Hlattice_sd(:, 1,3)/ 2, -1, -1,  0/ ; data Hlattice_sn(:, 1,3)/ 0,  0,  0,  1/
+data Hlattice_sd(:, 2,3)/-1,  2, -1,  0/ ; data Hlattice_sn(:, 2,3)/ 0,  0,  0,  1/
+data Hlattice_sd(:, 3,3)/-1, -1,  2,  0/ ; data Hlattice_sn(:, 3,3)/ 0,  0,  0,  1/
+!* 1st type prismatic systems {1010}<1120>  (independent of c/a-ratio)
+!* 4- [ 2 -1 -1  0]( 0  1 -1  0)
+!* 5- [-1  2 -1  0]( 1  0 -1  0)
+!* 6- [-1 -1  2  0](-1  1  0  0)
+!* Sort? Changed order of slip system and sign of Burges vector (yj.ro)
+data Hlattice_sd(:, 4,3)/ 2, -1, -1,  0/ ; data Hlattice_sn(:, 4,3)/ 0,  1, -1,  0/
+data Hlattice_sd(:, 5,3)/-1,  2, -1,  0/ ; data Hlattice_sn(:, 5,3)/ 1,  0, -1,  0/
+data Hlattice_sd(:, 6,3)/-1, -1,  2,  0/ ; data Hlattice_sn(:, 6,3)/-1,  1,  0,  0/
+!* 1st type 1st order pyramidal systems {1011}<1120>
+!* plane normales depend on the c/a-ratio
+!*	7- [ 2 -1 -1  0]( 0  1 -1  1)
+!*  8- [-1  2 -1  0]( 1  0 -1  1)
+!*  9- [-1 -1  2  0](-1  1  0  1)
+!* 10- [ 2 -1 -1  0]( 0 -1  1  1)
+!* 11- [-1  2 -1  0](-1  0  1  1)
+!* 12- [-1 -1  2  0]( 1 -1  0  1)
+!* Sort? Changed order of slip system and sign of Burges vector (Tom Bieler, yj.ro)
+data Hlattice_sd(:, 7,3)/ 2, -1, -1,  0/ ; data Hlattice_sn(:, 7,3)/ 0,  1, -1,  1/
+data Hlattice_sd(:, 8,3)/-1,  2, -1,  0/ ; data Hlattice_sn(:, 8,3)/ 1,  0, -1,  1/
+data Hlattice_sd(:, 9,3)/-1, -1,  2,  0/ ; data Hlattice_sn(:, 9,3)/-1,  1,  0,  1/
+data Hlattice_sd(:,10,3)/ 2, -1, -1,  0/ ; data Hlattice_sn(:,10,3)/ 0, -1,  1,  1/
+data Hlattice_sd(:,11,3)/-1,  2, -1,  0/ ; data Hlattice_sn(:,11,3)/-1,  0,  1,  1/
+data Hlattice_sd(:,12,3)/-1, -1,  2,  0/ ; data Hlattice_sn(:,12,3)/ 1, -1,  0,  1/
+!* pyramidal system: c+a slip {1011}<2113>
+!* plane normales depend on the c/a-ratio
+!* added by Tom Bieler, yj.ro
+!* 13- [ 2 -1 -1 -3]( 1  0 -1  1)
+!* 14- [ 1  1 -2 -3]( 1  0 -1  1)
+!* 15- [ 1  1 -2 -3]( 0  1 -1  1)
+!* 16- [-1  2 -1 -3]( 0  1 -1  1)
+!* 17- [-1  2 -1 -3](-1  1  0  1)
+!* 18- [-2  1  1 -3](-1  1  0  1)
+!* 19- [-2  1  1 -3](-1  0  1  1)
+!* 20- [-1 -1  2 -3](-1  0  1  1)
+!* 21- [-1 -1  2 -3]( 0 -1  1  1)
+!* 22- [ 1 -2  1 -3]( 0 -1  1  1)
+!* 23- [ 1 -2  1 -3]( 1 -1  0  1)
+!* 24- [ 2 -1 -1 -3]( 1 -1  0  1)
+data Hlattice_sd(:,13,3)/ 2, -1, -1, -3/ ; data Hlattice_sn(:,13,3)/ 1,  0, -1,  1/
+data Hlattice_sd(:,14,3)/ 1,  1, -2, -3/ ; data Hlattice_sn(:,14,3)/ 1,  0, -1,  1/
+data Hlattice_sd(:,15,3)/ 1,  1, -2, -3/ ; data Hlattice_sn(:,15,3)/ 0,  1, -1,  1/
+data Hlattice_sd(:,16,3)/-1,  2, -1, -3/ ; data Hlattice_sn(:,16,3)/ 0,  1, -1,  1/
+data Hlattice_sd(:,17,3)/-1,  2, -1, -3/ ; data Hlattice_sn(:,17,3)/-1,  1,  0,  1/
+data Hlattice_sd(:,18,3)/-2,  1,  1, -3/ ; data Hlattice_sn(:,18,3)/-1,  1,  0,  1/
+data Hlattice_sd(:,19,3)/-2,  1,  1, -3/ ; data Hlattice_sn(:,19,3)/-1,  0,  1,  1/
+data Hlattice_sd(:,20,3)/-1, -1,  2, -3/ ; data Hlattice_sn(:,20,3)/-1,  0,  1,  1/
+data Hlattice_sd(:,21,3)/-1, -1,  2, -3/ ; data Hlattice_sn(:,21,3)/ 0, -1,  1,  1/
+data Hlattice_sd(:,22,3)/ 1, -2,  1, -3/ ; data Hlattice_sn(:,22,3)/ 0, -1,  1,  1/
+data Hlattice_sd(:,23,3)/ 1, -2,  1, -3/ ; data Hlattice_sn(:,23,3)/ 1, -1,  0,  1/
+data Hlattice_sd(:,24,3)/ 2, -1, -1, -3/ ; data Hlattice_sn(:,24,3)/ 1, -1,  0,  1/
+
+!*** Twin systems for HCP structures (3) ***
+!* Sort? Numbering of twin system follows Prof. Tom Bieler's scheme (to be consistent with his work); but numbering in data was restarted from 1 &
+!*(to be consistent with this code structure).
+!* MISSING: not implemented yet
+!* added by Tom Bieler, yj.ro
+
+!* (1012)<1011> Twin: shear 0.169 -1.26 compression
+!* 25- [-1  0  1  1]( 1  0 -1  2)
+!* 26- [ 0 -1  1  1]( 0  1 -1  2)
+!* 27- [ 1 -1  0  1](-1  1  0  2)
+!* 28- [ 1  0 -1  1](-1  0  1  2)
+!* 29- [ 0  1 -1  1]( 0 -1  1  2)
+!* 30- [-1  1  0  1]( 1 -1  0  2)
+data Hlattice_td(:, 1,3)/-1,  0,  1,  1/ ; data Hlattice_tn(:, 1,3)/ 1,  0, -1,  2/
+data Hlattice_td(:, 2,3)/ 0, -1,  1,  1/ ; data Hlattice_tn(:, 2,3)/ 0,  1, -1,  2/
+data Hlattice_td(:, 3,3)/ 1, -1,  0,  1/ ; data Hlattice_tn(:, 3,3)/-1,  1,  0,  2/
+data Hlattice_td(:, 4,3)/ 1,  0, -1,  1/ ; data Hlattice_tn(:, 4,3)/-1,  0,  1,  2/
+data Hlattice_td(:, 5,3)/ 0,  1, -1,  1/ ; data Hlattice_tn(:, 5,3)/ 0, -1,  1,  2/
+data Hlattice_td(:, 6,3)/-1,  1,  0,  1/ ; data Hlattice_tn(:, 6,3)/ 1, -1,  0,  2/
+
+
+!*(2112)<211-2> Twin: shear 0.224 1.19 tension
+!* 31- [ 2 -1 -1 -3]( 2 -1 -1  2)
+!* 32- [ 1  1 -2 -3]( 1  1 -2  2)
+!* 33- [-1  2 -1 -3](-1  2 -1  2)
+!* 34- [-2  1  1 -3](-2  1  1  2)
+!* 35- [-1 -1  2 -3](-1 -1  2  2)
+!* 36- [ 1 -2  1 -3]( 1 -2  1  2)
+data Hlattice_td(:, 7,3)/ 2, -1, -1, -3/ ; data Hlattice_tn(:, 7,3)/ 2, -1, -1,  2/
+data Hlattice_td(:, 8,3)/ 1,  1, -2, -3/ ; data Hlattice_tn(:, 8,3)/ 1,  1, -2,  2/
+data Hlattice_td(:, 9,3)/-1,  2, -1, -3/ ; data Hlattice_tn(:, 9,3)/-1,  2, -1,  2/
+data Hlattice_td(:,10,3)/-2,  1,  1, -3/ ; data Hlattice_tn(:,10,3)/-2,  1,  1,  2/
+data Hlattice_td(:,11,3)/-1, -1,  2, -3/ ; data Hlattice_tn(:,11,3)/-1, -1,  2,  2/
+data Hlattice_td(:,12,3)/1,  -2,  1, -3/ ; data Hlattice_tn(:,12,3)/ 1, -2,  1,  2/
+
+
+!* (2111)<211-6> Twin: shear 0.628 -0.39 compressio
+!* 37- [-2  1  1  6]( 2 -1 -1  1)
+!* 38- [-1 -1  2  6]( 1  1 -2  1)
+!* 39- [ 1 -2  1  6](-1  2 -1  1)
+!* 40- [ 2 -1 -1  6](-2  1  1  1)
+!* 41- [ 1  1 -2  6](-1 -1  2  1)
+!* 42- [-1  2 -1  6]( 1 -2  1  1)
+data Hlattice_td(:,13,3)/-2,  1,  1,  6/ ; data Hlattice_tn(:,13,3)/ 2, -1, -1,  1/
+data Hlattice_td(:,14,3)/-1, -1,  2,  6/ ; data Hlattice_tn(:,14,3)/ 1,  1, -2,  1/
+data Hlattice_td(:,15,3)/ 1, -2,  1,  6/ ; data Hlattice_tn(:,15,3)/-1,  2, -1,  1/
+data Hlattice_td(:,16,3)/ 2, -1, -1,  6/ ; data Hlattice_tn(:,16,3)/-2,  1,  1,  1/
+data Hlattice_td(:,17,3)/ 1,  1, -2,  6/ ; data Hlattice_tn(:,17,3)/-1, -1,  2,  1/
+data Hlattice_td(:,18,3)/-1,  2, -1,  6/ ; data Hlattice_tn(:,18,3)/ 1, -2,  1,  1/
+
+
+!* (1011)<101-2> Twin: shear 0.103 1.09 tension
+!* 43- [ 1  0 -1 -2]( 1  0 -1  1)
+!* 44- [-1  0  1 -2](-1  0  1  1)
+!* 45- [ 0  1 -1 -2]( 0  1 -1  1)
+!* 46- [ 0 -1  2 -2]( 0 -1  1  1)
+!* 47- [ 1 -1  0 -2]( 1 -1  0  1)
+!* 48- [-1  1  0 -2](-1  1  0  1)
+data Hlattice_td(:,19,3)/ 1,  0, -1, -2/ ; data Hlattice_tn(:,19,3)/ 1,  0, -1,  1/
+data Hlattice_td(:,20,3)/-1,  0,  1, -2/ ; data Hlattice_tn(:,20,3)/-1,  0,  1,  1/
+data Hlattice_td(:,21,3)/ 0,  1, -1, -2/ ; data Hlattice_tn(:,21,3)/ 0,  1, -1,  1/
+data Hlattice_td(:,22,3)/ 0, -1,  1, -2/ ; data Hlattice_tn(:,22,3)/ 0, -1,  1,  1/
+data Hlattice_td(:,23,3)/ 1, -1,  0, -2/ ; data Hlattice_tn(:,23,3)/ 1, -1,  0,  1/
+data Hlattice_td(:,24,3)/-1,  1,  0, -2/ ; data Hlattice_tn(:,24,3)/-1,  1,  0,  1/
+
+
+!*** Slip-Slip interactions for HCP structures (3) ***
+data lattice_SlipIntType( 1,1:lattice_MaxNslipOfStructure(3),3)/1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType( 2,1:lattice_MaxNslipOfStructure(3),3)/1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType( 3,1:lattice_MaxNslipOfStructure(3),3)/1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType( 4,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType( 5,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType( 6,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType( 7,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType( 8,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType( 9,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(10,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(11,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(12,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(13,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(14,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(15,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(16,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2/
+data lattice_SlipIntType(17,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2/
+data lattice_SlipIntType(18,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2/
+data lattice_SlipIntType(19,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2/
+data lattice_SlipIntType(20,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2/
+data lattice_SlipIntType(21,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2/
+data lattice_SlipIntType(22,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2/
+data lattice_SlipIntType(23,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2/
+data lattice_SlipIntType(24,1:lattice_MaxNslipOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1/
+
+!*** slip-twin interactions for HCP structures (3) ***
+data lattice_SlipTwinIntType( 1,1:lattice_MaxNtwinOfStructure(3),3)/1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipTwinIntType( 2,1:lattice_MaxNtwinOfStructure(3),3)/2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipTwinIntType( 3,1:lattice_MaxNtwinOfStructure(3),3)/2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipTwinIntType( 4,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipTwinIntType( 5,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipTwinIntType( 6,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipTwinIntType( 7,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipTwinIntType( 8,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipTwinIntType( 9,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipTwinIntType(10,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipTwinIntType(11,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipTwinIntType(12,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipTwinIntType(13,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipTwinIntType(14,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2/
+data lattice_SlipTwinIntType(15,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2/
+data lattice_SlipTwinIntType(16,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2/
+data lattice_SlipTwinIntType(17,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2/
+data lattice_SlipTwinIntType(18,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2/
+data lattice_SlipTwinIntType(19,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2/
+data lattice_SlipTwinIntType(20,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2/
+data lattice_SlipTwinIntType(21,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2/
+data lattice_SlipTwinIntType(22,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2/
+data lattice_SlipTwinIntType(23,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2/
+data lattice_SlipTwinIntType(24,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1/
+
+!*** Twin-twin interactions for HCP structures (3) ***
+data lattice_TwinIntType( 1,1:lattice_MaxNtwinOfStructure(3),3)/1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_TwinIntType( 2,1:lattice_MaxNtwinOfStructure(3),3)/2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_TwinIntType( 3,1:lattice_MaxNtwinOfStructure(3),3)/2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_TwinIntType( 4,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_TwinIntType( 5,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_TwinIntType( 6,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_TwinIntType( 7,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_TwinIntType( 8,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_TwinIntType( 9,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_TwinIntType(10,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_TwinIntType(11,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_TwinIntType(12,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_TwinIntType(13,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2,2/
+data lattice_TwinIntType(14,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2,2/
+data lattice_TwinIntType(15,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2,2/
+data lattice_TwinIntType(16,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2,2/
+data lattice_TwinIntType(17,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2,2/
+data lattice_TwinIntType(18,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2,2/
+data lattice_TwinIntType(19,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2,2/
+data lattice_TwinIntType(20,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2,2/
+data lattice_TwinIntType(21,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2,2/
+data lattice_TwinIntType(22,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2,2/
+data lattice_TwinIntType(23,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,2/
+data lattice_TwinIntType(24,1:lattice_MaxNtwinOfStructure(3),3)/2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1/
+
+
+
+CONTAINS
+!****************************************
+!* - lattice_Init
+!* - lattice_SchmidMatrices
+!****************************************
+
+
+subroutine lattice_init()
+!**************************************
+!*      Module initialization         *
+!**************************************
+call lattice_SchmidMatrices()
+end subroutine
+
+
+subroutine lattice_SchmidMatrices()
+!**************************************
+!*   Calculation of Schmid matrices   *
+!**************************************
+use prec, only: pReal,pInt
+use math, only: math_I3,nrmMandel,mapMandel
+implicit none
+
+!* Definition of variables
+integer(pInt) i,j,k,l
+real(pReal) norm_d,norm_t,norm_n
+real(pReal) norm_sn, norm_sd, norm_tn, norm_td, ratio
+
+!*** Only HCP crystal: converting from 4 axes coordinate system (a1=a2=a3=c) to ortho-hexgonal system (a, b, c)
+!* Plane (hkil)->(h (h+2k)/sqrt(3) l/(c/a)): this has been changed to unit vector afterward.
+!* Direction [uvtw]->[3u/2 (u+2v)*sqrt(3)/2 w*(c/a)]: this has been changed to unit vector afterward.
+!* Equations provided by Prof. Tom Bieler
+!* need to input "c/a rati"o in somewhere in mattax.mpie file(I am not sure where to insert this value for now????).
+
+ratio = 1.56
+
+do i = 1,lattice_MaxNslipOfStructure(3)
+
+!* slip system conversion
+    H_lattice_sn(1,i,3) = Hlattice_sn(1,i,3)
+    H_lattice_sn(2,i,3) = (Hlattice_sn(1,i,3)+ 2.0*Hlattice_sn(2,i,3))/sqrt(3.0)
+    H_lattice_sn(3,i,3) = Hlattice_sn(4,i,3)/ratio
+    
+    norm_sn = dsqrt(H_lattice_sn(1,i,3)**2 + H_lattice_sn(2,i,3)**2 + H_lattice_sn(3,i,3)**2)
+    
+    lattice_sn(1,i,3) = H_lattice_sn(1,i,3)/norm_sn
+    lattice_sn(2,i,3) = H_lattice_sn(2,i,3)/norm_sn
+    lattice_sn(3,i,3) = H_lattice_sn(3,i,3)/norm_sn
+    
+    H_lattice_sd(1,i,3) = 1.5*Hlattice_sd(1,i,3)
+    H_lattice_sd(2,i,3) = (Hlattice_sd(1,i,3) + 2.0*Hlattice_sd(2,i,3))*(sqrt(3.0)/2.0)
+    H_lattice_sd(3,i,3) = Hlattice_sd(4,i,3)*ratio
+
+    norm_sd = dsqrt(H_lattice_sd(1,i,3)**2 + H_lattice_sd(2,i,3)**2 + H_lattice_sd(3,i,3)**2)
+    
+    lattice_sd(1,i,3) = H_lattice_sd(1,i,3)/norm_sd
+    lattice_sd(2,i,3) = H_lattice_sd(2,i,3)/norm_sd
+    lattice_sd(3,i,3) = H_lattice_sd(3,i,3)/norm_sd
+
+!* twin system conversion
+    H_lattice_tn(1,i,3) = Hlattice_tn(1,i,3)
+    H_lattice_tn(2,i,3) = (Hlattice_tn(1,i,3)+ 2.0*Hlattice_tn(2,i,3))/sqrt(3.0)
+    H_lattice_tn(3,i,3) = Hlattice_tn(4,i,3)/ratio
+    
+    norm_tn = dsqrt(H_lattice_tn(1,i,3)**2 + H_lattice_tn(2,i,3)**2 + H_lattice_tn(3,i,3)**2)
+    
+    lattice_tn(1,i,3) = H_lattice_tn(1,i,3)/norm_tn
+    lattice_tn(2,i,3) = H_lattice_tn(2,i,3)/norm_tn
+    lattice_tn(3,i,3) = H_lattice_tn(3,i,3)/norm_tn
+    
+    H_lattice_td(1,i,3) = 1.5*Hlattice_td(1,i,3)
+    H_lattice_td(2,i,3) = (Hlattice_td(1,i,3)+ 2.0*Hlattice_td(2,i,3))*(sqrt(3.0)/2.0)
+    H_lattice_td(3,i,3) = Hlattice_td(4,i,3)*ratio
+    
+    norm_td = dsqrt(H_lattice_td(1,i,3)**2 + H_lattice_td(2,i,3)**2 + H_lattice_td(3,i,3)**2)
+    
+    lattice_td(1,i,3) = H_lattice_td(1,i,3)/norm_td
+    lattice_td(2,i,3) = H_lattice_td(2,i,3)/norm_td
+    lattice_td(3,i,3) = H_lattice_td(3,i,3)/norm_td
+    
+enddo
+
+!* Iteration over the lattice structures
+do l=1,lattice_MaxLatticeStructure
+!* Iteration over the slip systems
+   do k=1,lattice_MaxNslipOfStructure(l)
+!* Definition of transverse direction st for the frame (sd,st,sn)
+      lattice_st(1,k,l)=lattice_sn(2,k,l)*lattice_sd(3,k,l)-lattice_sn(3,k,l)*lattice_sd(2,k,l)
+	  lattice_st(2,k,l)=lattice_sn(3,k,l)*lattice_sd(1,k,l)-lattice_sn(1,k,l)*lattice_sd(3,k,l)
+	  lattice_st(3,k,l)=lattice_sn(1,k,l)*lattice_sd(2,k,l)-lattice_sn(2,k,l)*lattice_sd(1,k,l)
+	  norm_d=dsqrt(lattice_sd(1,k,l)**2+lattice_sd(2,k,l)**2+lattice_sd(3,k,l)**2)
+      norm_t=dsqrt(lattice_st(1,k,l)**2+lattice_st(2,k,l)**2+lattice_st(3,k,l)**2)
+      norm_n=dsqrt(lattice_sn(1,k,l)**2+lattice_sn(2,k,l)**2+lattice_sn(3,k,l)**2)
+      lattice_sd(:,k,l)=lattice_sd(:,k,l)/norm_d
+	  lattice_st(:,k,l)=lattice_st(:,k,l)/norm_t
+	  lattice_sn(:,k,l)=lattice_sn(:,k,l)/norm_n
+!* Defintion of Schmid matrix
+      forall (i=1:3,j=1:3) lattice_Sslip(i,j,k,l)=lattice_sd(i,k,l)*lattice_sn(j,k,l)
+!* Vectorization of normalized Schmid matrix
+      forall (i=1:6) lattice_Sslip_v(i,k,l) = nrmMandel(i)/2.0_pReal * &
+                  (lattice_Sslip(mapMandel(1,i),mapMandel(2,i),k,l)+lattice_Sslip(mapMandel(2,i),mapMandel(1,i),k,l))
+   enddo
+
+!* Iteration over the twin systems
+   do k=1,lattice_MaxNtwinOfStructure(l)
+!* Definition of transverse direction tt for the frame (td,tt,tn)
+      lattice_tt(1,k,l)=lattice_tn(2,k,l)*lattice_td(3,k,l)-lattice_tn(3,k,l)*lattice_td(2,k,l)
+	  lattice_tt(2,k,l)=lattice_tn(3,k,l)*lattice_td(1,k,l)-lattice_tn(1,k,l)*lattice_td(3,k,l)
+	  lattice_tt(3,k,l)=lattice_tn(1,k,l)*lattice_td(2,k,l)-lattice_tn(2,k,l)*lattice_td(1,k,l)
+	  norm_d=dsqrt(lattice_td(1,k,l)**2+lattice_td(2,k,l)**2+lattice_td(3,k,l)**2)
+      norm_t=dsqrt(lattice_tt(1,k,l)**2+lattice_tt(2,k,l)**2+lattice_tt(3,k,l)**2)
+      norm_n=dsqrt(lattice_tn(1,k,l)**2+lattice_tn(2,k,l)**2+lattice_tn(3,k,l)**2)
+      lattice_td(:,k,l)=lattice_td(:,k,l)/norm_d
+	  lattice_tt(:,k,l)=lattice_tt(:,k,l)/norm_t
+	  lattice_tn(:,k,l)=lattice_tn(:,k,l)/norm_n
+!* Defintion of Schmid matrix and transformation matrices
+      lattice_Qtwin(:,:,k,l)=-math_I3
+      forall (i=1:3,j=1:3)
+	         lattice_Stwin(i,j,k,l)=lattice_td(i,k,l)*lattice_tn(j,k,l)
+			 lattice_Qtwin(i,j,k,l)=lattice_Qtwin(i,j,k,l)+2*lattice_tn(i,k,l)*lattice_tn(j,k,l)
+      endforall
+!* Vectorization of normalized Schmid matrix
+      lattice_Stwin_v(1,k,l)=lattice_Stwin(1,1,k,l)
+      lattice_Stwin_v(2,k,l)=lattice_Stwin(2,2,k,l)
+      lattice_Stwin_v(3,k,l)=lattice_Stwin(3,3,k,l)
+	  !* be compatible with Mandel notation of Tstar
+      lattice_Stwin_v(4,k,l)=(lattice_Stwin(1,2,k,l)+lattice_Stwin(2,1,k,l))/dsqrt(2.0_pReal)
+      lattice_Stwin_v(5,k,l)=(lattice_Stwin(2,3,k,l)+lattice_Stwin(3,2,k,l))/dsqrt(2.0_pReal)
+      lattice_Stwin_v(6,k,l)=(lattice_Stwin(1,3,k,l)+lattice_Stwin(3,1,k,l))/dsqrt(2.0_pReal)
+   enddo
+enddo
+
+!*** printout schmid matrix (0nly Hexagonal structure)to check if the conversion is correctly done.
+
+!* define the output location
+!open(7, FILE='slip.prn')
+!open(8, FILE='twin.prn')
+!
+!do k = 1,24
+!       write(7,*) k
+!        write(7,*) lattice_Sslip(1,1,k,3),lattice_Sslip(1,2,k,3),lattice_Sslip(1,3,k,3)
+!        write(7,*) lattice_Sslip(2,1,k,3),lattice_Sslip(2,2,k,3),lattice_Sslip(2,3,k,3)
+!        write(7,*) lattice_Sslip(3,1,k,3),lattice_Sslip(3,2,k,3),lattice_Sslip(3,3,k,3)
+!        write(7,*)
+!        write(8,*) k
+!        write(8,*) lattice_Stwin(1,1,k,3),lattice_Stwin(2,2,k,3),lattice_Stwin(3,3,k,3)
+!        write(8,*) lattice_Stwin(2,1,k,3),lattice_Stwin(2,2,k,3),lattice_Stwin(2,3,k,3)
+!        write(8,*) lattice_Stwin(3,1,k,3),lattice_Stwin(3,2,k,3),lattice_Stwin(3,3,k,3)
+!        write(8,*)
+!enddo
+
+end subroutine
+
+END MODULE
+
+	   
+         
diff --git a/trunk/math.f90 b/trunk/math.f90
index 027448c8e..b9fc608fb 100644
--- a/trunk/math.f90
+++ b/trunk/math.f90
@@ -221,8 +221,8 @@
  use prec, only: pReal, pInt
  implicit none
 
- integer(pInt), intent(in) :: dimen
- integer(pInt)  i,j,k,l
+ integer(pInt), intent(in) :: dimen
+ integer(pInt)  i,j,k,l
  real(pReal), dimension(dimen,dimen,dimen,dimen) ::  math_identity4th
 
  forall (i=1:dimen,j=1:dimen,k=1:dimen,l=1:dimen) math_identity4th(i,j,k,l) = &
@@ -232,47 +232,47 @@
  END FUNCTION
 
  
-!**************************************************************************
-! vector product a x b
-!**************************************************************************
- PURE FUNCTION math_vectorproduct(A,B)  
-
- use prec, only: pReal, pInt
- implicit none
-
- real(pReal), dimension(3), intent(in) ::  A,B
- real(pReal), dimension(3) ::  math_vectorproduct
-
- math_vectorproduct(1) = A(2)*B(3)-A(3)*B(2)
- math_vectorproduct(2) = A(3)*B(1)-A(1)*B(3)
- math_vectorproduct(3) = A(1)*B(2)-A(2)*B(1)
-
- return
-
- END FUNCTION
-
- 
-
-!**************************************************************************
-! matrix multiplication 3x3
-!**************************************************************************
- PURE FUNCTION math_mul33x33(A,B)  
-
- use prec, only: pReal, pInt
- implicit none
-
- integer(pInt)  i,j
- real(pReal), dimension(3,3), intent(in) ::  A,B
- real(pReal), dimension(3,3) ::  math_mul33x33
-
- forall (i=1:3,j=1:3) math_mul33x33(i,j) = &
-   A(i,1)*B(1,j) + A(i,2)*B(2,j) + A(i,3)*B(3,j)
- return
-
- END FUNCTION
-
- 
-
+!**************************************************************************
+! vector product a x b
+!**************************************************************************
+ PURE FUNCTION math_vectorproduct(A,B)  
+
+ use prec, only: pReal, pInt
+ implicit none
+
+ real(pReal), dimension(3), intent(in) ::  A,B
+ real(pReal), dimension(3) ::  math_vectorproduct
+
+ math_vectorproduct(1) = A(2)*B(3)-A(3)*B(2)
+ math_vectorproduct(2) = A(3)*B(1)-A(1)*B(3)
+ math_vectorproduct(3) = A(1)*B(2)-A(2)*B(1)
+
+ return
+
+ END FUNCTION
+
+ 
+
+!**************************************************************************
+! matrix multiplication 3x3
+!**************************************************************************
+
+ PURE FUNCTION math_mul33x33(A,B)  
+
+ use prec, only: pReal, pInt
+ implicit none
+
+ integer(pInt)  i,j
+ real(pReal), dimension(3,3), intent(in) ::  A,B
+ real(pReal), dimension(3,3) ::  math_mul33x33
+
+ forall (i=1:3,j=1:3) math_mul33x33(i,j) = &
+   A(i,1)*B(1,j) + A(i,2)*B(2,j) + A(i,3)*B(3,j)
+ return
+
+ END FUNCTION
+
+
 !**************************************************************************
 ! matrix multiplication 6x6
 !**************************************************************************
@@ -282,8 +282,8 @@
  implicit none
 
  integer(pInt)  i,j
- real(pReal), dimension(6,6), intent(in) ::  A,B
- real(pReal), dimension(6,6) ::  math_mul66x66
+ real(pReal), dimension(6,6), intent(in) ::  A,B
+ real(pReal), dimension(6,6) ::  math_mul66x66
 
  forall (i=1:6,j=1:6) math_mul66x66(i,j) = &
    A(i,1)*B(1,j) + A(i,2)*B(2,j) + A(i,3)*B(3,j) + &
@@ -292,25 +292,27 @@
 
  END FUNCTION
 
-!**************************************************************************
-! matrix multiplication 6x6
-!**************************************************************************
- PURE FUNCTION math_mul66x6(A,B)  
-
- use prec, only: pReal, pInt
- implicit none
-
- integer(pInt)  i
- real(pReal), dimension(6,6), intent(in) ::  A
- real(pReal), dimension(6),   intent(in) ::  B
- real(pReal), dimension(6) ::  math_mul66x6
-
- forall (i=1:6) math_mul66x6(i) = &
-   A(i,1)*B(1) + A(i,2)*B(2) + A(i,3)*B(3) + &
-   A(i,4)*B(4) + A(i,5)*B(5) + A(i,6)*B(6)
- return
-
- END FUNCTION
+
+!**************************************************************************
+! matrix multiplication 6x6
+!**************************************************************************
+ PURE FUNCTION math_mul66x6(A,B)  
+
+ use prec, only: pReal, pInt
+ implicit none
+
+ integer(pInt)  i
+ real(pReal), dimension(6,6), intent(in) ::  A
+ real(pReal), dimension(6),   intent(in) ::  B
+ real(pReal), dimension(6) ::  math_mul66x6
+
+ forall (i=1:6) math_mul66x6(i) = &
+   A(i,1)*B(1) + A(i,2)*B(2) + A(i,3)*B(3) + &
+   A(i,4)*B(4) + A(i,5)*B(5) + A(i,6)*B(6)
+ return
+
+ END FUNCTION
+
  
 !**************************************************************************
 ! matrix multiplication 9x9
@@ -321,8 +323,10 @@
  implicit none
 
  integer(pInt)  i,j
- real(pReal), dimension(9,9), intent(in) ::  A,B
- real(pReal), dimension(9,9) ::  math_mul99x99
+ real(pReal), dimension(9,9), intent(in) ::  A,B
+
+ real(pReal), dimension(9,9) ::  math_mul99x99
+
 
  forall (i=1:9,j=1:9) math_mul99x99(i,j) = &
    A(i,1)*B(1,j) + A(i,2)*B(2,j) + A(i,3)*B(3,j) + &
@@ -610,9 +614,9 @@
  use prec, only: pReal,pInt
  implicit none
 
- integer(pInt) i,j
- real(pReal), dimension(6,6), intent(in) :: m
- real(pReal), dimension(6,6) :: math_symmetric6x6
+ integer(pInt) i,j
+ real(pReal), dimension(6,6), intent(in) :: m
+ real(pReal), dimension(6,6) :: math_symmetric6x6
  
  forall (i=1:6,j=1:6) math_symmetric6x6(i,j) = 1.0_pReal/2.0_pReal * &
    (m(i,j) + m(j,i))
@@ -629,7 +633,7 @@
  implicit none
 
  real(pReal), dimension(3,3), intent(in) :: m
- real(pReal) math_det3x3
+ real(pReal) math_det3x3
 
  math_det3x3 = 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)) &
@@ -807,10 +811,10 @@
 
  use prec, only: pReal, pInt
  implicit none
-
+
  real(pReal), dimension (3,3), intent(in) :: R
  real(pReal), dimension(3) :: math_RtoEuler
- real(pReal) sqhkl, squvw, sqhk, val
+ real(pReal) sqhkl, squvw, sqhk, val
 
  sqhkl=sqrt(R(1,3)*R(1,3)+R(2,3)*R(2,3)+R(3,3)*R(3,3))
  squvw=sqrt(R(1,1)*R(1,1)+R(2,1)*R(2,1)+R(3,1)*R(3,1))
@@ -862,9 +866,9 @@
  use prec, only: pReal, pInt
  implicit none
 
- real(pReal), dimension(3), intent(in) :: axis
- real(pReal), intent(in) :: omega
- real(pReal), dimension(3) :: axisNrm
+ real(pReal), dimension(3), intent(in) :: axis
+ real(pReal), intent(in) :: omega
+ real(pReal), dimension(3) :: axisNrm
  real(pReal), dimension(3,3) :: math_RodrigToR
  real(pReal) s,c
  integer(pInt) i
@@ -976,16 +980,11 @@
  real(pReal) noise,scatter,cosScatter
  integer(pInt) i
 
-
 if (noise==0.0) then
-
     math_sampleGaussOri = center
-
     return
-
 endif
 
-
 ! Helming uses different distribution with Bessel functions
 ! therefore the gauss scatter width has to be scaled differently
  scatter = 0.95_pReal * noise
@@ -2034,28 +2033,27 @@ math_sampleFiberOri = math_RtoEuler(math_mul33x33(pRot,math_mul33x33(fRot,oRot))
  
  END FUNCTION
 
-!**************************************************************************
-! volume of tetrahedron given by four vertices
-!**************************************************************************
- PURE FUNCTION math_volTetrahedron(v1,v2,v3,v4)  
-
- use prec, only: pReal
- implicit none
-
- real(pReal) math_volTetrahedron
- real(pReal), dimension (3), intent(in) :: v1,v2,v3,v4
- real(pReal), dimension (3,3) :: m
-
- m(:,1) = v1-v2
- m(:,2) = v2-v3
- m(:,3) = v3-v4
-
- math_volTetrahedron = math_det3x3(m)/6.0_pReal 
- return
-
- END FUNCTION
-
-
-
- END MODULE math
+!**************************************************************************
+! volume of tetrahedron given by four vertices
+!**************************************************************************
+ PURE FUNCTION math_volTetrahedron(v1,v2,v3,v4)  
 
+ use prec, only: pReal
+ implicit none
+
+ real(pReal) math_volTetrahedron
+ real(pReal), dimension (3), intent(in) :: v1,v2,v3,v4
+ real(pReal), dimension (3,3) :: m
+
+ m(:,1) = v1-v2
+ m(:,2) = v2-v3
+ m(:,3) = v3-v4
+
+ math_volTetrahedron = math_det3x3(m)/6.0_pReal 
+ return
+
+ END FUNCTION
+
+
+
+ END MODULE math
diff --git a/trunk/mattex.mpie b/trunk/mattex.mpie
index bfc4ed6d2..0f26301ac 100644
--- a/trunk/mattex.mpie
+++ b/trunk/mattex.mpie
@@ -1,83 +1,83 @@
-<materials>
-[TWIP steel FeMnC]
-lattice_structure		              1
-Nslip				              12
-Ntwin                                         0
-## Elastic constants 
-# Unit in [Pa]
-C11				              183.9e9
-C12				              101.9e9
-C44				              115.4e9
-
-## Parameters for phenomenological modeling
-# Unit in [Pa]
-s0_slip				              85.0e6
-gdot0_slip			              0.001
-n_slip				              100.0
-h0				              355.0e6
-s_sat				              265.0e6
-w0				              1.0
-# Self and latent hardening coefficients
-hardening_coefficients        	              1.0 1.4
-
-## Parameters for dislocation-based modeling
-# Burgers vector [m]                        
-burgers			                      2.56e-10
-# Activation energy for dislocation glide [J/K] (0.5*G*b^3)
-Qedge				              5.5e-19
-# Activation energy for self diffusion [J/K] (gamma-iron)
-Qsd				              4.7e-19
-# Vacancy diffusion coeffficent              (gamma-iron)
-diff0				              4.0e-5
-# Average grain size [m]
-grain_size                                    2.0e-5
-# Dislocation interaction coefficients
-interaction_coefficients	              1.0 2.2 3.0 1.6 3.8 4.5
-
-# Initial dislocation density [m]²
-rho0				              6.0e12 
-# Passing stress adjustment
-c1				              0.1
-# Jump width adjustment
-c2                                            2.0
-# Activation volume adjustment
-c3                                            1.0
-# Average slip distance adjustment for lock formation
-c4                      	              50.0
-# Average slip distance adjustment when grain boundaries
-c5                                            1.0                                            
-# Athermal recovery adjustment
-c7				              8.0
-# Thermal recovery adjustment (plays no role for me)
-c8				              1.0e10
-
-## Parameters for mechanical twinning
-# Average twin thickness (stacks) [m]
-stack_size                                    5.0e-8
-# Total twin volume fraction saturation
-f_sat                                         1.0
-# Average slip distance adjustment when twin boundaries
-c6 
-# Scaling potential nucleation sites
-site_scaling                                  1.0e-6
-# Scaling the P-K force on the twinning dislocation
-q1                                            1.0
-# Scaling the resolved shear stress
-q2                                            1.0
-
-                      
-
-<textures>
-[cube SX]
-symmetry			no /monoclinic /orthorhombic
-Ngrains				10 /2 /4
-#(gauss)				phi1	0.0	phi	29.21	phi2	-26.57 scatter 0.0	fraction 1.0
-#(gauss)				phi1	0.0	phi	54.74	phi2	-45.0  scatter 0.0	fraction 0.1
-#(gauss)				phi1	0.0	phi	45.0	phi2	 0.0   scatter 0.0	fraction 0.1
-#(gauss)				phi1	0.0	phi	0.0	phi2	 0.0   scatter 0.0	fraction 0.1
-#(gauss)				phi1	0.0	phi	35.26	phi2	-45.0  scatter 0.0	fraction 0.1
-#(gauss)				phi1	0.0	phi	48.19	phi2	-26.57 scatter 0.0	fraction 0.1
-#(gauss)				phi1	0.0	phi	26.57	phi2	 0.0   scatter 0.0	fraction 0.1
-#(gauss)				phi1	0.0	phi	42.03	phi2	-33.69 scatter 0.0	fraction 0.1
-#(gauss)				phi1	0.0	phi	40.36	phi2	-11.31 scatter 0.0	fraction 0.1
-#(gauss)				phi1	0.0	phi	15.62	phi2	-26.57 scatter 0.0	fraction 0.1
+<materials>
+[TWIP steel FeMnC]
+lattice_structure		              1
+Nslip				              12
+Ntwin                                         0
+## Elastic constants 
+# Unit in [Pa]
+C11				              183.9e9
+C12				              101.9e9
+C44				              115.4e9
+
+## Parameters for phenomenological modeling
+# Unit in [Pa]
+s0_slip				              85.0e6
+gdot0_slip			              0.001
+n_slip				              100.0
+h0				              355.0e6
+s_sat				              265.0e6
+w0				              1.0
+# Self and latent hardening coefficients
+hardening_coefficients        	              1.0 1.4
+
+## Parameters for dislocation-based modeling
+# Burgers vector [m]                        
+burgers			                      2.56e-10
+# Activation energy for dislocation glide [J/K] (0.5*G*b^3)
+Qedge				              5.5e-19
+# Activation energy for self diffusion [J/K] (gamma-iron)
+Qsd				              4.7e-19
+# Vacancy diffusion coeffficent              (gamma-iron)
+diff0				              4.0e-5
+# Average grain size [m]
+grain_size                                    2.0e-5
+# Dislocation interaction coefficients
+interaction_coefficients	              1.0 2.2 3.0 1.6 3.8 4.5
+
+# Initial dislocation density [m]²
+rho0				              6.0e12 
+# Passing stress adjustment
+c1				              0.1
+# Jump width adjustment
+c2                                            2.0
+# Activation volume adjustment
+c3                                            1.0
+# Average slip distance adjustment for lock formation
+c4                      	              50.0
+# Average slip distance adjustment when grain boundaries
+c5                                            1.0                                            
+# Athermal recovery adjustment
+c7				              8.0
+# Thermal recovery adjustment (plays no role for me)
+c8				              1.0e10
+
+## Parameters for mechanical twinning
+# Average twin thickness (stacks) [m]
+stack_size                                    5.0e-8
+# Total twin volume fraction saturation
+f_sat                                         1.0
+# Average slip distance adjustment when twin boundaries
+c6 
+# Scaling potential nucleation sites
+site_scaling                                  1.0e-6
+# Scaling the P-K force on the twinning dislocation
+q1                                            1.0
+# Scaling the resolved shear stress
+q2                                            1.0
+
+                      
+
+<textures>
+[cube SX]
+symmetry			no /monoclinic /orthorhombic
+Ngrains				10 /2 /4
+#(gauss)				phi1	0.0	phi	29.21	phi2	-26.57 scatter 0.0	fraction 1.0
+#(gauss)				phi1	0.0	phi	54.74	phi2	-45.0  scatter 0.0	fraction 0.1
+#(gauss)				phi1	0.0	phi	45.0	phi2	 0.0   scatter 0.0	fraction 0.1
+#(gauss)				phi1	0.0	phi	0.0	phi2	 0.0   scatter 0.0	fraction 0.1
+#(gauss)				phi1	0.0	phi	35.26	phi2	-45.0  scatter 0.0	fraction 0.1
+#(gauss)				phi1	0.0	phi	48.19	phi2	-26.57 scatter 0.0	fraction 0.1
+#(gauss)				phi1	0.0	phi	26.57	phi2	 0.0   scatter 0.0	fraction 0.1
+#(gauss)				phi1	0.0	phi	42.03	phi2	-33.69 scatter 0.0	fraction 0.1
+#(gauss)				phi1	0.0	phi	40.36	phi2	-11.31 scatter 0.0	fraction 0.1
+#(gauss)				phi1	0.0	phi	15.62	phi2	-26.57 scatter 0.0	fraction 0.1
diff --git a/trunk/mpie_cpfem_marc2007r1.f90 b/trunk/mpie_cpfem_marc2007r1.f90
index 465be638f..6f4e6ea0b 100644
--- a/trunk/mpie_cpfem_marc2007r1.f90
+++ b/trunk/mpie_cpfem_marc2007r1.f90
@@ -31,7 +31,7 @@
  include "debug.f90"            ! uses prec
  include "math.f90"             ! uses prec
  include "IO.f90"               ! uses prec, debug, math
- include "FEsolving.f90"        ! uses prec, IO
+ include "FEsolving.f90"        ! uses prec, IO
  include "mesh.f90"             ! uses prec, IO, math, FEsolving
  include "lattice.f90"          ! uses prec, math
  include "constitutive.f90"     ! uses prec, IO, math, lattice, mesh, debug
@@ -130,16 +130,11 @@
  use math, only: invnrmMandel
 
  implicit real(pReal) (a-h,o-z)
-
  integer(pInt) computationMode
 
-
-
  dimension e(*),de(*),t(*),dt(*),g(*),d(ngens,*),s(*), n(2),coord(ncrd,*),disp(ndeg,*),matus(2),dispt(ndeg,*),ffn(itel,*),&
            frotn(itel,*),strechn(itel),eigvn(itel,*),ffn1(itel,*),frotn1(itel,*),strechn1(itel),eigvn1(itel,*),kcus(2)
 
-
-
 ! Marc common blocks are in fixed format so they have to be pasted in here
 ! Beware of changes in newer Marc versions -- these are from 2005r3
 ! concom is needed for inc, subinc, ncycle, lovl
@@ -168,14 +163,13 @@
      cptim,timinc,timinc_p,timinc_s,timincm,timinc_a,timinc_b,creept(33),icptim,icfte,icfst,&
      icfeq,icftm,icetem,mcreep,jcreep,icpa,icftmp,icfstr,icfqcp,icfcpm,icrppr,icrcha,icpb,iicpmt,iicpa
 
-
  if (inc == 0) then
    cycleCounter = 4
  else
    if (theCycle > ncycle .or. theInc /= inc) cycleCounter = 0                  ! reset counter for each cutback or new inc
-   if (theCycle /= ncycle .or. theLovl /= lovl) then
-     cycleCounter = cycleCounter+1   ! ping pong
-     outdatedFFN1 = .false.
+   if (theCycle /= ncycle .or. theLovl /= lovl) then
+     cycleCounter = cycleCounter+1   ! ping pong
+     outdatedFFN1 = .false.
    endif
  endif
  if (cptim > theTime .or. theInc /= inc) then                                   ! reached convergence
@@ -195,12 +189,12 @@
  if (computationMode == 2 .and. outdatedByNewInc) then
    computationMode  = 1   ! compute and age former results
    outdatedByNewInc = .false.
- endif
- if (computationMode == 2 .and. outdatedFFN1) then
-   computationMode  = 4   ! return odd results to force new vyvle
- endif
+ endif
+
+ if (computationMode == 2 .and. outdatedFFN1) then
+   computationMode  = 4   ! return odd results to force new vyvle
+ endif
 
- 
  theTime  = cptim                                   ! record current starting time
  theInc   = inc                                     ! record current increment number
  theCycle = ncycle                                  ! record current cycle count
@@ -208,7 +202,6 @@
 
  call CPFEM_general(computationMode,ffn,ffn1,t(1),timinc,n(1),nn,s,mod(cycleCounter-4,4_pInt*ijaco)==0,d,ngens)
 
-
 !     Mandel: 11, 22, 33, SQRT(2)*12, SQRT(2)*23, SQRT(2)*13
 !     Marc:   11, 22, 33, 12, 23, 13
  forall(i=1:ngens) d(1:ngens,i) = invnrmMandel(i)*d(1:ngens,i)*invnrmMandel(1:ngens)
@@ -253,7 +246,8 @@
 ! assign result variable
  v=CPFEM_results(mod(jpltcd-1_pInt, CPFEM_Nresults+constitutive_maxNresults)+1_pInt,&
                  (jpltcd-1_pInt)/(CPFEM_Nresults+constitutive_maxNresults)+1_pInt,&
-                 nn, mesh_FEasCP('elem', m))
+                 nn, mesh_FEasCP('elem', m))
+
  return
  END SUBROUTINE
 !
diff --git a/trunk/mpie_cpfem_marc2007r1_sequential.f90 b/trunk/mpie_cpfem_marc2007r1_sequential.f90
index 5a090d833..fdfd0b867 100644
--- a/trunk/mpie_cpfem_marc2007r1_sequential.f90
+++ b/trunk/mpie_cpfem_marc2007r1_sequential.f90
@@ -27,15 +27,15 @@
 !             - creeps: timinc
 !********************************************************************
 !
- include "prec.f90"             ! uses nothing else
- include "debug.f90"            ! uses prec
- include "math.f90"             ! uses prec
- include "IO.f90"               ! uses prec, debug, math
- include "FEsolving.f90"        ! uses prec, IO
- include "mesh.f90"             ! uses prec, IO, math, FEsolving
- include "lattice.f90"          ! uses prec, math
- include "constitutive.f90"     ! uses prec, IO, math, lattice, mesh, debug
-! include "crystallite.f90"      ! uses prec, debug, constitutive, mesh, math, IO
+ include "prec.f90"             ! uses nothing else
+ include "debug.f90"            ! uses prec
+ include "math.f90"             ! uses prec
+ include "IO.f90"               ! uses prec, debug, math
+ include "FEsolving.f90"        ! uses prec, IO
+ include "mesh.f90"             ! uses prec, IO, math, FEsolving
+ include "lattice.f90"          ! uses prec, math
+ include "constitutive.f90"     ! uses prec, IO, math, lattice, mesh, debug
+! include "crystallite.f90"      ! uses prec, debug, constitutive, mesh, math, IO
  include "CPFEM_sequential.f90" ! uses prec, math, mesh, constitutive, FEsolving, debug, lattice, IO, crystallite
 !
 
@@ -130,16 +130,11 @@
  use math, only: invnrmMandel
 
  implicit real(pReal) (a-h,o-z)
-
  integer(pInt) computationMode
 
-
-
  dimension e(*),de(*),t(*),dt(*),g(*),d(ngens,*),s(*), n(2),coord(ncrd,*),disp(ndeg,*),matus(2),dispt(ndeg,*),ffn(itel,*),&
            frotn(itel,*),strechn(itel),eigvn(itel,*),ffn1(itel,*),frotn1(itel,*),strechn1(itel),eigvn1(itel,*),kcus(2)
 
-
-
 ! Marc common blocks are in fixed format so they have to be pasted in here
 ! Beware of changes in newer Marc versions -- these are from 2005r3
 ! concom is needed for inc, subinc, ncycle, lovl
@@ -168,7 +163,6 @@
      cptim,timinc,timinc_p,timinc_s,timincm,timinc_a,timinc_b,creept(33),icptim,icfte,icfst,&
      icfeq,icftm,icetem,mcreep,jcreep,icpa,icftmp,icfstr,icfqcp,icfcpm,icrppr,icrcha,icpb,iicpmt,iicpa
 
-
  if (inc == 0) then
    cycleCounter = 4
  else
@@ -202,7 +196,6 @@
 
  call CPFEM_general(computationMode,ffn,ffn1,t(1),timinc,n(1),nn,s,mod(cycleCounter-4,2_pInt*ijaco)==0,d,ngens)
 
-
 !     Mandel: 11, 22, 33, SQRT(2)*12, SQRT(2)*23, SQRT(2)*13
 !     Marc:   11, 22, 33, 12, 23, 13
  forall(i=1:ngens) d(1:ngens,i) = invnrmMandel(i)*d(1:ngens,i)*invnrmMandel(1:ngens)
diff --git a/trunk/mpie_cpfem_marc2008r1.f90 b/trunk/mpie_cpfem_marc2008r1.f90
index d66e407cd..ffbe3dd91 100644
--- a/trunk/mpie_cpfem_marc2008r1.f90
+++ b/trunk/mpie_cpfem_marc2008r1.f90
@@ -1,292 +1,290 @@
-!********************************************************************
-! Material subroutine for MSC.Marc Version 0.1
-!
-! written by F. Roters, P. Eisenlohr, L. Hantcherli, W.A. Counts
-! MPI fuer Eisenforschung, Duesseldorf
-!
-! last modified: 22.11.2008
-!********************************************************************
-!     Usage:
-!             - choose material as hypela2
-!             - set statevariable 2 to index of material
-!             - set statevariable 3 to index of texture
-!             - choose output of user variables if desired
-!             - make sure the file "mattex.mpie" exists in the working
-!               directory
-!             - use nonsymmetric option for solver (e.g. direct 
-!               profile or multifrontal sparse, the latter seems
-!               to be faster!)
-!             - in case of ddm a symmetric solver has to be used
-!********************************************************************
-!     Marc subroutines used:
-!             - hypela2
-!             - plotv
-!             - quit
-!********************************************************************
-!     Marc common blocks included:
-!             - concom: lovl, ncycle, inc, incsub
-!             - creeps: timinc
-!********************************************************************
-!
- include "prec.f90"             ! uses nothing else
- include "debug.f90"            ! uses prec
- include "math.f90"             ! uses prec
- include "IO.f90"               ! uses prec, debug, math
- include "FEsolving.f90"        ! uses prec, IO
- include "mesh.f90"             ! uses prec, IO, math, FEsolving
- include "lattice.f90"          ! uses prec, math
- include "constitutive.f90"     ! uses prec, IO, math, lattice, mesh, debug
-! include "crystallite.f90"      ! uses prec, debug, constitutive, mesh, math, IO
- include "CPFEM.f90"            ! uses prec, math, mesh, constitutive, FEsolving, debug, lattice, IO, crystallite
-!
-!
- SUBROUTINE hypela2(d,g,e,de,s,t,dt,ngens,n,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)
-!********************************************************************
-! This is the Marc material routine
-!********************************************************************
-!
-! *************   user subroutine for defining material behavior  **************
-!
-!
-! CAUTION : Due to calculation of the Deformation gradients, Stretch Tensors and
-!         Rotation tensors at previous and current states, the analysis can be
-!         computationally expensive. Please use the user subroutine ->  hypela
-!         if these kinematic quantities are not needed in the constitutive model
-!
-!
-! IMPORTANT NOTES :
-!
-! (1) F,R,U are only available for continuum and membrane elements (not for
-!     shells and beams).
-!
-! (2) For total Lagrangian formulation use the -> 'Elasticity,1' card(=
-!     total Lagrange with large disp) in the parameter section of input deck.
-!     For updated Lagrangian formulation use the -> 'Plasticity,3' card(=
-!     update+finite+large disp+constant d) in the parameter section of
-!     input deck.
-!
-!
-!     d            stress strain law to be formed
-!     g            change in stress due to temperature effects
-!     e            total elastic strain
-!     de           increment of strain
-!     s            stress - should be updated by user
-!     t            state variables (comes in at t=n, must be updated
-!                                   to have state variables at t=n+1)
-!     dt           increment of state variables
-!     ngens        size of stress - strain law
-!     n            element number
-!     nn           integration point number
-!     kcus(1)      layer number
-!     kcus(2)      internal layer number
-!     matus(1)     user material identification number
-!     matus(2)     internal material identification number
-!     ndi          number of direct components
-!     nshear       number of shear components
-!     disp         incremental displacements
-!     dispt        displacements at t=n   (at assembly,        lovl=4) and
-!                  displacements at t=n+1 (at stress recovery, lovl=6)
-!     coord        coordinates
-!     ncrd         number of coordinates
-!     ndeg         number of degrees of freedom
-!     itel         dimension of F and R, either 2 or 3
-!     nnode        number of nodes per element
-!     jtype        element type
-!     lclass       element class
-!     ifr          set to 1 if R has been calculated
-!     ifu          set to 1 if strech has been calculated
-!
-!     at t=n   :
-!
-!     ffn          deformation gradient
-!     frotn        rotation tensor
-!     strechn      square of principal stretch ratios, lambda(i)
-!     eigvn(i,j)   i principal direction components for j eigenvalues
-!
-!     at t=n+1 :
-!
-!     ffn1         deformation gradient
-!     frotn1       rotation tensor
-!     strechn1     square of principal stretch ratios, lambda(i)
-!     eigvn1(i,j)  i principal direction components for j eigenvalues
-!
-!     The following operation obtains U (stretch tensor) at t=n+1 :
-!
-!     call scla(un1,0.d0,itel,itel,1)
-!     do 3 k=1,3
-!      do 2 i=1,3
-!       do 1 j=1,3
-!        un1(i,j)=un1(i,j)+dsqrt(strechn1(k))*eigvn1(i,k)*eigvn1(j,k)
-!1      continue
-!2     continue
-!3    continue
-!
- use prec, only: pReal,pInt, ijaco
- use FEsolving
- use CPFEM, only: CPFEM_general
- use math, only: invnrmMandel
-!
+!********************************************************************
+! Material subroutine for MSC.Marc Version 0.1
+!
+! written by F. Roters, P. Eisenlohr, L. Hantcherli, W.A. Counts
+! MPI fuer Eisenforschung, Duesseldorf
+!
+! last modified: 22.11.2008
+!********************************************************************
+!     Usage:
+!             - choose material as hypela2
+!             - set statevariable 2 to index of material
+!             - set statevariable 3 to index of texture
+!             - choose output of user variables if desired
+!             - make sure the file "mattex.mpie" exists in the working
+!               directory
+!             - use nonsymmetric option for solver (e.g. direct 
+!               profile or multifrontal sparse, the latter seems
+!               to be faster!)
+!             - in case of ddm a symmetric solver has to be used
+!********************************************************************
+!     Marc subroutines used:
+!             - hypela2
+!             - plotv
+!             - quit
+!********************************************************************
+!     Marc common blocks included:
+!             - concom: lovl, ncycle, inc, incsub
+!             - creeps: timinc
+!********************************************************************
+!
+ include "prec.f90"             ! uses nothing else
+ include "debug.f90"            ! uses prec
+ include "math.f90"             ! uses prec
+ include "IO.f90"               ! uses prec, debug, math
+ include "FEsolving.f90"        ! uses prec, IO
+ include "mesh.f90"             ! uses prec, IO, math, FEsolving
+ include "lattice.f90"          ! uses prec, math
+ include "constitutive.f90"     ! uses prec, IO, math, lattice, mesh, debug
+! include "crystallite.f90"      ! uses prec, debug, constitutive, mesh, math, IO
+ include "CPFEM.f90"            ! uses prec, math, mesh, constitutive, FEsolving, debug, lattice, IO, crystallite
+!
+!
+ SUBROUTINE hypela2(d,g,e,de,s,t,dt,ngens,n,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)
+!********************************************************************
+! This is the Marc material routine
+!********************************************************************
+!
+! *************   user subroutine for defining material behavior  **************
+!
+!
+! CAUTION : Due to calculation of the Deformation gradients, Stretch Tensors and
+!         Rotation tensors at previous and current states, the analysis can be
+!         computationally expensive. Please use the user subroutine ->  hypela
+!         if these kinematic quantities are not needed in the constitutive model
+!
+!
+! IMPORTANT NOTES :
+!
+! (1) F,R,U are only available for continuum and membrane elements (not for
+!     shells and beams).
+!
+! (2) For total Lagrangian formulation use the -> 'Elasticity,1' card(=
+!     total Lagrange with large disp) in the parameter section of input deck.
+!     For updated Lagrangian formulation use the -> 'Plasticity,3' card(=
+!     update+finite+large disp+constant d) in the parameter section of
+!     input deck.
+!
+!
+!     d            stress strain law to be formed
+!     g            change in stress due to temperature effects
+!     e            total elastic strain
+!     de           increment of strain
+!     s            stress - should be updated by user
+!     t            state variables (comes in at t=n, must be updated
+!                                   to have state variables at t=n+1)
+!     dt           increment of state variables
+!     ngens        size of stress - strain law
+!     n            element number
+!     nn           integration point number
+!     kcus(1)      layer number
+!     kcus(2)      internal layer number
+!     matus(1)     user material identification number
+!     matus(2)     internal material identification number
+!     ndi          number of direct components
+!     nshear       number of shear components
+!     disp         incremental displacements
+!     dispt        displacements at t=n   (at assembly,        lovl=4) and
+!                  displacements at t=n+1 (at stress recovery, lovl=6)
+!     coord        coordinates
+!     ncrd         number of coordinates
+!     ndeg         number of degrees of freedom
+!     itel         dimension of F and R, either 2 or 3
+!     nnode        number of nodes per element
+!     jtype        element type
+!     lclass       element class
+!     ifr          set to 1 if R has been calculated
+!     ifu          set to 1 if strech has been calculated
+!
+!     at t=n   :
+!
+!     ffn          deformation gradient
+!     frotn        rotation tensor
+!     strechn      square of principal stretch ratios, lambda(i)
+!     eigvn(i,j)   i principal direction components for j eigenvalues
+!
+!     at t=n+1 :
+!
+!     ffn1         deformation gradient
+!     frotn1       rotation tensor
+!     strechn1     square of principal stretch ratios, lambda(i)
+!     eigvn1(i,j)  i principal direction components for j eigenvalues
+!
+!     The following operation obtains U (stretch tensor) at t=n+1 :
+!
+!     call scla(un1,0.d0,itel,itel,1)
+!     do 3 k=1,3
+!      do 2 i=1,3
+!       do 1 j=1,3
+!        un1(i,j)=un1(i,j)+dsqrt(strechn1(k))*eigvn1(i,k)*eigvn1(j,k)
+!1      continue
+!2     continue
+!3    continue
+!
+ use prec, only: pReal,pInt, ijaco
+ use FEsolving
+ use CPFEM, only: CPFEM_general
+ use math, only: invnrmMandel
+!
  implicit none
-!
+ 
 !     ** Start of generated type statements **
  real(pReal) coord, d, de, disp, dispt, dt, e, eigvn, eigvn1, ffn, ffn1
  real(pReal) frotn, frotn1, g
  integer(pInt) ifr, ifu, itel, jtype, kcus, lclass, matus, n, ncrd, ndeg
  integer(pInt) ndi, ndm, ngens, nn, nnode, nshear
  real(pReal) s, strechn, strechn1, t
-!     ** End of generated type statements **
+ !     ** End of generated type statements **
+ !
+ dimension e(*),de(*),t(*),dt(*),g(*),d(ngens,*),s(*), n(2),coord(ncrd,*),disp(ndeg,*),matus(2),dispt(ndeg,*),ffn(itel,*),&
+           frotn(itel,*),strechn(itel),eigvn(itel,*),ffn1(itel,*),frotn1(itel,*),strechn1(itel),eigvn1(itel,*),kcus(2),&
+           lclass(2)
 !
- dimension e(*),de(*),t(*),dt(*),g(*),d(ngens,*),s(*), n(2),coord(ncrd,*),disp(ndeg,*),matus(2),dispt(ndeg,*),ffn(itel,*),&
-           frotn(itel,*),strechn(itel),eigvn(itel,*),ffn1(itel,*),frotn1(itel,*),strechn1(itel),eigvn1(itel,*),kcus(2),&
-           lclass(2)
-!
-! Marc common blocks are in fixed format so they have to be reformated to free format (f90)
-! Beware of changes in newer Marc versions -- these are from 2005r3
-! concom is needed for inc, subinc, ncycle, lovl
- include "concom_f90"
-! creeps is needed for timinc (time increment)
- include "creeps_f90"
-!
- integer(pInt) computationMode,i
+! Marc common blocks are in fixed format so they have to be reformated to free format (f90)
+! Beware of changes in newer Marc versions -- these are from 2005r3
+! concom is needed for inc, subinc, ncycle, lovl
+ include "concom_f90"
+! creeps is needed for timinc (time increment)
+ include "creeps_f90"
 !
- if (inc == 0) then
-   cycleCounter = 4
- else
-   if (theCycle > ncycle .or. theInc /= inc) cycleCounter = 0                  ! reset counter for each cutback or new inc
-   if (theCycle /= ncycle .or. theLovl /= lovl) then
-     cycleCounter = cycleCounter+1   ! ping pong
-     outdatedFFN1 = .false.
-   endif
- endif
- if (cptim > theTime .or. theInc /= inc) then                                   ! reached convergence
-   lastIncConverged = .true.
-   outdatedByNewInc = .true.
- endif
-
- if (mod(cycleCounter,2) /= 0) computationMode = 4   ! recycle
- if (mod(cycleCounter,4) == 2) computationMode = 3   ! collect
- if (mod(cycleCounter,4) == 0) computationMode = 2   ! compute
- if (computationMode == 4 .and. ncycle == 0 .and. .not. lastIncConverged) &
-   computationMode = 6    ! recycle but restore known good consistent tangent
- if (computationMode == 4 .and. lastIncConverged) then
-   computationMode  = 5   ! recycle and record former consistent tangent
-   lastIncConverged = .false.
- endif
- if (computationMode == 2 .and. outdatedByNewInc) then
-   computationMode  = 1   ! compute and age former results
-   outdatedByNewInc = .false.
- endif
- if (computationMode == 2 .and. outdatedFFN1) then
-   computationMode  = 4   ! return odd results to force new vyvle
- endif
-
- 
- theTime  = cptim                                   ! record current starting time
- theInc   = inc                                     ! record current increment number
- theCycle = ncycle                                  ! record current cycle count
- theLovl  = lovl                                    ! record current lovl
-
- call CPFEM_general(computationMode,ffn,ffn1,t(1),timinc,n(1),nn,s,mod(cycleCounter-4,4_pInt*ijaco)==0,d,ngens)
-
-
-!     Mandel: 11, 22, 33, SQRT(2)*12, SQRT(2)*23, SQRT(2)*13
-!     Marc:   11, 22, 33, 12, 23, 13
- forall(i=1:ngens) d(1:ngens,i) = invnrmMandel(i)*d(1:ngens,i)*invnrmMandel(1:ngens)
- s(1:ngens) = s(1:ngens)*invnrmMandel(1:ngens)
- if(symmetricSolver) d(1:ngens,1:ngens) = 0.5_pReal*(d(1:ngens,1:ngens)+transpose(d(1:ngens,1:ngens)))
- return
- 
- END SUBROUTINE
-!
-
- SUBROUTINE plotv(v,s,sp,etot,eplas,ecreep,t,m,nn,layer,ndi,nshear,jpltcd)
-!********************************************************************
-!     This routine sets user defined output variables for Marc
-!********************************************************************
-!
-!     select a variable contour plotting (user subroutine).
-!
-!     v            variable
-!     s (idss)         stress array
-!     sp           stresses in preferred direction
-!     etot          total strain (generalized)
-!     eplas         total plastic strain
-!     ecreep        total creep strain
-!     t             current temperature
-!     m            element number
-!     nn           integration point number
-!     layer        layer number
-!     ndi (3)       number of direct stress components
-!     nshear (3)    number of shear stress components
-!
-!********************************************************************
- use prec,  only: pReal,pInt
- use CPFEM, only: CPFEM_results, CPFEM_Nresults
- use constitutive, only: constitutive_maxNresults
- use mesh,  only: mesh_FEasCP
- implicit none
-!
- real(pReal) s(*),etot(*),eplas(*),ecreep(*),sp(*)
- real(pReal) v, t(*)
- integer(pInt) m, nn, layer, ndi, nshear, jpltcd
-!
-! assign result variable
- v=CPFEM_results(mod(jpltcd-1_pInt, CPFEM_Nresults+constitutive_maxNresults)+1_pInt,&
-                 (jpltcd-1_pInt)/(CPFEM_Nresults+constitutive_maxNresults)+1_pInt,&
-                 nn, mesh_FEasCP('elem', m))
- return
- END SUBROUTINE
-!
-!
-! subroutine utimestep(timestep,timestepold,icall,time,timeloadcase)
-!********************************************************************
-!     This routine modifies the addaptive time step of Marc
-!********************************************************************
-! use prec, only: pReal,pInt
-! use CPFEM, only : CPFEM_timefactor_max
-! implicit none
-!
-! real(pReal) timestep, timestepold, time,timeloadcase 
-! integer(pInt) icall
-!
-! user subroutine for modifying the time step in auto step
-!
-!   timestep    :  the current time step as suggested by marc
-!                  to be modified in this routine
-!   timestepold :  the current time step before it was modified by marc
-!   icall       :  =1 for setting the initial time step
-!                  =2 if this routine is called during an increment
-!                  =3 if this routine is called at the beginning
-!                     of the increment
-!   time        :  time at the start of the current increment
-!   timeloadcase:  time period of the current load case
-!
-!   it is in general not recommended to increase the time step
-!   during the increment.
-!   this routine is called right after the time step has (possibly)
-!   been updated by marc.
-!
-!  user coding
-!     reduce timestep during increment in case mpie_timefactor is too large
-! if(icall==2_pInt) then
-!    if(mpie_timefactor_max>1.25_pReal) then
-!        timestep=min(timestep,timestepold*0.8_pReal)
-!    end if
-! return
-!     modify timestep at beginning of new increment
-! else if(icall==3_pInt) then
-!    if(mpie_timefactor_max<=0.8_pReal) then
-!        timestep=min(timestep,timestepold*1.25_pReal)
-!    else if (mpie_timefactor_max<=1.0_pReal) then
-!        timestep=min(timestep,timestepold/mpie_timefactor_max)
-!    else if (mpie_timefactor_max<=1.25_pReal) then
-!        timestep=min(timestep,timestepold*1.01_pReal)
-!    else
-!        timestep=min(timestep,timestepold*0.8_pReal)
-!    end if
-! end if
-! return
+ integer(pInt) computationMode,i
+!
+ if (inc == 0) then
+   cycleCounter = 4
+ else
+   if (theCycle > ncycle .or. theInc /= inc) cycleCounter = 0                  ! reset counter for each cutback or new inc
+   if (theCycle /= ncycle .or. theLovl /= lovl) then
+     cycleCounter = cycleCounter+1   ! ping pong
+     outdatedFFN1 = .false.
+   endif
+ endif
+ if (cptim > theTime .or. theInc /= inc) then                                   ! reached convergence
+   lastIncConverged = .true.
+   outdatedByNewInc = .true.
+ endif
+
+ if (mod(cycleCounter,2) /= 0) computationMode = 4   ! recycle
+ if (mod(cycleCounter,4) == 2) computationMode = 3   ! collect
+ if (mod(cycleCounter,4) == 0) computationMode = 2   ! compute
+ if (computationMode == 4 .and. ncycle == 0 .and. .not. lastIncConverged) &
+   computationMode = 6    ! recycle but restore known good consistent tangent
+ if (computationMode == 4 .and. lastIncConverged) then
+   computationMode  = 5   ! recycle and record former consistent tangent
+   lastIncConverged = .false.
+ endif
+ if (computationMode == 2 .and. outdatedByNewInc) then
+   computationMode  = 1   ! compute and age former results
+   outdatedByNewInc = .false.
+ endif
+ if (computationMode == 2 .and. outdatedFFN1) then
+   computationMode  = 4   ! return odd results to force new vyvle
+ endif
+
+ theTime  = cptim                                   ! record current starting time
+ theInc   = inc                                     ! record current increment number
+ theCycle = ncycle                                  ! record current cycle count
+ theLovl  = lovl                                    ! record current lovl
+
+ call CPFEM_general(computationMode,ffn,ffn1,t(1),timinc,n(1),nn,s,mod(cycleCounter-4,4_pInt*ijaco)==0,d,ngens)
+
+!     Mandel: 11, 22, 33, SQRT(2)*12, SQRT(2)*23, SQRT(2)*13
+!     Marc:   11, 22, 33, 12, 23, 13
+ forall(i=1:ngens) d(1:ngens,i) = invnrmMandel(i)*d(1:ngens,i)*invnrmMandel(1:ngens)
+ s(1:ngens) = s(1:ngens)*invnrmMandel(1:ngens)
+ if(symmetricSolver) d(1:ngens,1:ngens) = 0.5_pReal*(d(1:ngens,1:ngens)+transpose(d(1:ngens,1:ngens)))
+ return
+ 
+ END SUBROUTINE
+!
+
+ SUBROUTINE plotv(v,s,sp,etot,eplas,ecreep,t,m,nn,layer,ndi,nshear,jpltcd)
+!********************************************************************
+!     This routine sets user defined output variables for Marc
+!********************************************************************
+!
+!     select a variable contour plotting (user subroutine).
+!
+!     v            variable
+!     s (idss)         stress array
+!     sp           stresses in preferred direction
+!     etot          total strain (generalized)
+!     eplas         total plastic strain
+!     ecreep        total creep strain
+!     t             current temperature
+!     m            element number
+!     nn           integration point number
+!     layer        layer number
+!     ndi (3)       number of direct stress components
+!     nshear (3)    number of shear stress components
+!
+!********************************************************************
+ use prec,  only: pReal,pInt
+ use CPFEM, only: CPFEM_results, CPFEM_Nresults
+ use constitutive, only: constitutive_maxNresults
+ use mesh,  only: mesh_FEasCP
+ implicit none
+!
+ real(pReal) s(*),etot(*),eplas(*),ecreep(*),sp(*)
+ real(pReal) v, t(*)
+ integer(pInt) m, nn, layer, ndi, nshear, jpltcd
+!
+! assign result variable
+ v=CPFEM_results(mod(jpltcd-1_pInt, CPFEM_Nresults+constitutive_maxNresults)+1_pInt,&
+                 (jpltcd-1_pInt)/(CPFEM_Nresults+constitutive_maxNresults)+1_pInt,&
+                 nn, mesh_FEasCP('elem', m))
+ return
+ END SUBROUTINE
+!
+!
+! subroutine utimestep(timestep,timestepold,icall,time,timeloadcase)
+!********************************************************************
+!     This routine modifies the addaptive time step of Marc
+!********************************************************************
+! use prec, only: pReal,pInt
+! use CPFEM, only : CPFEM_timefactor_max
+! implicit none
+!
+! real(pReal) timestep, timestepold, time,timeloadcase 
+! integer(pInt) icall
+!
+! user subroutine for modifying the time step in auto step
+!
+!   timestep    :  the current time step as suggested by marc
+!                  to be modified in this routine
+!   timestepold :  the current time step before it was modified by marc
+!   icall       :  =1 for setting the initial time step
+!                  =2 if this routine is called during an increment
+!                  =3 if this routine is called at the beginning
+!                     of the increment
+!   time        :  time at the start of the current increment
+!   timeloadcase:  time period of the current load case
+!
+!   it is in general not recommended to increase the time step
+!   during the increment.
+!   this routine is called right after the time step has (possibly)
+!   been updated by marc.
+!
+!  user coding
+!     reduce timestep during increment in case mpie_timefactor is too large
+! if(icall==2_pInt) then
+!    if(mpie_timefactor_max>1.25_pReal) then
+!        timestep=min(timestep,timestepold*0.8_pReal)
+!    end if
+! return
+!     modify timestep at beginning of new increment
+! else if(icall==3_pInt) then
+!    if(mpie_timefactor_max<=0.8_pReal) then
+!        timestep=min(timestep,timestepold*1.25_pReal)
+!    else if (mpie_timefactor_max<=1.0_pReal) then
+!        timestep=min(timestep,timestepold/mpie_timefactor_max)
+!    else if (mpie_timefactor_max<=1.25_pReal) then
+!        timestep=min(timestep,timestepold*1.01_pReal)
+!    else
+!        timestep=min(timestep,timestepold*0.8_pReal)
+!    end if
+! end if
+! return
 ! end
\ No newline at end of file
diff --git a/trunk/mpie_cpfem_marc2008r1_sequential.f90 b/trunk/mpie_cpfem_marc2008r1_sequential.f90
index 0f9e165ee..f8f5279cd 100644
--- a/trunk/mpie_cpfem_marc2008r1_sequential.f90
+++ b/trunk/mpie_cpfem_marc2008r1_sequential.f90
@@ -16,7 +16,8 @@
 !             - use nonsymmetric option for solver (e.g. direct 
 !               profile or multifrontal sparse, the latter seems
 !               to be faster!)
-!             - in case of ddm a symmetric solver has to be used
+!             - in case of ddm a symmetric solver has to be used
+
 !********************************************************************
 !     Marc subroutines used:
 !             - hypela2
@@ -28,15 +29,15 @@
 !             - creeps: timinc
 !********************************************************************
 !
- include "prec.f90"             ! uses nothing else
- include "debug.f90"            ! uses prec
- include "math.f90"             ! uses prec
- include "IO.f90"               ! uses prec, debug, math
- include "FEsolving.f90"        ! uses prec, IO
- include "mesh.f90"             ! uses prec, IO, math, FEsolving
- include "lattice.f90"          ! uses prec, math
- include "constitutive.f90"     ! uses prec, IO, math, lattice, mesh, debug
-! include "crystallite.f90"      ! uses prec, debug, constitutive, mesh, math, IO
+ include "prec.f90"             ! uses nothing else
+ include "debug.f90"            ! uses prec
+ include "math.f90"             ! uses prec
+ include "IO.f90"               ! uses prec, debug, math
+ include "FEsolving.f90"        ! uses prec, IO
+ include "mesh.f90"             ! uses prec, IO, math, FEsolving
+ include "lattice.f90"          ! uses prec, math
+ include "constitutive.f90"     ! uses prec, IO, math, lattice, mesh, debug
+! include "crystallite.f90"      ! uses prec, debug, constitutive, mesh, math, IO
  include "CPFEM_sequential.f90" ! uses prec, math, mesh, constitutive, FEsolving, debug, lattice, IO, crystallite
 !
 
@@ -124,35 +125,34 @@
 !2     continue
 !3    continue
 !
-
- use prec, only: pReal,pInt, ijaco
- use FEsolving
- use CPFEM, only: CPFEM_general
- use math, only: invnrmMandel
-!
- implicit none
-!
-!     ** Start of generated type statements **
- real(pReal) coord, d, de, disp, dispt, dt, e, eigvn, eigvn1, ffn, ffn1
- real(pReal) frotn, frotn1, g
- integer(pInt) ifr, ifu, itel, jtype, kcus, lclass, matus, n, ncrd, ndeg
- integer(pInt) ndi, ndm, ngens, nn, nnode, nshear
- real(pReal) s, strechn, strechn1, t
-!     ** End of generated type statements **
-!
- dimension e(*),de(*),t(*),dt(*),g(*),d(ngens,*),s(*), n(2),coord(ncrd,*),disp(ndeg,*),matus(2),dispt(ndeg,*),ffn(itel,*),&
-           frotn(itel,*),strechn(itel),eigvn(itel,*),ffn1(itel,*),frotn1(itel,*),strechn1(itel),eigvn1(itel,*),kcus(2),&
-           lclass(2)
-!
-! Marc common blocks are in fixed format so they have to be reformated to free format (f90)
-! Beware of changes in newer Marc versions -- these are from 2005r3
-! concom is needed for inc, subinc, ncycle, lovl
- include "concom_f90"
-! creeps is needed for timinc (time increment)
- include "creeps_f90"
-!
- integer(pInt) computationMode,i
-!
+ use prec, only: pReal,pInt, ijaco
+ use FEsolving
+ use CPFEM, only: CPFEM_general
+ use math, only: invnrmMandel
+!
+ implicit none
+!
+!     ** Start of generated type statements **
+ real(pReal) coord, d, de, disp, dispt, dt, e, eigvn, eigvn1, ffn, ffn1
+ real(pReal) frotn, frotn1, g
+ integer(pInt) ifr, ifu, itel, jtype, kcus, lclass, matus, n, ncrd, ndeg
+ integer(pInt) ndi, ndm, ngens, nn, nnode, nshear
+ real(pReal) s, strechn, strechn1, t
+!     ** End of generated type statements **
+!
+ dimension e(*),de(*),t(*),dt(*),g(*),d(ngens,*),s(*), n(2),coord(ncrd,*),disp(ndeg,*),matus(2),dispt(ndeg,*),ffn(itel,*),&
+           frotn(itel,*),strechn(itel),eigvn(itel,*),ffn1(itel,*),frotn1(itel,*),strechn1(itel),eigvn1(itel,*),kcus(2),&
+           lclass(2)
+!
+! Marc common blocks are in fixed format so they have to be reformated to free format (f90)
+! Beware of changes in newer Marc versions -- these are from 2005r3
+! concom is needed for inc, subinc, ncycle, lovl
+ include "concom_f90"
+! creeps is needed for timinc (time increment)
+ include "creeps_f90"
+!
+ integer(pInt) computationMode,i
+!
  if (inc == 0) then
    cycleCounter = 4
  else
@@ -186,7 +186,6 @@
 
  call CPFEM_general(computationMode,ffn,ffn1,t(1),timinc,n(1),nn,s,mod(cycleCounter-4,2_pInt*ijaco)==0,d,ngens)
 
-
 !     Mandel: 11, 22, 33, SQRT(2)*12, SQRT(2)*23, SQRT(2)*13
 !     Marc:   11, 22, 33, 12, 23, 13
  forall(i=1:ngens) d(1:ngens,i) = invnrmMandel(i)*d(1:ngens,i)*invnrmMandel(1:ngens)