2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
2018-08-28 16:45:38 +05:30
!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH
2013-02-21 03:36:15 +05:30
!> @author Denny Tjahjanto, Max-Planck-Institut für Eisenforschung GmbH
!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH
!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH
!> @brief Relaxed grain cluster (RGC) homogenization scheme
2018-08-28 16:45:38 +05:30
!> Nconstituents is defined as p x q x r (cluster)
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
module homogenization_RGC
use prec , only : &
pReal , &
pInt
2009-10-12 21:31:49 +05:30
2012-03-09 01:55:28 +05:30
implicit none
2013-02-21 03:36:15 +05:30
private
2013-12-18 12:58:01 +05:30
integer ( pInt ) , dimension ( : , : ) , allocatable , target , public :: &
2013-02-21 03:36:15 +05:30
homogenization_RGC_sizePostResult
2013-12-18 12:58:01 +05:30
character ( len = 64 ) , dimension ( : , : ) , allocatable , target , public :: &
2013-02-21 03:36:15 +05:30
homogenization_RGC_output ! name of each post result output
2018-08-28 16:27:22 +05:30
2018-08-31 04:54:28 +05:30
enum , bind ( c )
2019-01-13 02:34:03 +05:30
enumerator :: &
undefined_ID , &
constitutivework_ID , &
penaltyenergy_ID , &
volumediscrepancy_ID , &
averagerelaxrate_ID , &
maximumrelaxrate_ID , &
magnitudemismatch_ID
2018-08-31 04:54:28 +05:30
end enum
2019-01-13 02:34:03 +05:30
type , private :: tParameters
2018-08-28 16:27:22 +05:30
integer ( pInt ) , dimension ( : ) , allocatable :: &
Nconstituents
real ( pReal ) :: &
xiAlpha , &
ciAlpha
real ( pReal ) , dimension ( : ) , allocatable :: &
dAlpha , &
angles
2019-01-13 02:34:03 +05:30
integer ( pInt ) :: &
2019-01-13 03:37:35 +05:30
of_debug = 0_pInt
2018-08-31 04:54:28 +05:30
integer ( kind ( undefined_ID ) ) , dimension ( : ) , allocatable :: &
2019-01-13 02:34:03 +05:30
outputID
2018-08-28 16:27:22 +05:30
end type
2018-11-04 02:06:49 +05:30
type , private :: tRGCstate
2018-11-03 21:20:43 +05:30
real ( pReal ) , pointer , dimension ( : ) :: &
2018-10-13 21:51:13 +05:30
work , &
2019-01-13 03:52:13 +05:30
penaltyEnergy
2018-11-03 21:20:43 +05:30
real ( pReal ) , pointer , dimension ( : , : ) :: &
2019-01-13 03:52:13 +05:30
relaxationVector
2018-11-04 02:06:49 +05:30
end type tRGCstate
type , private :: tRGCdependentState
2019-01-13 03:52:13 +05:30
real ( pReal ) , allocatable , dimension ( : ) :: &
volumeDiscrepancy , &
relaxationRate_avg , &
relaxationRate_max
real ( pReal ) , allocatable , dimension ( : , : ) :: &
mismatch
2018-11-04 02:06:49 +05:30
real ( pReal ) , allocatable , dimension ( : , : , : ) :: &
orientation
end type tRGCdependentState
2019-01-13 03:52:13 +05:30
type ( tparameters ) , dimension ( : ) , allocatable , private :: &
param
type ( tRGCstate ) , dimension ( : ) , allocatable , private :: &
2019-01-13 13:44:23 +05:30
state , &
state0
2019-01-13 03:52:13 +05:30
type ( tRGCdependentState ) , dimension ( : ) , allocatable , private :: &
dependentState
2018-11-04 02:06:49 +05:30
2013-02-21 03:36:15 +05:30
public :: &
homogenization_RGC_init , &
homogenization_RGC_partitionDeformation , &
homogenization_RGC_averageStressAndItsTangent , &
homogenization_RGC_updateState , &
homogenization_RGC_postResults
private :: &
2018-08-30 14:20:52 +05:30
relaxationVector , &
interfaceNormal , &
getInterface , &
grain1to3 , &
grain3to1 , &
interface4to1 , &
interface1to4
2013-02-21 03:36:15 +05:30
contains
!--------------------------------------------------------------------------------------------------
2018-04-17 18:12:04 +05:30
!> @brief allocates all necessary fields, reads information from material configuration file
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
2018-11-03 21:20:43 +05:30
subroutine homogenization_RGC_init ( )
2018-02-02 17:06:09 +05:30
#if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800
2017-10-05 20:05:34 +05:30
use , intrinsic :: iso_fortran_env , only : &
compiler_version , &
compiler_options
#endif
2014-08-21 23:18:20 +05:30
use prec , only : &
pReal , &
pInt
2013-02-21 03:36:15 +05:30
use debug , only : &
2019-01-13 13:44:23 +05:30
#ifdef DEBUG
debug_i , &
debug_e , &
#endif
debug_level , &
debug_homogenization , &
debug_levelBasic
2013-02-21 03:36:15 +05:30
use math , only : &
math_EulerToR , &
INRAD
2019-01-13 02:34:03 +05:30
use IO , only : &
IO_error , &
IO_timeStamp
2019-01-13 13:44:23 +05:30
use material , only : &
homogenization_type , &
material_homog , &
homogState , &
HOMOGENIZATION_RGC_ID , &
HOMOGENIZATION_RGC_LABEL , &
homogenization_typeInstance , &
homogenization_Noutput , &
homogenization_Ngrains
2019-01-13 02:34:03 +05:30
use config , only : &
config_homogenization
2012-03-09 01:55:28 +05:30
implicit none
2018-11-03 21:20:43 +05:30
integer ( pInt ) :: &
2019-01-13 02:34:03 +05:30
Ninstance , &
2019-01-13 13:44:23 +05:30
h , i , &
2019-01-13 02:34:03 +05:30
NofMyHomog , outputSize , &
sizeState , nIntFaceTot
2018-08-31 04:54:28 +05:30
character ( len = 65536 ) , dimension ( 0 ) , parameter :: emptyStringArray = [ character ( len = 65536 ) :: ]
2019-01-13 02:34:03 +05:30
integer ( kind ( undefined_ID ) ) :: &
outputID
character ( len = 65536 ) , dimension ( : ) , allocatable :: &
outputs
2013-01-09 03:41:59 +05:30
2017-11-21 19:38:45 +05:30
write ( 6 , '(/,a)' ) ' <<<+- homogenization_' / / HOMOGENIZATION_RGC_label / / ' init -+>>>'
2018-04-22 13:37:49 +05:30
write ( 6 , '(/,a)' ) ' Tjahjanto et al., International Journal of Material Forming, 2(1):939– 942, 2009'
2018-08-31 04:54:28 +05:30
write ( 6 , '(a)' ) ' https://doi.org/10.1007/s12289-009-0619-1'
2018-04-22 13:37:49 +05:30
write ( 6 , '(/,a)' ) ' Tjahjanto et al., Modelling and Simulation in Materials Science and Engineering, 18:015006, 2010'
2018-08-31 04:54:28 +05:30
write ( 6 , '(a)' ) ' https://doi.org/10.1088/0965-0393/18/1/015006'
2017-11-21 19:38:45 +05:30
write ( 6 , '(a15,a)' ) ' Current time: ' , IO_timeStamp ( )
2012-02-01 00:48:55 +05:30
#include "compilation_info.f90"
2009-10-12 21:31:49 +05:30
2019-01-13 02:34:03 +05:30
Ninstance = int ( count ( homogenization_type == HOMOGENIZATION_RGC_ID ) , pInt )
2018-08-28 16:27:22 +05:30
if ( iand ( debug_level ( debug_HOMOGENIZATION ) , debug_levelBasic ) / = 0_pInt ) &
2019-01-13 02:34:03 +05:30
write ( 6 , '(a16,1x,i5,/)' ) '# instances:' , Ninstance
2018-08-29 13:22:22 +05:30
2019-01-13 02:34:03 +05:30
allocate ( param ( Ninstance ) )
allocate ( state ( Ninstance ) )
2019-01-13 13:44:23 +05:30
allocate ( state0 ( Ninstance ) )
2019-01-13 02:34:03 +05:30
allocate ( dependentState ( Ninstance ) )
allocate ( homogenization_RGC_sizePostResult ( maxval ( homogenization_Noutput ) , Ninstance ) , source = 0_pInt )
allocate ( homogenization_RGC_output ( maxval ( homogenization_Noutput ) , Ninstance ) )
homogenization_RGC_output = ''
2018-08-29 13:22:22 +05:30
2018-08-28 16:45:38 +05:30
do h = 1_pInt , size ( homogenization_type )
if ( homogenization_type ( h ) / = HOMOGENIZATION_RGC_ID ) cycle
2019-01-13 02:34:03 +05:30
associate ( prm = > param ( homogenization_typeInstance ( h ) ) , &
stt = > state ( homogenization_typeInstance ( h ) ) , &
2019-01-13 13:44:23 +05:30
st0 = > state0 ( homogenization_typeInstance ( h ) ) , &
2019-01-13 02:34:03 +05:30
dst = > dependentState ( homogenization_typeInstance ( h ) ) , &
config = > config_homogenization ( h ) )
#ifdef DEBUG
2019-01-13 13:44:23 +05:30
!if (h==material_homogenizationAt(debug_e)) then
! prm%of_debug = mappingHomogenization(1,debug_i,debug_e)
!endif
2019-01-13 02:34:03 +05:30
#endif
2018-08-31 04:54:28 +05:30
2019-01-13 02:34:03 +05:30
prm % Nconstituents = config % getInts ( 'clustersize' , requiredShape = [ 3 ] )
2018-08-29 13:22:22 +05:30
if ( homogenization_Ngrains ( h ) / = product ( prm % Nconstituents ) ) &
2018-08-31 04:54:28 +05:30
call IO_error ( 211_pInt , ext_msg = 'clustersize (' / / HOMOGENIZATION_RGC_label / / ')' )
2019-01-13 02:34:03 +05:30
prm % xiAlpha = config % getFloat ( 'scalingparameter' )
prm % ciAlpha = config % getFloat ( 'overproportionality' )
prm % dAlpha = config % getFloats ( 'grainsize' , requiredShape = [ 3 ] )
prm % angles = config % getFloats ( 'clusterorientation' , requiredShape = [ 3 ] )
2018-08-29 17:06:46 +05:30
2019-01-13 02:34:03 +05:30
outputs = config % getStrings ( '(output)' , defaultVal = emptyStringArray )
2018-08-31 04:54:28 +05:30
allocate ( prm % outputID ( 0 ) )
do i = 1_pInt , size ( outputs )
outputID = undefined_ID
select case ( outputs ( i ) )
2019-01-13 02:34:03 +05:30
2018-08-31 04:54:28 +05:30
case ( 'constitutivework' )
outputID = constitutivework_ID
outputSize = 1_pInt
case ( 'penaltyenergy' )
outputID = penaltyenergy_ID
outputSize = 1_pInt
case ( 'volumediscrepancy' )
outputID = volumediscrepancy_ID
outputSize = 1_pInt
case ( 'averagerelaxrate' )
outputID = averagerelaxrate_ID
outputSize = 1_pInt
case ( 'maximumrelaxrate' )
outputID = maximumrelaxrate_ID
outputSize = 1_pInt
case ( 'magnitudemismatch' )
outputID = magnitudemismatch_ID
outputSize = 3_pInt
2019-01-13 02:34:03 +05:30
2018-08-31 04:54:28 +05:30
end select
2019-01-13 02:34:03 +05:30
2018-11-03 19:43:11 +05:30
if ( outputID / = undefined_ID ) then
2019-01-13 02:34:03 +05:30
homogenization_RGC_output ( i , homogenization_typeInstance ( h ) ) = outputs ( i )
homogenization_RGC_sizePostResult ( i , homogenization_typeInstance ( h ) ) = outputSize
2018-11-03 19:43:11 +05:30
prm % outputID = [ prm % outputID , outputID ]
endif
2019-01-13 02:34:03 +05:30
2018-08-31 04:54:28 +05:30
enddo
2018-08-29 17:06:46 +05:30
2018-08-31 10:05:30 +05:30
NofMyHomog = count ( material_homog == h )
2018-11-03 21:20:43 +05:30
nIntFaceTot = 3_pInt * ( ( prm % Nconstituents ( 1 ) - 1_pInt ) * prm % Nconstituents ( 2 ) * prm % Nconstituents ( 3 ) &
+ prm % Nconstituents ( 1 ) * ( prm % Nconstituents ( 2 ) - 1_pInt ) * prm % Nconstituents ( 3 ) &
+ prm % Nconstituents ( 1 ) * prm % Nconstituents ( 2 ) * ( prm % Nconstituents ( 3 ) - 1_pInt ) )
2019-01-13 02:34:03 +05:30
sizeState = nIntFaceTot &
2019-01-13 03:52:13 +05:30
+ size ( [ 'avg constitutive work ' , 'average penalty energy' ] )
2019-01-13 02:34:03 +05:30
homogState ( h ) % sizeState = sizeState
homogState ( h ) % sizePostResults = sum ( homogenization_RGC_sizePostResult ( : , homogenization_typeInstance ( h ) ) )
allocate ( homogState ( h ) % state0 ( sizeState , NofMyHomog ) , source = 0.0_pReal )
allocate ( homogState ( h ) % subState0 ( sizeState , NofMyHomog ) , source = 0.0_pReal )
allocate ( homogState ( h ) % state ( sizeState , NofMyHomog ) , source = 0.0_pReal )
stt % relaxationVector = > homogState ( h ) % state ( 1 : nIntFaceTot , : )
2019-01-13 13:44:23 +05:30
st0 % relaxationVector = > homogState ( h ) % state0 ( 1 : nIntFaceTot , : )
2019-01-13 02:34:03 +05:30
stt % work = > homogState ( h ) % state ( nIntFaceTot + 1 , : )
2019-01-13 03:52:13 +05:30
stt % penaltyEnergy = > homogState ( h ) % state ( nIntFaceTot + 2 , : )
2019-01-13 02:34:03 +05:30
2019-01-13 03:52:13 +05:30
allocate ( dst % volumeDiscrepancy ( NofMyHomog ) )
allocate ( dst % relaxationRate_avg ( NofMyHomog ) )
allocate ( dst % relaxationRate_max ( NofMyHomog ) )
allocate ( dst % mismatch ( 3 , NofMyHomog ) )
allocate ( dst % orientation ( 3 , 3 , NofMyHomog ) )
2018-11-04 02:06:49 +05:30
!--------------------------------------------------------------------------------------------------
2019-01-13 02:34:03 +05:30
! assigning cluster orientations
2019-01-13 13:44:23 +05:30
dst % orientation = spread ( math_EulerToR ( prm % angles * inRad ) , 3 , NofMyHomog )
2019-01-13 02:34:03 +05:30
2018-08-28 16:45:38 +05:30
end associate
2019-01-13 02:34:03 +05:30
2018-08-28 16:45:38 +05:30
enddo
2014-09-10 19:44:03 +05:30
2013-02-21 03:36:15 +05:30
end subroutine homogenization_RGC_init
2009-10-12 21:31:49 +05:30
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
!> @brief partitions the deformation gradient onto the constituents
!--------------------------------------------------------------------------------------------------
2018-11-04 03:53:52 +05:30
subroutine homogenization_RGC_partitionDeformation ( F , avgF , instance , of )
2019-01-13 02:34:03 +05:30
#ifdef DEBUG
2013-02-21 03:36:15 +05:30
use debug , only : &
debug_level , &
debug_homogenization , &
debug_levelExtensive
2019-01-13 02:34:03 +05:30
#endif
2009-10-12 21:31:49 +05:30
implicit none
2019-01-13 13:44:23 +05:30
real ( pReal ) , dimension ( : , : , : ) , intent ( out ) :: F !< partioned F per grain
2019-01-13 02:34:03 +05:30
2019-01-13 13:44:23 +05:30
real ( pReal ) , dimension ( : , : ) , intent ( in ) :: avgF !< averaged F
integer ( pInt ) , intent ( in ) :: &
2018-11-04 03:53:52 +05:30
instance , &
2019-01-13 02:34:03 +05:30
of
2013-02-21 03:36:15 +05:30
real ( pReal ) , dimension ( 3 ) :: aVect , nVect
2009-10-12 21:31:49 +05:30
integer ( pInt ) , dimension ( 4 ) :: intFace
integer ( pInt ) , dimension ( 3 ) :: iGrain3
2018-11-04 03:53:52 +05:30
integer ( pInt ) :: iGrain , iFace , i , j
2009-10-12 21:31:49 +05:30
2018-11-04 03:43:20 +05:30
associate ( prm = > param ( instance ) )
2019-01-13 02:34:03 +05:30
2019-01-13 13:44:23 +05:30
!--------------------------------------------------------------------------------------------------
! compute the deformation gradient of individual grains due to relaxations
2009-10-12 21:31:49 +05:30
F = 0.0_pReal
2018-11-04 03:53:52 +05:30
do iGrain = 1_pInt , product ( prm % Nconstituents )
2018-11-04 12:41:35 +05:30
iGrain3 = grain1to3 ( iGrain , prm % Nconstituents )
2018-11-04 02:06:49 +05:30
do iFace = 1_pInt , 6_pInt
2018-11-04 03:43:20 +05:30
intFace = getInterface ( iFace , iGrain3 ) ! identifying 6 interfaces of each grain
aVect = relaxationVector ( intFace , instance , of ) ! get the relaxation vectors for each interface from global relaxation vector array
nVect = interfaceNormal ( intFace , instance , of )
2012-02-13 19:48:07 +05:30
forall ( i = 1_pInt : 3_pInt , j = 1_pInt : 3_pInt ) &
2018-10-13 21:51:13 +05:30
F ( i , j , iGrain ) = F ( i , j , iGrain ) + aVect ( i ) * nVect ( j ) ! calculating deformation relaxations due to interface relaxation
2009-10-12 21:31:49 +05:30
enddo
2013-02-21 03:36:15 +05:30
F ( 1 : 3 , 1 : 3 , iGrain ) = F ( 1 : 3 , 1 : 3 , iGrain ) + avgF ! resulting relaxed deformation gradient
2010-11-26 17:20:20 +05:30
2019-01-13 02:34:03 +05:30
#ifdef DEBUG
2012-07-05 15:24:50 +05:30
if ( iand ( debug_level ( debug_homogenization ) , debug_levelExtensive ) / = 0_pInt ) then
2012-02-01 00:48:55 +05:30
write ( 6 , '(1x,a32,1x,i3)' ) 'Deformation gradient of grain: ' , iGrain
2012-02-13 19:48:07 +05:30
do i = 1_pInt , 3_pInt
2012-02-16 00:28:38 +05:30
write ( 6 , '(1x,3(e15.8,1x))' ) ( F ( i , j , iGrain ) , j = 1_pInt , 3_pInt )
2009-10-12 21:31:49 +05:30
enddo
write ( 6 , * ) ' '
2012-11-06 21:20:20 +05:30
flush ( 6 )
2009-10-12 21:31:49 +05:30
endif
2019-01-13 02:34:03 +05:30
#endif
2009-10-12 21:31:49 +05:30
enddo
2019-01-13 02:34:03 +05:30
2018-11-04 03:43:20 +05:30
end associate
2009-10-12 21:31:49 +05:30
2013-02-21 03:36:15 +05:30
end subroutine homogenization_RGC_partitionDeformation
!--------------------------------------------------------------------------------------------------
!> @brief update the internal state of the homogenization scheme and tell whether "done" and
! "happy" with result
!--------------------------------------------------------------------------------------------------
2014-09-19 23:29:06 +05:30
function homogenization_RGC_updateState ( P , F , F0 , avgF , dt , dPdF , ip , el )
2016-05-29 14:15:03 +05:30
use prec , only : &
2016-10-29 13:09:08 +05:30
dEq0
2019-01-13 03:37:35 +05:30
#ifdef DEBUG
2013-02-21 03:36:15 +05:30
use debug , only : &
debug_level , &
debug_homogenization , &
debug_levelExtensive , &
debug_e , &
debug_i
2019-01-13 03:37:35 +05:30
#endif
2013-02-21 03:36:15 +05:30
use math , only : &
2019-01-13 13:44:23 +05:30
math_invert2
2013-02-21 03:36:15 +05:30
use material , only : &
2018-11-04 13:30:35 +05:30
material_homogenizationAt , &
2013-02-21 03:36:15 +05:30
homogenization_typeInstance , &
2019-01-13 14:03:47 +05:30
mappingHomogenization
2013-02-21 03:36:15 +05:30
use numerics , only : &
absTol_RGC , &
relTol_RGC , &
absMax_RGC , &
relMax_RGC , &
pPert_RGC , &
maxdRelax_RGC , &
viscPower_RGC , &
viscModus_RGC , &
refRelaxRate_RGC
2009-10-12 21:31:49 +05:30
implicit none
2014-09-19 23:29:06 +05:30
2019-01-13 14:03:47 +05:30
real ( pReal ) , dimension ( : , : , : ) , intent ( in ) :: &
2013-02-21 03:36:15 +05:30
P , & !< array of P
F , & !< array of F
F0 !< array of initial F
2019-01-13 14:03:47 +05:30
real ( pReal ) , dimension ( : , : , : , : , : ) , intent ( in ) :: dPdF !< array of current grain stiffness
real ( pReal ) , dimension ( 3 , 3 ) , intent ( in ) :: avgF !< average F
real ( pReal ) , intent ( in ) :: dt !< time increment
integer ( pInt ) , intent ( in ) :: &
2013-02-21 03:36:15 +05:30
ip , & !< integration point number
el !< element number
2018-11-03 21:20:43 +05:30
2009-10-12 21:31:49 +05:30
logical , dimension ( 2 ) :: homogenization_RGC_updateState
2019-01-13 14:03:47 +05:30
2009-10-12 21:31:49 +05:30
integer ( pInt ) , dimension ( 4 ) :: intFaceN , intFaceP , faceID
integer ( pInt ) , dimension ( 3 ) :: nGDim , iGr3N , iGr3P , stresLoc
2019-01-13 14:03:47 +05:30
integer ( pInt ) :: instance , iNum , i , j , nIntFaceTot , iGrN , iGrP , iMun , iFace , k , l , ipert , iGrain , nGrain , of
real ( pReal ) , dimension ( 3 , 3 , size ( P , 3 ) ) :: R , pF , pR , D , pD
real ( pReal ) , dimension ( 3 , size ( P , 3 ) ) :: NN , devNull
real ( pReal ) , dimension ( 3 ) :: normP , normN , mornP , mornN
real ( pReal ) :: residMax , stresMax
logical :: error
2009-11-17 19:12:38 +05:30
real ( pReal ) , dimension ( : , : ) , allocatable :: tract , jmatrix , jnverse , smatrix , pmatrix , rmatrix
2009-10-12 21:31:49 +05:30
real ( pReal ) , dimension ( : ) , allocatable :: resid , relax , p_relax , p_resid , drelax
2019-01-13 14:03:47 +05:30
#ifdef DEBUG
integer ( pInt ) , dimension ( 3 ) :: stresLoc
integer ( pInt ) , dimension ( 2 ) :: residLoc
#endif
2013-02-13 15:06:06 +05:30
2016-10-29 13:09:08 +05:30
zeroTimeStep : if ( dEq0 ( dt ) ) then
2016-05-29 14:15:03 +05:30
homogenization_RGC_updateState = . true . ! pretend everything is fine and return
2013-02-21 03:36:15 +05:30
return
2016-05-29 14:15:03 +05:30
endif zeroTimeStep
2009-10-12 21:31:49 +05:30
2018-11-04 13:30:35 +05:30
instance = homogenization_typeInstance ( material_homogenizationAt ( el ) )
2018-11-04 00:30:02 +05:30
of = mappingHomogenization ( 1 , ip , el )
2019-01-13 03:37:35 +05:30
2019-01-13 13:44:23 +05:30
associate ( stt = > state ( instance ) , st0 = > state0 ( instance ) , dst = > dependentState ( instance ) , prm = > param ( instance ) )
2019-01-13 03:37:35 +05:30
!--------------------------------------------------------------------------------------------------
! get the dimension of the cluster (grains and interfaces)
nGDim = prm % Nconstituents
nGrain = product ( nGDim )
2018-11-04 13:19:40 +05:30
nIntFaceTot = ( nGDim ( 1 ) - 1_pInt ) * nGDim ( 2 ) * nGDim ( 3 ) &
+ nGDim ( 1 ) * ( nGDim ( 2 ) - 1_pInt ) * nGDim ( 3 ) &
+ nGDim ( 1 ) * nGDim ( 2 ) * ( nGDim ( 3 ) - 1_pInt )
2009-10-12 21:31:49 +05:30
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
! allocate the size of the global relaxation arrays/jacobian matrices depending on the size of the cluster
2013-12-18 12:58:01 +05:30
allocate ( resid ( 3_pInt * nIntFaceTot ) , source = 0.0_pReal )
allocate ( tract ( nIntFaceTot , 3 ) , source = 0.0_pReal )
2019-01-13 03:37:35 +05:30
relax = stt % relaxationVector ( : , of )
2019-01-13 13:44:23 +05:30
drelax = stt % relaxationVector ( : , of ) - st0 % relaxationVector ( : , of )
2019-01-13 02:34:03 +05:30
#ifdef DEBUG
2012-07-05 15:24:50 +05:30
if ( iand ( debug_level ( debug_homogenization ) , debug_levelExtensive ) / = 0_pInt ) then
2012-02-01 00:48:55 +05:30
write ( 6 , '(1x,a30)' ) 'Obtained state: '
2019-01-13 03:37:35 +05:30
do i = 1_pInt , size ( stt % relaxationVector ( : , of ) )
write ( 6 , '(1x,2(e15.8,1x))' ) stt % relaxationVector ( i , of )
2009-10-12 21:31:49 +05:30
enddo
write ( 6 , * ) ' '
endif
2019-01-13 02:34:03 +05:30
#endif
2009-10-12 21:31:49 +05:30
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
! computing interface mismatch and stress penalty tensor for all interfaces of all grains
2019-01-13 03:37:35 +05:30
call stressPenalty ( R , NN , avgF , F , ip , el , instance , of )
2009-12-16 21:50:53 +05:30
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
! calculating volume discrepancy and stress penalty related to overall volume discrepancy
2019-01-13 03:52:13 +05:30
call volumePenalty ( D , dst % volumeDiscrepancy ( of ) , avgF , F , nGrain , instance , of )
2009-12-16 21:50:53 +05:30
2019-01-13 02:34:03 +05:30
#ifdef DEBUG
2012-07-05 15:24:50 +05:30
if ( iand ( debug_level ( debug_homogenization ) , debug_levelExtensive ) / = 0_pInt ) then
2012-02-21 22:01:37 +05:30
do iGrain = 1_pInt , nGrain
2013-02-21 03:36:15 +05:30
write ( 6 , '(1x,a30,1x,i3,1x,a4,3(1x,e15.8))' ) 'Mismatch magnitude of grain(' , iGrain , ') :' , &
NN ( 1 , iGrain ) , NN ( 2 , iGrain ) , NN ( 3 , iGrain )
write ( 6 , '(/,1x,a30,1x,i3)' ) 'Stress and penalties of grain: ' , iGrain
2012-02-21 22:01:37 +05:30
do i = 1_pInt , 3_pInt
write ( 6 , '(1x,3(e15.8,1x),1x,3(e15.8,1x),1x,3(e15.8,1x))' ) ( P ( i , j , iGrain ) , j = 1_pInt , 3_pInt ) , &
2018-10-13 21:51:13 +05:30
( R ( i , j , iGrain ) , j = 1_pInt , 3_pInt ) , &
( D ( i , j , iGrain ) , j = 1_pInt , 3_pInt )
2009-10-12 21:31:49 +05:30
enddo
write ( 6 , * ) ' '
enddo
endif
2019-01-13 02:34:03 +05:30
#endif
2009-10-12 21:31:49 +05:30
2014-09-19 23:29:06 +05:30
!------------------------------------------------------------------------------------------------
2013-02-21 03:36:15 +05:30
! computing the residual stress from the balance of traction at all (interior) interfaces
2012-02-21 22:01:37 +05:30
do iNum = 1_pInt , nIntFaceTot
2018-11-04 12:41:35 +05:30
faceID = interface1to4 ( iNum , param ( instance ) % Nconstituents ) ! identifying the interface ID in local coordinate system (4-dimensional index)
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
! identify the left/bottom/back grain (-|N)
iGr3N = faceID ( 2 : 4 ) ! identifying the grain ID in local coordinate system (3-dimensional index)
2018-11-04 12:41:35 +05:30
iGrN = grain3to1 ( iGr3N , param ( instance ) % Nconstituents ) ! translate the local grain ID into global coordinate system (1-dimensional index)
2018-08-30 14:20:52 +05:30
intFaceN = getInterface ( 2_pInt * faceID ( 1 ) , iGr3N )
2018-11-04 03:43:20 +05:30
normN = interfaceNormal ( intFaceN , instance , of )
2010-11-26 17:20:20 +05:30
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
! identify the right/up/front grain (+|P)
2009-10-12 21:31:49 +05:30
iGr3P = iGr3N
2013-02-21 03:36:15 +05:30
iGr3P ( faceID ( 1 ) ) = iGr3N ( faceID ( 1 ) ) + 1_pInt ! identifying the grain ID in local coordinate system (3-dimensional index)
2018-11-04 12:41:35 +05:30
iGrP = grain3to1 ( iGr3P , param ( instance ) % Nconstituents ) ! translate the local grain ID into global coordinate system (1-dimensional index)
2018-08-30 14:20:52 +05:30
intFaceP = getInterface ( 2_pInt * faceID ( 1 ) - 1_pInt , iGr3P )
2018-11-04 03:43:20 +05:30
normP = interfaceNormal ( intFaceP , instance , of )
2010-11-26 17:20:20 +05:30
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
! compute the residual of traction at the interface (in local system, 4-dimensional index)
2012-02-21 22:01:37 +05:30
do i = 1_pInt , 3_pInt
2012-02-13 19:48:07 +05:30
tract ( iNum , i ) = sign ( viscModus_RGC * ( abs ( drelax ( i + 3 * ( iNum - 1_pInt ) ) ) / ( refRelaxRate_RGC * dt ) ) ** viscPower_RGC , &
2013-02-21 03:36:15 +05:30
drelax ( i + 3 * ( iNum - 1_pInt ) ) ) ! contribution from the relaxation viscosity
2012-02-21 22:01:37 +05:30
do j = 1_pInt , 3_pInt
2013-02-21 03:36:15 +05:30
tract ( iNum , i ) = tract ( iNum , i ) + ( P ( i , j , iGrP ) + R ( i , j , iGrP ) + D ( i , j , iGrP ) ) * normP ( j ) & ! contribution from material stress P, mismatch penalty R, and volume penalty D projected into the interface
2009-12-16 21:50:53 +05:30
+ ( P ( i , j , iGrN ) + R ( i , j , iGrN ) + D ( i , j , iGrN ) ) * normN ( j )
2013-02-21 03:36:15 +05:30
resid ( i + 3_pInt * ( iNum - 1_pInt ) ) = tract ( iNum , i ) ! translate the local residual into global 1-dimensional residual array
2009-11-17 19:12:38 +05:30
enddo
2009-10-12 21:31:49 +05:30
enddo
2010-11-26 17:20:20 +05:30
2019-01-13 02:34:03 +05:30
#ifdef DEBUG
2012-07-05 15:24:50 +05:30
if ( iand ( debug_level ( debug_homogenization ) , debug_levelExtensive ) / = 0_pInt ) then
2012-02-01 00:48:55 +05:30
write ( 6 , '(1x,a30,1x,i3)' ) 'Traction at interface: ' , iNum
2012-02-21 22:01:37 +05:30
write ( 6 , '(1x,3(e15.8,1x))' ) ( tract ( iNum , j ) , j = 1_pInt , 3_pInt )
2009-10-12 21:31:49 +05:30
write ( 6 , * ) ' '
endif
2019-01-13 02:34:03 +05:30
#endif
2009-10-12 21:31:49 +05:30
enddo
2013-12-18 12:58:01 +05:30
!--------------------------------------------------------------------------------------------------
2013-02-21 03:36:15 +05:30
! convergence check for stress residual
stresMax = maxval ( abs ( P ) ) ! get the maximum of first Piola-Kirchhoff (material) stress
residMax = maxval ( abs ( tract ) ) ! get the maximum of the residual
2010-11-26 17:20:20 +05:30
2019-01-13 02:34:03 +05:30
#ifdef DEBUG
2012-07-05 15:24:50 +05:30
if ( iand ( debug_level ( debug_homogenization ) , debug_levelExtensive ) / = 0_pInt &
2012-03-09 01:55:28 +05:30
. and . debug_e == el . and . debug_i == ip ) then
2019-01-13 14:03:47 +05:30
stresLoc = int ( maxloc ( abs ( P ) ) , pInt ) ! get the location of the maximum stress
residLoc = int ( maxloc ( abs ( tract ) ) , pInt ) ! get the position of the maximum residual
2012-02-01 00:48:55 +05:30
write ( 6 , '(1x,a)' ) ' '
write ( 6 , '(1x,a,1x,i2,1x,i4)' ) 'RGC residual check ...' , ip , el
2012-02-16 00:28:38 +05:30
write ( 6 , '(1x,a15,1x,e15.8,1x,a7,i3,1x,a12,i2,i2)' ) 'Max stress: ' , stresMax , &
2009-10-12 21:31:49 +05:30
'@ grain' , stresLoc ( 3 ) , 'in component' , stresLoc ( 1 ) , stresLoc ( 2 )
2012-02-16 00:28:38 +05:30
write ( 6 , '(1x,a15,1x,e15.8,1x,a7,i3,1x,a12,i2)' ) 'Max residual: ' , residMax , &
2009-10-12 21:31:49 +05:30
'@ iface' , residLoc ( 1 ) , 'in direction' , residLoc ( 2 )
2012-11-06 21:20:20 +05:30
flush ( 6 )
2009-10-12 21:31:49 +05:30
endif
2019-01-13 02:34:03 +05:30
#endif
2010-11-26 17:20:20 +05:30
2009-10-12 21:31:49 +05:30
homogenization_RGC_updateState = . false .
2013-10-16 18:34:59 +05:30
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
! If convergence reached => done and happy
2009-10-12 21:31:49 +05:30
if ( residMax < relTol_RGC * stresMax . or . residMax < absTol_RGC ) then
homogenization_RGC_updateState = . true .
2019-01-13 03:37:35 +05:30
#ifdef DEBUG
2012-07-05 15:24:50 +05:30
if ( iand ( debug_level ( debug_homogenization ) , debug_levelExtensive ) / = 0_pInt &
2012-03-09 01:55:28 +05:30
. and . debug_e == el . and . debug_i == ip ) then
2013-10-16 18:34:59 +05:30
write ( 6 , '(1x,a55,/)' ) '... done and happy'
2012-11-06 21:20:20 +05:30
flush ( 6 )
2009-10-12 21:31:49 +05:30
endif
2019-01-13 03:37:35 +05:30
#endif
2010-11-26 17:20:20 +05:30
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
! compute/update the state for postResult, i.e., all energy densities computed by time-integration
2019-01-13 13:44:23 +05:30
do iGrain = 1_pInt , product ( prm % Nconstituents )
2018-11-04 03:53:52 +05:30
do i = 1_pInt , 3_pInt ; do j = 1_pInt , 3_pInt
2019-01-13 03:37:35 +05:30
stt % work ( of ) = stt % work ( of ) &
+ P ( i , j , iGrain ) * ( F ( i , j , iGrain ) - F0 ( i , j , iGrain ) ) / real ( nGrain , pReal )
stt % penaltyEnergy ( of ) = stt % penaltyEnergy ( of ) &
+ R ( i , j , iGrain ) * ( F ( i , j , iGrain ) - F0 ( i , j , iGrain ) ) / real ( nGrain , pReal )
2018-11-04 03:53:52 +05:30
enddo ; enddo
2009-10-12 21:31:49 +05:30
enddo
2018-11-04 02:06:49 +05:30
2019-01-13 03:52:13 +05:30
dst % mismatch ( 1 : 3 , of ) = sum ( NN , 2 ) / real ( nGrain , pReal )
dst % relaxationRate_avg ( of ) = sum ( abs ( drelax ) ) / dt / real ( 3_pInt * nIntFaceTot , pReal )
dst % relaxationRate_max ( of ) = maxval ( abs ( drelax ) ) / dt
2019-01-13 03:37:35 +05:30
#ifdef DEBUG
2012-07-05 15:24:50 +05:30
if ( iand ( debug_level ( debug_homogenization ) , debug_levelExtensive ) / = 0_pInt &
2012-03-09 01:55:28 +05:30
. and . debug_e == el . and . debug_i == ip ) then
2019-01-13 03:37:35 +05:30
write ( 6 , '(1x,a30,1x,e15.8)' ) 'Constitutive work: ' , stt % work ( of )
2019-01-13 03:52:13 +05:30
write ( 6 , '(1x,a30,3(1x,e15.8))' ) 'Magnitude mismatch: ' , dst % mismatch ( 1 , of ) , &
dst % mismatch ( 2 , of ) , &
dst % mismatch ( 3 , of )
2019-01-13 03:37:35 +05:30
write ( 6 , '(1x,a30,1x,e15.8)' ) 'Penalty energy: ' , stt % penaltyEnergy ( of )
2019-01-13 03:52:13 +05:30
write ( 6 , '(1x,a30,1x,e15.8,/)' ) 'Volume discrepancy: ' , dst % volumeDiscrepancy ( of )
write ( 6 , '(1x,a30,1x,e15.8)' ) 'Maximum relaxation rate: ' , dst % relaxationRate_max ( of )
write ( 6 , '(1x,a30,1x,e15.8,/)' ) 'Average relaxation rate: ' , dst % relaxationRate_avg ( of )
2012-11-06 21:20:20 +05:30
flush ( 6 )
2009-10-12 21:31:49 +05:30
endif
2019-01-13 03:37:35 +05:30
#endif
2010-11-26 17:20:20 +05:30
2009-10-12 21:31:49 +05:30
return
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
! if residual blows-up => done but unhappy
elseif ( residMax > relMax_RGC * stresMax . or . residMax > absMax_RGC ) then ! try to restart when residual blows up exceeding maximum bound
homogenization_RGC_updateState = [ . true . , . false . ] ! with direct cut-back
2019-01-13 03:37:35 +05:30
#ifdef DEBUG
2012-07-05 15:24:50 +05:30
if ( iand ( debug_level ( debug_homogenization ) , debug_levelExtensive ) / = 0_pInt &
2012-03-09 01:55:28 +05:30
. and . debug_e == el . and . debug_i == ip ) then
2013-10-16 18:34:59 +05:30
write ( 6 , '(1x,a55,/)' ) '... broken'
2012-11-06 21:20:20 +05:30
flush ( 6 )
2009-10-12 21:31:49 +05:30
endif
2019-01-13 03:37:35 +05:30
#endif
return
2010-11-26 17:20:20 +05:30
2013-02-21 03:36:15 +05:30
else ! proceed with computing the Jacobian and state update
2019-01-13 03:37:35 +05:30
#ifdef DEBUG
2012-07-05 15:24:50 +05:30
if ( iand ( debug_level ( debug_homogenization ) , debug_levelExtensive ) / = 0_pInt &
2012-03-09 01:55:28 +05:30
. and . debug_e == el . and . debug_i == ip ) then
2013-10-16 18:34:59 +05:30
write ( 6 , '(1x,a55,/)' ) '... not yet done'
2012-11-06 21:20:20 +05:30
flush ( 6 )
2009-10-12 21:31:49 +05:30
endif
2019-01-13 03:37:35 +05:30
#endif
2010-11-26 17:20:20 +05:30
2009-10-12 21:31:49 +05:30
endif
2014-09-19 23:29:06 +05:30
!---------------------------------------------------------------------------------------------------
2013-02-21 03:36:15 +05:30
! construct the global Jacobian matrix for updating the global relaxation vector array when
! convergence is not yet reached ...
!--------------------------------------------------------------------------------------------------
! ... of the constitutive stress tangent, assembled from dPdF or material constitutive model "smatrix"
2013-12-18 12:58:01 +05:30
allocate ( smatrix ( 3 * nIntFaceTot , 3 * nIntFaceTot ) , source = 0.0_pReal )
2012-02-21 22:01:37 +05:30
do iNum = 1_pInt , nIntFaceTot
2018-12-18 22:47:06 +05:30
faceID = interface1to4 ( iNum , param ( instance ) % Nconstituents ) ! assembling of local dPdF into global Jacobian matrix
2010-11-26 17:20:20 +05:30
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
! identify the left/bottom/back grain (-|N)
iGr3N = faceID ( 2 : 4 ) ! identifying the grain ID in local coordinate sytem
2018-12-18 22:47:06 +05:30
iGrN = grain3to1 ( iGr3N , param ( instance ) % Nconstituents ) ! translate into global grain ID
intFaceN = getInterface ( 2_pInt * faceID ( 1 ) , iGr3N ) ! identifying the connecting interface in local coordinate system
2018-11-04 03:43:20 +05:30
normN = interfaceNormal ( intFaceN , instance , of )
2018-11-04 02:06:49 +05:30
do iFace = 1_pInt , 6_pInt
2018-12-18 22:47:06 +05:30
intFaceN = getInterface ( iFace , iGr3N ) ! identifying all interfaces that influence relaxation of the above interface
2018-11-04 03:43:20 +05:30
mornN = interfaceNormal ( intFaceN , instance , of )
2018-11-04 12:26:27 +05:30
iMun = interface4to1 ( intFaceN , param ( instance ) % Nconstituents ) ! translate the interfaces ID into local 4-dimensional index
2013-12-18 12:58:01 +05:30
if ( iMun > 0 ) then ! get the corresponding tangent
2012-02-21 22:01:37 +05:30
do i = 1_pInt , 3_pInt ; do j = 1_pInt , 3_pInt ; do k = 1_pInt , 3_pInt ; do l = 1_pInt , 3_pInt
2018-11-04 03:53:52 +05:30
smatrix ( 3 * ( iNum - 1 ) + i , 3 * ( iMun - 1 ) + j ) = smatrix ( 3 * ( iNum - 1 ) + i , 3 * ( iMun - 1 ) + j ) &
+ dPdF ( i , k , j , l , iGrN ) * normN ( k ) * mornN ( l )
2011-08-03 23:28:16 +05:30
enddo ; enddo ; enddo ; enddo
2014-08-21 23:18:20 +05:30
! projecting the material tangent dPdF into the interface
! to obtain the Jacobian matrix contribution of dPdF
2009-10-12 21:31:49 +05:30
endif
enddo
2010-11-26 17:20:20 +05:30
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
! identify the right/up/front grain (+|P)
2009-10-12 21:31:49 +05:30
iGr3P = iGr3N
2013-02-21 03:36:15 +05:30
iGr3P ( faceID ( 1 ) ) = iGr3N ( faceID ( 1 ) ) + 1_pInt ! identifying the grain ID in local coordinate sytem
2018-12-18 22:47:06 +05:30
iGrP = grain3to1 ( iGr3P , param ( instance ) % Nconstituents ) ! translate into global grain ID
intFaceP = getInterface ( 2_pInt * faceID ( 1 ) - 1_pInt , iGr3P ) ! identifying the connecting interface in local coordinate system
2018-11-04 03:43:20 +05:30
normP = interfaceNormal ( intFaceP , instance , of )
2018-11-04 02:06:49 +05:30
do iFace = 1_pInt , 6_pInt
2018-12-18 22:47:06 +05:30
intFaceP = getInterface ( iFace , iGr3P ) ! identifying all interfaces that influence relaxation of the above interface
2018-11-04 03:43:20 +05:30
mornP = interfaceNormal ( intFaceP , instance , of )
2018-12-18 22:47:06 +05:30
iMun = interface4to1 ( intFaceP , param ( instance ) % Nconstituents ) ! translate the interfaces ID into local 4-dimensional index
2013-02-21 03:36:15 +05:30
if ( iMun > 0_pInt ) then ! get the corresponding tangent
2012-02-21 22:01:37 +05:30
do i = 1_pInt , 3_pInt ; do j = 1_pInt , 3_pInt ; do k = 1_pInt , 3_pInt ; do l = 1_pInt , 3_pInt
2018-11-04 13:19:40 +05:30
smatrix ( 3 * ( iNum - 1 ) + i , 3 * ( iMun - 1 ) + j ) = smatrix ( 3 * ( iNum - 1 ) + i , 3 * ( iMun - 1 ) + j ) &
+ dPdF ( i , k , j , l , iGrP ) * normP ( k ) * mornP ( l )
2011-08-03 23:28:16 +05:30
enddo ; enddo ; enddo ; enddo
2009-10-12 21:31:49 +05:30
endif
enddo
enddo
2010-11-26 17:20:20 +05:30
2019-01-13 03:37:35 +05:30
#ifdef DEBUG
2012-07-05 15:24:50 +05:30
if ( iand ( debug_level ( debug_homogenization ) , debug_levelExtensive ) / = 0_pInt ) then
2012-02-01 00:48:55 +05:30
write ( 6 , '(1x,a30)' ) 'Jacobian matrix of stress'
2012-02-21 22:01:37 +05:30
do i = 1_pInt , 3_pInt * nIntFaceTot
write ( 6 , '(1x,100(e11.4,1x))' ) ( smatrix ( i , j ) , j = 1_pInt , 3_pInt * nIntFaceTot )
2009-10-12 21:31:49 +05:30
enddo
write ( 6 , * ) ' '
2012-11-06 21:20:20 +05:30
flush ( 6 )
2009-10-12 21:31:49 +05:30
endif
2019-01-13 03:37:35 +05:30
#endif
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
! ... of the stress penalty tangent (mismatch penalty and volume penalty, computed using numerical
! perturbation method) "pmatrix"
2013-12-18 12:58:01 +05:30
allocate ( pmatrix ( 3 * nIntFaceTot , 3 * nIntFaceTot ) , source = 0.0_pReal )
allocate ( p_relax ( 3 * nIntFaceTot ) , source = 0.0_pReal )
allocate ( p_resid ( 3 * nIntFaceTot ) , source = 0.0_pReal )
2018-11-04 13:19:40 +05:30
2012-02-21 22:01:37 +05:30
do ipert = 1_pInt , 3_pInt * nIntFaceTot
2009-10-12 21:31:49 +05:30
p_relax = relax
2013-02-21 03:36:15 +05:30
p_relax ( ipert ) = relax ( ipert ) + pPert_RGC ! perturb the relaxation vector
2019-01-13 03:37:35 +05:30
stt % relaxationVector ( : , of ) = p_relax
2018-12-18 22:47:06 +05:30
call grainDeformation ( pF , avgF , instance , of ) ! rain deformation from perturbed state
2019-01-13 14:03:47 +05:30
call stressPenalty ( pR , DevNull , avgF , pF , ip , el , instance , of ) ! stress penalty due to interface mismatch from perturbed state
call volumePenalty ( pD , devNull ( 1 , 1 ) , avgF , pF , nGrain , instance , of ) ! stress penalty due to volume discrepancy from perturbed state
2010-11-26 17:20:20 +05:30
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
! computing the global stress residual array from the perturbed state
2009-10-12 21:31:49 +05:30
p_resid = 0.0_pReal
2012-02-21 22:01:37 +05:30
do iNum = 1_pInt , nIntFaceTot
2018-11-04 12:41:35 +05:30
faceID = interface1to4 ( iNum , param ( instance ) % Nconstituents ) ! identifying the interface ID in local coordinate system (4-dimensional index)
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
! identify the left/bottom/back grain (-|N)
2018-12-18 22:47:06 +05:30
iGr3N = faceID ( 2 : 4 ) ! identify the grain ID in local coordinate system (3-dimensional index)
iGrN = grain3to1 ( iGr3N , param ( instance ) % Nconstituents ) ! translate the local grain ID into global coordinate system (1-dimensional index)
intFaceN = getInterface ( 2_pInt * faceID ( 1 ) , iGr3N ) ! identify the interface ID of the grain
2018-11-04 03:43:20 +05:30
normN = interfaceNormal ( intFaceN , instance , of )
2010-11-26 17:20:20 +05:30
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
! identify the right/up/front grain (+|P)
2009-10-12 21:31:49 +05:30
iGr3P = iGr3N
2018-12-18 22:47:06 +05:30
iGr3P ( faceID ( 1 ) ) = iGr3N ( faceID ( 1 ) ) + 1_pInt ! identify the grain ID in local coordinate system (3-dimensional index)
iGrP = grain3to1 ( iGr3P , param ( instance ) % Nconstituents ) ! translate the local grain ID into global coordinate system (1-dimensional index)
intFaceP = getInterface ( 2_pInt * faceID ( 1 ) - 1_pInt , iGr3P ) ! identify the interface ID of the grain
2018-11-04 03:43:20 +05:30
normP = interfaceNormal ( intFaceP , instance , of )
2010-11-26 17:20:20 +05:30
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
! compute the residual stress (contribution of mismatch and volume penalties) from perturbed state
! at all interfaces
do i = 1_pInt , 3_pInt ; do j = 1_pInt , 3_pInt
2009-10-12 21:31:49 +05:30
p_resid ( i + 3 * ( iNum - 1 ) ) = p_resid ( i + 3 * ( iNum - 1 ) ) + ( pR ( i , j , iGrP ) - R ( i , j , iGrP ) ) * normP ( j ) &
2009-12-16 21:50:53 +05:30
+ ( pR ( i , j , iGrN ) - R ( i , j , iGrN ) ) * normN ( j ) &
+ ( pD ( i , j , iGrP ) - D ( i , j , iGrP ) ) * normP ( j ) &
+ ( pD ( i , j , iGrN ) - D ( i , j , iGrN ) ) * normN ( j )
2013-02-21 03:36:15 +05:30
enddo ; enddo
2009-10-12 21:31:49 +05:30
enddo
pmatrix ( : , ipert ) = p_resid / pPert_RGC
enddo
2010-11-26 17:20:20 +05:30
2019-01-13 03:37:35 +05:30
#ifdef DEBUG
2012-07-05 15:24:50 +05:30
if ( iand ( debug_level ( debug_homogenization ) , debug_levelExtensive ) / = 0_pInt ) then
2012-02-01 00:48:55 +05:30
write ( 6 , '(1x,a30)' ) 'Jacobian matrix of penalty'
2012-02-21 22:01:37 +05:30
do i = 1_pInt , 3_pInt * nIntFaceTot
write ( 6 , '(1x,100(e11.4,1x))' ) ( pmatrix ( i , j ) , j = 1_pInt , 3_pInt * nIntFaceTot )
2009-10-12 21:31:49 +05:30
enddo
write ( 6 , * ) ' '
2012-11-06 21:20:20 +05:30
flush ( 6 )
2009-10-12 21:31:49 +05:30
endif
2019-01-13 03:37:35 +05:30
#endif
2009-11-17 19:12:38 +05:30
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
! ... of the numerical viscosity traction "rmatrix"
2013-12-18 12:58:01 +05:30
allocate ( rmatrix ( 3 * nIntFaceTot , 3 * nIntFaceTot ) , source = 0.0_pReal )
2012-02-21 22:01:37 +05:30
forall ( i = 1_pInt : 3_pInt * nIntFaceTot ) &
2013-02-21 03:36:15 +05:30
rmatrix ( i , i ) = viscModus_RGC * viscPower_RGC / ( refRelaxRate_RGC * dt ) * & ! tangent due to numerical viscosity traction appears
( abs ( drelax ( i ) ) / ( refRelaxRate_RGC * dt ) ) ** ( viscPower_RGC - 1.0_pReal ) ! only in the main diagonal term
2019-01-13 03:37:35 +05:30
#ifdef DEBUG
2012-07-05 15:24:50 +05:30
if ( iand ( debug_level ( debug_homogenization ) , debug_levelExtensive ) / = 0_pInt ) then
2012-02-01 00:48:55 +05:30
write ( 6 , '(1x,a30)' ) 'Jacobian matrix of penalty'
2012-02-21 22:01:37 +05:30
do i = 1_pInt , 3_pInt * nIntFaceTot
write ( 6 , '(1x,100(e11.4,1x))' ) ( rmatrix ( i , j ) , j = 1_pInt , 3_pInt * nIntFaceTot )
2009-11-17 19:12:38 +05:30
enddo
write ( 6 , * ) ' '
2012-11-06 21:20:20 +05:30
flush ( 6 )
2009-11-17 19:12:38 +05:30
endif
2019-01-13 03:37:35 +05:30
#endif
2009-11-17 19:12:38 +05:30
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
! The overall Jacobian matrix summarizing contributions of smatrix, pmatrix, rmatrix
2009-11-17 19:12:38 +05:30
allocate ( jmatrix ( 3 * nIntFaceTot , 3 * nIntFaceTot ) ) ; jmatrix = smatrix + pmatrix + rmatrix
2019-01-13 03:37:35 +05:30
#ifdef DEBUG
2012-07-05 15:24:50 +05:30
if ( iand ( debug_level ( debug_homogenization ) , debug_levelExtensive ) / = 0_pInt ) then
2012-02-01 00:48:55 +05:30
write ( 6 , '(1x,a30)' ) 'Jacobian matrix (total)'
2012-02-21 22:01:37 +05:30
do i = 1_pInt , 3_pInt * nIntFaceTot
write ( 6 , '(1x,100(e11.4,1x))' ) ( jmatrix ( i , j ) , j = 1_pInt , 3_pInt * nIntFaceTot )
2009-10-12 21:31:49 +05:30
enddo
write ( 6 , * ) ' '
2012-11-06 21:20:20 +05:30
flush ( 6 )
2009-10-12 21:31:49 +05:30
endif
2019-01-13 03:37:35 +05:30
#endif
2010-11-26 17:20:20 +05:30
2013-12-18 12:58:01 +05:30
!--------------------------------------------------------------------------------------------------
2013-02-21 03:36:15 +05:30
! computing the update of the state variable (relaxation vectors) using the Jacobian matrix
2013-12-18 12:58:01 +05:30
allocate ( jnverse ( 3_pInt * nIntFaceTot , 3_pInt * nIntFaceTot ) , source = 0.0_pReal )
2019-01-13 13:44:23 +05:30
call math_invert2 ( jnverse , error , jmatrix )
2010-11-26 17:20:20 +05:30
2019-01-13 03:37:35 +05:30
#ifdef DEBUG
2012-07-05 15:24:50 +05:30
if ( iand ( debug_level ( debug_homogenization ) , debug_levelExtensive ) / = 0_pInt ) then
2012-02-01 00:48:55 +05:30
write ( 6 , '(1x,a30)' ) 'Jacobian inverse'
2012-02-21 22:01:37 +05:30
do i = 1_pInt , 3_pInt * nIntFaceTot
2012-02-16 00:28:38 +05:30
write ( 6 , '(1x,100(e11.4,1x))' ) ( jnverse ( i , j ) , j = 1_pInt , 3_pInt * nIntFaceTot )
2009-10-12 21:31:49 +05:30
enddo
write ( 6 , * ) ' '
2012-11-06 21:20:20 +05:30
flush ( 6 )
2009-10-12 21:31:49 +05:30
endif
2019-01-13 03:37:35 +05:30
#endif
2009-10-12 21:31:49 +05:30
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
! calculate the state update (global relaxation vectors) for the next Newton-Raphson iteration
2009-11-17 19:12:38 +05:30
drelax = 0.0_pReal
2018-11-04 13:19:40 +05:30
do i = 1_pInt , 3_pInt * nIntFaceTot ; do j = 1_pInt , 3_pInt * nIntFaceTot
drelax ( i ) = drelax ( i ) - jnverse ( i , j ) * resid ( j ) ! Calculate the correction for the state variable
enddo ; enddo
2019-01-13 13:44:23 +05:30
stt % relaxationVector ( : , of ) = relax + drelax ! Updateing the state variable for the next iteration
2013-02-21 03:36:15 +05:30
if ( any ( abs ( drelax ) > maxdRelax_RGC ) ) then ! Forcing cutback when the incremental change of relaxation vector becomes too large
homogenization_RGC_updateState = [ . true . , . false . ]
openmp parallelization working again (at least for j2 and nonlocal constitutive model).
In order to keep it like that, please follow these simple rules:
DON'T use implicit array subscripts:
example: real, dimension(3,3) :: A,B
A(:,2) = B(:,1) <--- DON'T USE
A(1:3,2) = B(1:3,1) <--- BETTER USE
In many cases the use of explicit array subscripts is inevitable for parallelization. Additionally, it is an easy means to prevent memory leaks.
Enclose all write statements with the following:
!$OMP CRITICAL (write2out)
<your write statement>
!$OMP END CRITICAL (write2out)
Whenever you change something in the code and are not sure if it affects parallelization and leads to nonconforming behavior, please ask me and/or Franz to check this.
2011-03-17 16:16:17 +05:30
!$OMP CRITICAL (write2out)
2012-02-01 00:48:55 +05:30
write ( 6 , '(1x,a,1x,i3,1x,a,1x,i3,1x,a)' ) 'RGC_updateState: ip' , ip , '| el' , el , 'enforces cutback'
2012-02-16 00:28:38 +05:30
write ( 6 , '(1x,a,1x,e15.8)' ) 'due to large relaxation change =' , maxval ( abs ( drelax ) )
2012-11-06 21:20:20 +05:30
flush ( 6 )
openmp parallelization working again (at least for j2 and nonlocal constitutive model).
In order to keep it like that, please follow these simple rules:
DON'T use implicit array subscripts:
example: real, dimension(3,3) :: A,B
A(:,2) = B(:,1) <--- DON'T USE
A(1:3,2) = B(1:3,1) <--- BETTER USE
In many cases the use of explicit array subscripts is inevitable for parallelization. Additionally, it is an easy means to prevent memory leaks.
Enclose all write statements with the following:
!$OMP CRITICAL (write2out)
<your write statement>
!$OMP END CRITICAL (write2out)
Whenever you change something in the code and are not sure if it affects parallelization and leads to nonconforming behavior, please ask me and/or Franz to check this.
2011-03-17 16:16:17 +05:30
!$OMP END CRITICAL (write2out)
2009-10-12 21:31:49 +05:30
endif
2010-11-26 17:20:20 +05:30
2019-01-13 03:37:35 +05:30
#ifdef DEBUG
2012-03-09 01:55:28 +05:30
if ( iand ( debug_homogenization , debug_levelExtensive ) > 0_pInt ) then
2012-02-01 00:48:55 +05:30
write ( 6 , '(1x,a30)' ) 'Returned state: '
2019-01-13 03:37:35 +05:30
do i = 1_pInt , size ( stt % relaxationVector ( : , of ) )
2019-01-13 13:44:23 +05:30
write ( 6 , '(1x,2(e15.8,1x))' ) stt % relaxationVector ( i , of )
2009-10-12 21:31:49 +05:30
enddo
write ( 6 , * ) ' '
2012-11-06 21:20:20 +05:30
flush ( 6 )
2009-10-12 21:31:49 +05:30
endif
2019-01-13 03:37:35 +05:30
#endif
end associate
2018-11-04 01:41:43 +05:30
contains
!--------------------------------------------------------------------------------------------------
!> @brief calculate stress-like penalty due to deformation mismatch
!--------------------------------------------------------------------------------------------------
2019-01-13 03:37:35 +05:30
subroutine stressPenalty ( rPen , nMis , avgF , fDef , ip , el , instance , of )
2018-11-04 01:41:43 +05:30
use math , only : &
math_civita
use numerics , only : &
xSmoo_RGC
implicit none
2019-01-13 14:03:47 +05:30
real ( pReal ) , dimension ( : , : , : ) , intent ( out ) :: rPen !< stress-like penalty
real ( pReal ) , dimension ( : , : ) , intent ( out ) :: nMis !< total amount of mismatch
2019-01-13 03:37:35 +05:30
2019-01-13 14:03:47 +05:30
real ( pReal ) , dimension ( : , : , : ) , intent ( in ) :: fDef !< deformation gradients
real ( pReal ) , dimension ( 3 , 3 ) , intent ( in ) :: avgF !< initial effective stretch tensor
integer ( pInt ) , intent ( in ) :: ip , el , instance , of
2019-01-13 03:37:35 +05:30
2018-11-04 01:41:43 +05:30
integer ( pInt ) , dimension ( 4 ) :: intFace
integer ( pInt ) , dimension ( 3 ) :: iGrain3 , iGNghb3 , nGDim
real ( pReal ) , dimension ( 3 , 3 ) :: gDef , nDef
real ( pReal ) , dimension ( 3 ) :: nVect , surfCorr
real ( pReal ) , dimension ( 2 ) :: Gmoduli
2019-01-13 03:37:35 +05:30
integer ( pInt ) :: iGrain , iGNghb , iFace , i , j , k , l
2018-11-04 01:41:43 +05:30
real ( pReal ) :: muGrain , muGNghb , nDefNorm , bgGrain , bgGNghb
real ( pReal ) , parameter :: nDefToler = 1.0e-10_pReal
2019-01-13 03:37:35 +05:30
#ifdef DEBUG
2018-11-04 03:53:52 +05:30
logical :: debugActive
2019-01-13 03:37:35 +05:30
#endif
2018-11-04 03:53:52 +05:30
2018-11-04 01:41:43 +05:30
nGDim = param ( instance ) % Nconstituents
rPen = 0.0_pReal
nMis = 0.0_pReal
!--------------------------------------------------------------------------------------------------
! get the correction factor the modulus of penalty stress representing the evolution of area of
! the interfaces due to deformations
2018-11-04 03:43:20 +05:30
surfCorr = surfaceCorrection ( avgF , instance , of )
2019-01-13 03:37:35 +05:30
2018-11-04 01:41:43 +05:30
associate ( prm = > param ( instance ) )
2018-11-04 03:53:52 +05:30
2019-01-13 03:37:35 +05:30
#ifdef DEBUG
debugActive = iand ( debug_level ( debug_homogenization ) , debug_levelExtensive ) / = 0_pInt &
2019-01-13 13:44:23 +05:30
. and . prm % of_debug == of
2019-01-13 03:37:35 +05:30
2018-11-04 03:53:52 +05:30
if ( debugActive ) then
write ( 6 , '(1x,a20,2(1x,i3))' ) 'Correction factor: ' , ip , el
write ( 6 , * ) surfCorr
2018-11-04 01:41:43 +05:30
endif
2019-01-13 03:37:35 +05:30
#endif
2018-11-04 01:41:43 +05:30
!--------------------------------------------------------------------------------------------------
! computing the mismatch and penalty stress tensor of all grains
2019-01-13 03:37:35 +05:30
grainLoop : do iGrain = 1_pInt , product ( prm % Nconstituents )
2018-11-04 01:41:43 +05:30
Gmoduli = equivalentModuli ( iGrain , ip , el )
2018-12-18 22:47:06 +05:30
muGrain = Gmoduli ( 1 ) ! collecting the equivalent shear modulus of grain
bgGrain = Gmoduli ( 2 ) ! and the lengthh of Burgers vector
iGrain3 = grain1to3 ( iGrain , prm % Nconstituents ) ! get the grain ID in local 3-dimensional index (x,y,z)-position
2018-11-04 01:41:43 +05:30
2019-01-13 03:37:35 +05:30
interfaceLoop : do iFace = 1_pInt , 6_pInt
2018-12-18 22:47:06 +05:30
intFace = getInterface ( iFace , iGrain3 ) ! get the 4-dimensional index of the interface in local numbering system of the grain
2018-11-04 03:43:20 +05:30
nVect = interfaceNormal ( intFace , instance , of )
2018-12-18 22:47:06 +05:30
iGNghb3 = iGrain3 ! identify the neighboring grain across the interface
2018-11-04 02:06:49 +05:30
iGNghb3 ( abs ( intFace ( 1 ) ) ) = iGNghb3 ( abs ( intFace ( 1 ) ) ) &
+ int ( real ( intFace ( 1 ) , pReal ) / real ( abs ( intFace ( 1 ) ) , pReal ) , pInt )
where ( iGNghb3 < 1 ) iGNghb3 = nGDim
where ( iGNghb3 > nGDim ) iGNghb3 = 1_pInt
2018-12-18 22:47:06 +05:30
iGNghb = grain3to1 ( iGNghb3 , prm % Nconstituents ) ! get the ID of the neighboring grain
Gmoduli = equivalentModuli ( iGNghb , ip , el ) ! collect the shear modulus and Burgers vector of the neighbor
2018-11-04 01:41:43 +05:30
muGNghb = Gmoduli ( 1 )
bgGNghb = Gmoduli ( 2 )
2018-12-18 22:47:06 +05:30
gDef = 0.5_pReal * ( fDef ( 1 : 3 , 1 : 3 , iGNghb ) - fDef ( 1 : 3 , 1 : 3 , iGrain ) ) ! difference/jump in deformation gradeint across the neighbor
2018-11-04 01:41:43 +05:30
!--------------------------------------------------------------------------------------------------
! compute the mismatch tensor of all interfaces
nDefNorm = 0.0_pReal
nDef = 0.0_pReal
do i = 1_pInt , 3_pInt ; do j = 1_pInt , 3_pInt
do k = 1_pInt , 3_pInt ; do l = 1_pInt , 3_pInt
2018-12-18 22:47:06 +05:30
nDef ( i , j ) = nDef ( i , j ) - nVect ( k ) * gDef ( i , l ) * math_civita ( j , k , l ) ! compute the interface mismatch tensor from the jump of deformation gradient
2018-11-04 01:41:43 +05:30
enddo ; enddo
2018-12-18 22:47:06 +05:30
nDefNorm = nDefNorm + nDef ( i , j ) ** 2.0_pReal ! compute the norm of the mismatch tensor
2018-11-04 01:41:43 +05:30
enddo ; enddo
2018-12-18 22:47:06 +05:30
nDefNorm = max ( nDefToler , sqrt ( nDefNorm ) ) ! approximation to zero mismatch if mismatch is zero (singularity)
nMis ( abs ( intFace ( 1 ) ) , iGrain ) = nMis ( abs ( intFace ( 1 ) ) , iGrain ) + nDefNorm ! total amount of mismatch experienced by the grain (at all six interfaces)
2019-01-13 03:37:35 +05:30
#ifdef DEBUG
2018-11-04 13:19:40 +05:30
if ( debugActive ) then
write ( 6 , '(1x,a20,i2,1x,a20,1x,i3)' ) 'Mismatch to face: ' , intFace ( 1 ) , 'neighbor grain: ' , iGNghb
write ( 6 , * ) transpose ( nDef )
write ( 6 , '(1x,a20,e11.4)' ) 'with magnitude: ' , nDefNorm
endif
2019-01-13 03:37:35 +05:30
#endif
2018-11-04 01:41:43 +05:30
!--------------------------------------------------------------------------------------------------
! compute the stress penalty of all interfaces
2018-11-04 13:19:40 +05:30
do i = 1_pInt , 3_pInt ; do j = 1_pInt , 3_pInt ; do k = 1_pInt , 3_pInt ; do l = 1_pInt , 3_pInt
rPen ( i , j , iGrain ) = rPen ( i , j , iGrain ) + 0.5_pReal * ( muGrain * bgGrain + muGNghb * bgGNghb ) * prm % xiAlpha &
* surfCorr ( abs ( intFace ( 1 ) ) ) / prm % dAlpha ( abs ( intFace ( 1 ) ) ) &
* cosh ( prm % ciAlpha * nDefNorm ) &
* 0.5_pReal * nVect ( l ) * nDef ( i , k ) / nDefNorm * math_civita ( k , l , j ) &
* tanh ( nDefNorm / xSmoo_RGC )
enddo ; enddo ; enddo ; enddo
2019-01-13 03:37:35 +05:30
enddo interfaceLoop
#ifdef DEBUG
2018-11-04 03:53:52 +05:30
if ( debugActive ) then
2019-01-13 03:37:35 +05:30
write ( 6 , '(1x,a20,i2)' ) 'Penalty of grain: ' , iGrain
write ( 6 , * ) transpose ( rPen ( 1 : 3 , 1 : 3 , iGrain ) )
2018-11-04 01:41:43 +05:30
endif
2019-01-13 03:37:35 +05:30
#endif
2018-11-04 01:41:43 +05:30
2019-01-13 03:37:35 +05:30
enddo grainLoop
2018-11-04 01:41:43 +05:30
end associate
end subroutine stressPenalty
!--------------------------------------------------------------------------------------------------
!> @brief calculate stress-like penalty due to volume discrepancy
!--------------------------------------------------------------------------------------------------
2019-01-13 03:37:35 +05:30
subroutine volumePenalty ( vPen , vDiscrep , fAvg , fDef , nGrain , instance , of )
2018-11-04 01:41:43 +05:30
use math , only : &
math_det33 , &
math_inv33
use numerics , only : &
maxVolDiscr_RGC , &
volDiscrMod_RGC , &
volDiscrPow_RGC
implicit none
2019-01-13 14:03:47 +05:30
real ( pReal ) , dimension ( : , : , : ) , intent ( out ) :: vPen ! stress-like penalty due to volume
real ( pReal ) , intent ( out ) :: vDiscrep ! total volume discrepancy
2019-01-13 03:37:35 +05:30
2019-01-13 14:03:47 +05:30
real ( pReal ) , dimension ( : , : , : ) , intent ( in ) :: fDef ! deformation gradients
real ( pReal ) , dimension ( 3 , 3 ) , intent ( in ) :: fAvg ! overall deformation gradient
2019-01-13 03:37:35 +05:30
integer ( pInt ) , intent ( in ) :: &
Ngrain , &
instance , &
of
2019-01-13 14:03:47 +05:30
real ( pReal ) , dimension ( size ( vPen , 3 ) ) :: gVol
2019-01-13 03:37:35 +05:30
integer ( pInt ) :: i
2018-11-04 03:53:52 +05:30
2018-11-04 01:41:43 +05:30
!--------------------------------------------------------------------------------------------------
! compute the volumes of grains and of cluster
2019-01-13 03:37:35 +05:30
vDiscrep = math_det33 ( fAvg ) ! compute the volume of the cluster
do i = 1_pInt , nGrain
gVol ( i ) = math_det33 ( fDef ( 1 : 3 , 1 : 3 , i ) ) ! compute the volume of individual grains
vDiscrep = vDiscrep - gVol ( i ) / real ( nGrain , pReal ) ! calculate the difference/dicrepancy between
! the volume of the cluster and the the total volume of grains
2018-11-04 01:41:43 +05:30
enddo
!--------------------------------------------------------------------------------------------------
! calculate the stress and penalty due to volume discrepancy
vPen = 0.0_pReal
2019-01-13 03:37:35 +05:30
do i = 1_pInt , nGrain
vPen ( : , : , i ) = - 1.0_pReal / real ( nGrain , pReal ) * volDiscrMod_RGC * volDiscrPow_RGC / maxVolDiscr_RGC * &
2018-11-04 01:41:43 +05:30
sign ( ( abs ( vDiscrep ) / maxVolDiscr_RGC ) ** ( volDiscrPow_RGC - 1.0 ) , vDiscrep ) * &
2019-01-13 03:37:35 +05:30
gVol ( i ) * transpose ( math_inv33 ( fDef ( : , : , i ) ) )
2018-11-04 01:41:43 +05:30
2019-01-13 03:37:35 +05:30
#ifdef DEBUG
if ( iand ( debug_level ( debug_homogenization ) , debug_levelExtensive ) / = 0_pInt &
. and . param ( instance ) % of_debug == of ) then
write ( 6 , '(1x,a30,i2)' ) 'Volume penalty of grain: ' , i
write ( 6 , * ) transpose ( vPen ( : , : , i ) )
2018-11-04 01:41:43 +05:30
endif
2019-01-13 03:37:35 +05:30
#endif
2018-11-04 01:41:43 +05:30
enddo
2018-11-04 02:06:49 +05:30
2018-11-04 01:41:43 +05:30
end subroutine volumePenalty
2018-11-04 02:06:49 +05:30
2018-11-04 01:41:43 +05:30
!--------------------------------------------------------------------------------------------------
!> @brief compute the correction factor accouted for surface evolution (area change) due to
! deformation
!--------------------------------------------------------------------------------------------------
2018-11-04 03:43:20 +05:30
function surfaceCorrection ( avgF , instance , of )
2018-11-04 01:41:43 +05:30
use math , only : &
math_invert33 , &
math_mul33x33
implicit none
real ( pReal ) , dimension ( 3 ) :: surfaceCorrection
real ( pReal ) , dimension ( 3 , 3 ) , intent ( in ) :: avgF !< average F
2018-11-04 03:43:20 +05:30
integer ( pInt ) , intent ( in ) :: &
instance , &
of
2018-11-04 01:41:43 +05:30
real ( pReal ) , dimension ( 3 , 3 ) :: invC
real ( pReal ) , dimension ( 3 ) :: nVect
real ( pReal ) :: detF
integer ( pInt ) :: i , j , iBase
logical :: error
call math_invert33 ( math_mul33x33 ( transpose ( avgF ) , avgF ) , invC , detF , error )
surfaceCorrection = 0.0_pReal
do iBase = 1_pInt , 3_pInt
2018-11-04 03:43:20 +05:30
nVect = interfaceNormal ( [ iBase , 1_pInt , 1_pInt , 1_pInt ] , instance , of )
2018-11-04 01:41:43 +05:30
do i = 1_pInt , 3_pInt ; do j = 1_pInt , 3_pInt
2019-01-13 13:44:23 +05:30
surfaceCorrection ( iBase ) = surfaceCorrection ( iBase ) + invC ( i , j ) * nVect ( i ) * nVect ( j ) ! compute the component of (the inverse of) the stretch in the direction of the normal
2018-11-04 01:41:43 +05:30
enddo ; enddo
2019-01-13 13:44:23 +05:30
surfaceCorrection ( iBase ) = sqrt ( surfaceCorrection ( iBase ) ) * detF ! get the surface correction factor (area contraction/enlargement)
2018-11-04 01:41:43 +05:30
enddo
end function surfaceCorrection
2018-11-04 02:06:49 +05:30
2018-11-04 01:41:43 +05:30
!--------------------------------------------------------------------------------------------------
!> @brief compute the equivalent shear and bulk moduli from the elasticity tensor
!--------------------------------------------------------------------------------------------------
function equivalentModuli ( grainID , ip , el )
use constitutive , only : &
constitutive_homogenizedC
implicit none
2018-11-04 12:41:35 +05:30
real ( pReal ) , dimension ( 2 ) :: equivalentModuli
2018-11-04 01:41:43 +05:30
integer ( pInt ) , intent ( in ) :: &
grainID , &
2019-01-13 13:44:23 +05:30
ip , & !< integration point number
el !< element number
2018-11-04 12:41:35 +05:30
real ( pReal ) , dimension ( 6 , 6 ) :: elasTens
2018-11-04 01:41:43 +05:30
real ( pReal ) :: &
cEquiv_11 , &
cEquiv_12 , &
cEquiv_44
elasTens = constitutive_homogenizedC ( grainID , ip , el )
!--------------------------------------------------------------------------------------------------
! compute the equivalent shear modulus after Turterltaub and Suiker, JMPS (2005)
cEquiv_11 = ( elasTens ( 1 , 1 ) + elasTens ( 2 , 2 ) + elasTens ( 3 , 3 ) ) / 3.0_pReal
cEquiv_12 = ( elasTens ( 1 , 2 ) + elasTens ( 2 , 3 ) + elasTens ( 3 , 1 ) + &
elasTens ( 1 , 3 ) + elasTens ( 2 , 1 ) + elasTens ( 3 , 2 ) ) / 6.0_pReal
cEquiv_44 = ( elasTens ( 4 , 4 ) + elasTens ( 5 , 5 ) + elasTens ( 6 , 6 ) ) / 3.0_pReal
equivalentModuli ( 1 ) = 0.2_pReal * ( cEquiv_11 - cEquiv_12 ) + 0.6_pReal * cEquiv_44
!--------------------------------------------------------------------------------------------------
! obtain the length of Burgers vector (could be model dependend)
equivalentModuli ( 2 ) = 2.5e-10_pReal
end function equivalentModuli
!--------------------------------------------------------------------------------------------------
!> @brief calculating the grain deformation gradient (the same with
2019-01-13 13:44:23 +05:30
! homogenization_RGC_partitionDeformation, but used only for perturbation scheme)
2018-11-04 01:41:43 +05:30
!--------------------------------------------------------------------------------------------------
2018-11-04 11:57:25 +05:30
subroutine grainDeformation ( F , avgF , instance , of )
2018-11-04 01:41:43 +05:30
implicit none
2019-01-13 13:44:23 +05:30
real ( pReal ) , dimension ( : , : , : ) , intent ( out ) :: F !< partioned F per grain
real ( pReal ) , dimension ( : , : ) , intent ( in ) :: avgF !< averaged F
integer ( pInt ) , intent ( in ) :: &
2018-11-04 11:57:25 +05:30
instance , &
of
2019-01-13 03:37:35 +05:30
2018-11-04 01:41:43 +05:30
real ( pReal ) , dimension ( 3 ) :: aVect , nVect
integer ( pInt ) , dimension ( 4 ) :: intFace
integer ( pInt ) , dimension ( 3 ) :: iGrain3
2018-11-04 11:57:25 +05:30
integer ( pInt ) :: iGrain , iFace , i , j
2018-11-04 01:41:43 +05:30
2019-01-13 13:44:23 +05:30
!-------------------------------------------------------------------------------------------------
2018-11-04 03:43:20 +05:30
! compute the deformation gradient of individual grains due to relaxations
2019-01-13 03:37:35 +05:30
associate ( prm = > param ( instance ) )
2018-11-04 11:57:25 +05:30
F = 0.0_pReal
2019-01-13 03:37:35 +05:30
do iGrain = 1_pInt , product ( prm % Nconstituents )
iGrain3 = grain1to3 ( iGrain , prm % Nconstituents )
2018-11-04 11:57:25 +05:30
do iFace = 1_pInt , 6_pInt
intFace = getInterface ( iFace , iGrain3 )
aVect = relaxationVector ( intFace , instance , of )
nVect = interfaceNormal ( intFace , instance , of )
forall ( i = 1_pInt : 3_pInt , j = 1_pInt : 3_pInt ) &
F ( i , j , iGrain ) = F ( i , j , iGrain ) + aVect ( i ) * nVect ( j ) ! effective relaxations
enddo
F ( 1 : 3 , 1 : 3 , iGrain ) = F ( 1 : 3 , 1 : 3 , iGrain ) + avgF ! relaxed deformation gradient
enddo
2018-11-04 03:43:20 +05:30
2019-01-13 03:37:35 +05:30
end associate
2018-11-04 01:41:43 +05:30
end subroutine grainDeformation
2009-10-12 21:31:49 +05:30
2013-02-21 03:36:15 +05:30
end function homogenization_RGC_updateState
!--------------------------------------------------------------------------------------------------
!> @brief derive average stress and stiffness from constituent quantities
!--------------------------------------------------------------------------------------------------
2018-11-04 00:38:18 +05:30
subroutine homogenization_RGC_averageStressAndItsTangent ( avgP , dAvgPdAvgF , P , dPdF , instance )
2009-10-12 21:31:49 +05:30
implicit none
2013-10-16 18:34:59 +05:30
real ( pReal ) , dimension ( 3 , 3 ) , intent ( out ) :: avgP !< average stress at material point
real ( pReal ) , dimension ( 3 , 3 , 3 , 3 ) , intent ( out ) :: dAvgPdAvgF !< average stiffness at material point
2019-01-13 13:44:23 +05:30
real ( pReal ) , dimension ( : , : , : ) , intent ( in ) :: P !< partitioned stresses
real ( pReal ) , dimension ( : , : , : , : , : ) , intent ( in ) :: dPdF !< partitioned stiffnesses
2018-11-04 00:38:18 +05:30
integer ( pInt ) , intent ( in ) :: instance
2009-10-12 21:31:49 +05:30
2018-11-04 00:38:18 +05:30
avgP = sum ( P , 3 ) / real ( product ( param ( instance ) % Nconstituents ) , pReal )
dAvgPdAvgF = sum ( dPdF , 5 ) / real ( product ( param ( instance ) % Nconstituents ) , pReal )
2009-10-12 21:31:49 +05:30
2013-10-11 21:31:53 +05:30
end subroutine homogenization_RGC_averageStressAndItsTangent
2009-10-12 21:31:49 +05:30
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
!> @brief return array of homogenization results for post file inclusion
!--------------------------------------------------------------------------------------------------
2019-01-13 03:37:35 +05:30
pure function homogenization_RGC_postResults ( instance , of ) result ( postResults )
2019-01-13 13:44:23 +05:30
2009-10-12 21:31:49 +05:30
implicit none
2013-10-19 00:27:28 +05:30
integer ( pInt ) , intent ( in ) :: &
2019-01-13 03:37:35 +05:30
instance , &
of
integer ( pInt ) :: &
o , c
real ( pReal ) , dimension ( sum ( homogenization_RGC_sizePostResult ( : , instance ) ) ) :: &
2018-08-30 14:20:52 +05:30
postResults
2009-10-12 21:31:49 +05:30
2019-01-13 03:52:13 +05:30
associate ( stt = > state ( instance ) , dst = > dependentState ( instance ) , prm = > param ( instance ) )
2009-10-12 21:31:49 +05:30
c = 0_pInt
2019-01-13 03:37:35 +05:30
2018-08-31 10:05:30 +05:30
outputsLoop : do o = 1_pInt , size ( prm % outputID )
select case ( prm % outputID ( o ) )
2019-01-13 03:37:35 +05:30
2013-12-18 12:58:01 +05:30
case ( constitutivework_ID )
2019-01-13 03:37:35 +05:30
postResults ( c + 1 ) = stt % work ( of )
2012-02-21 22:01:37 +05:30
c = c + 1_pInt
2013-12-18 12:58:01 +05:30
case ( magnitudemismatch_ID )
2019-01-13 03:52:13 +05:30
postResults ( c + 1 : c + 3 ) = dst % mismatch ( 1 : 3 , of )
2012-02-21 22:01:37 +05:30
c = c + 3_pInt
2013-12-18 12:58:01 +05:30
case ( penaltyenergy_ID )
2019-01-13 03:37:35 +05:30
postResults ( c + 1 ) = stt % penaltyEnergy ( of )
2014-08-21 23:18:20 +05:30
c = c + 1_pInt
2013-12-18 12:58:01 +05:30
case ( volumediscrepancy_ID )
2019-01-13 03:52:13 +05:30
postResults ( c + 1 ) = dst % volumeDiscrepancy ( of )
2014-08-21 23:18:20 +05:30
c = c + 1_pInt
2013-12-18 12:58:01 +05:30
case ( averagerelaxrate_ID )
2019-01-13 03:52:13 +05:30
postResults ( c + 1 ) = dst % relaxationrate_avg ( of )
2014-08-21 23:18:20 +05:30
c = c + 1_pInt
2013-12-18 12:58:01 +05:30
case ( maximumrelaxrate_ID )
2019-01-13 03:52:13 +05:30
postResults ( c + 1 ) = dst % relaxationrate_max ( of )
2014-08-21 23:18:20 +05:30
c = c + 1_pInt
2009-10-12 21:31:49 +05:30
end select
2019-01-13 03:37:35 +05:30
2018-08-31 10:05:30 +05:30
enddo outputsLoop
2019-01-13 03:37:35 +05:30
2018-08-30 14:16:30 +05:30
end associate
2019-01-13 03:37:35 +05:30
2013-02-21 03:36:15 +05:30
end function homogenization_RGC_postResults
!--------------------------------------------------------------------------------------------------
!> @brief collect relaxation vectors of an interface
!--------------------------------------------------------------------------------------------------
2018-11-04 12:03:57 +05:30
pure function relaxationVector ( intFace , instance , of )
2013-02-21 03:36:15 +05:30
2009-10-12 21:31:49 +05:30
implicit none
2018-11-04 03:43:20 +05:30
integer ( pInt ) , intent ( in ) :: instance , of
2019-01-13 03:37:35 +05:30
2018-08-30 14:20:52 +05:30
real ( pReal ) , dimension ( 3 ) :: relaxationVector
2013-02-21 03:36:15 +05:30
integer ( pInt ) , dimension ( 4 ) , intent ( in ) :: intFace !< set of interface ID in 4D array (normal and position)
2014-02-08 16:18:09 +05:30
integer ( pInt ) :: &
2018-11-04 03:43:20 +05:30
iNum
2009-10-12 21:31:49 +05:30
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
! collect the interface relaxation vector from the global state array
2019-01-13 03:37:35 +05:30
2018-11-04 12:26:27 +05:30
iNum = interface4to1 ( intFace , param ( instance ) % Nconstituents ) ! identify the position of the interface in global state array
2019-01-13 03:37:35 +05:30
if ( iNum > 0_pInt ) then
relaxationVector = state ( instance ) % relaxationVector ( ( 3 * iNum - 2 ) : ( 3 * iNum ) , of )
else
relaxationVector = 0.0_pReal
endif
2013-02-21 03:36:15 +05:30
2018-08-30 14:20:52 +05:30
end function relaxationVector
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
!> @brief identify the normal of an interface
!--------------------------------------------------------------------------------------------------
2018-11-04 12:03:57 +05:30
pure function interfaceNormal ( intFace , instance , of )
2013-02-21 03:36:15 +05:30
use math , only : &
math_mul33x3
2012-03-09 01:55:28 +05:30
2009-10-12 21:31:49 +05:30
implicit none
2018-08-30 14:20:52 +05:30
real ( pReal ) , dimension ( 3 ) :: interfaceNormal
2013-02-21 03:36:15 +05:30
integer ( pInt ) , dimension ( 4 ) , intent ( in ) :: intFace !< interface ID in 4D array (normal and position)
2014-02-08 16:18:09 +05:30
integer ( pInt ) , intent ( in ) :: &
2018-11-04 03:43:20 +05:30
instance , &
of
integer ( pInt ) :: nPos
2009-10-12 21:31:49 +05:30
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
! get the normal of the interface, identified from the value of intFace(1)
2018-08-30 14:20:52 +05:30
interfaceNormal = 0.0_pReal
2012-02-16 00:28:38 +05:30
nPos = abs ( intFace ( 1 ) ) ! identify the position of the interface in global state array
2018-08-30 21:21:31 +05:30
interfaceNormal ( nPos ) = real ( intFace ( 1 ) / abs ( intFace ( 1 ) ) , pReal ) ! get the normal vector w.r.t. cluster axis
2009-10-12 21:31:49 +05:30
2018-11-04 03:53:52 +05:30
interfaceNormal = math_mul33x3 ( dependentState ( instance ) % orientation ( 1 : 3 , 1 : 3 , of ) , interfaceNormal ) ! map the normal vector into sample coordinate system (basis)
2010-03-24 18:50:12 +05:30
2018-08-30 14:20:52 +05:30
end function interfaceNormal
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
!> @brief collect six faces of a grain in 4D (normal and position)
!--------------------------------------------------------------------------------------------------
2018-11-04 12:03:57 +05:30
pure function getInterface ( iFace , iGrain3 )
2013-02-21 03:36:15 +05:30
2009-10-12 21:31:49 +05:30
implicit none
2018-08-30 14:20:52 +05:30
integer ( pInt ) , dimension ( 4 ) :: getInterface
2014-02-08 16:18:09 +05:30
integer ( pInt ) , dimension ( 3 ) , intent ( in ) :: iGrain3 !< grain ID in 3D array
integer ( pInt ) , intent ( in ) :: iFace !< face index (1..6) mapped like (-e1,-e2,-e3,+e1,+e2,+e3) or iDir = (-1,-2,-3,1,2,3)
integer ( pInt ) :: iDir
2009-10-12 21:31:49 +05:30
!* Direction of interface normal
2012-02-21 22:01:37 +05:30
iDir = ( int ( real ( iFace - 1_pInt , pReal ) / 2.0_pReal , pInt ) + 1_pInt ) * ( - 1_pInt ) ** iFace
2018-08-30 14:20:52 +05:30
getInterface ( 1 ) = iDir
2009-10-12 21:31:49 +05:30
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
! identify the interface position by the direction of its normal
2018-08-30 14:20:52 +05:30
getInterface ( 2 : 4 ) = iGrain3
2018-11-04 12:03:57 +05:30
if ( iDir < 0_pInt ) getInterface ( 1_pInt - iDir ) = getInterface ( 1_pInt - iDir ) - 1_pInt ! to have a correlation with coordinate/position in real space
2009-10-12 21:31:49 +05:30
2018-08-30 14:20:52 +05:30
end function getInterface
2009-10-12 21:31:49 +05:30
2018-11-04 12:41:35 +05:30
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
!> @brief map grain ID from in 1D (global array) to in 3D (local position)
!--------------------------------------------------------------------------------------------------
2018-11-04 12:41:35 +05:30
pure function grain1to3 ( grain1 , nGDim )
2012-03-09 01:55:28 +05:30
2009-10-12 21:31:49 +05:30
implicit none
2018-11-04 12:41:35 +05:30
integer ( pInt ) , dimension ( 3 ) :: grain1to3
integer ( pInt ) , intent ( in ) :: grain1 !< grain ID in 1D array
integer ( pInt ) , dimension ( 3 ) , intent ( in ) :: nGDim
2009-10-12 21:31:49 +05:30
2018-08-30 21:21:31 +05:30
grain1to3 = 1_pInt + [ mod ( ( grain1 - 1_pInt ) , nGDim ( 1 ) ) , &
mod ( ( grain1 - 1_pInt ) / nGDim ( 1 ) , nGDim ( 2 ) ) , &
( grain1 - 1_pInt ) / ( nGDim ( 1 ) * nGDim ( 2 ) ) ]
2009-10-12 21:31:49 +05:30
2018-08-30 14:20:52 +05:30
end function grain1to3
2009-10-12 21:31:49 +05:30
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
!> @brief map grain ID from in 3D (local position) to in 1D (global array)
!--------------------------------------------------------------------------------------------------
2018-11-04 13:49:24 +05:30
integer ( pInt ) pure function grain3to1 ( grain3 , nGDim )
2009-10-12 21:31:49 +05:30
2012-03-09 01:55:28 +05:30
implicit none
2018-11-04 12:41:35 +05:30
integer ( pInt ) , dimension ( 3 ) , intent ( in ) :: grain3 !< grain ID in 3D array (pos.x,pos.y,pos.z)
integer ( pInt ) , dimension ( 3 ) , intent ( in ) :: nGDim
2009-10-12 21:31:49 +05:30
2018-11-04 12:41:35 +05:30
grain3to1 = grain3 ( 1 ) &
+ nGDim ( 1 ) * ( grain3 ( 2 ) - 1_pInt ) &
+ nGDim ( 1 ) * nGDim ( 2 ) * ( grain3 ( 3 ) - 1_pInt )
2009-10-12 21:31:49 +05:30
2018-08-30 14:20:52 +05:30
end function grain3to1
2009-10-12 21:31:49 +05:30
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
!> @brief maps interface ID from 4D (normal and local position) into 1D (global array)
!--------------------------------------------------------------------------------------------------
2018-11-04 12:26:27 +05:30
integer ( pInt ) pure function interface4to1 ( iFace4D , nGDim )
2012-03-09 01:55:28 +05:30
2009-10-12 21:31:49 +05:30
implicit none
2018-11-04 12:26:27 +05:30
integer ( pInt ) , dimension ( 4 ) , intent ( in ) :: iFace4D !< interface ID in 4D array (n.dir,pos.x,pos.y,pos.z)
integer ( pInt ) , dimension ( 3 ) , intent ( in ) :: nGDim
2010-11-26 17:20:20 +05:30
2013-02-21 03:36:15 +05:30
2018-11-04 13:49:24 +05:30
select case ( abs ( iFace4D ( 1 ) ) )
case ( 1_pInt )
if ( ( iFace4D ( 2 ) == 0_pInt ) . or . ( iFace4D ( 2 ) == nGDim ( 1 ) ) ) then
interface4to1 = 0_pInt
else
interface4to1 = iFace4D ( 3 ) + nGDim ( 2 ) * ( iFace4D ( 4 ) - 1_pInt ) &
+ nGDim ( 2 ) * nGDim ( 3 ) * ( iFace4D ( 2 ) - 1_pInt )
endif
case ( 2_pInt )
if ( ( iFace4D ( 3 ) == 0_pInt ) . or . ( iFace4D ( 3 ) == nGDim ( 2 ) ) ) then
interface4to1 = 0_pInt
else
interface4to1 = iFace4D ( 4 ) + nGDim ( 3 ) * ( iFace4D ( 2 ) - 1_pInt ) &
+ nGDim ( 3 ) * nGDim ( 1 ) * ( iFace4D ( 3 ) - 1_pInt ) &
+ ( nGDim ( 1 ) - 1_pInt ) * nGDim ( 2 ) * nGDim ( 3 ) ! total number of interfaces normal //e1
endif
case ( 3_pInt )
if ( ( iFace4D ( 4 ) == 0_pInt ) . or . ( iFace4D ( 4 ) == nGDim ( 3 ) ) ) then
interface4to1 = 0_pInt
else
interface4to1 = iFace4D ( 2 ) + nGDim ( 1 ) * ( iFace4D ( 3 ) - 1_pInt ) &
+ nGDim ( 1 ) * nGDim ( 2 ) * ( iFace4D ( 4 ) - 1_pInt ) &
+ ( nGDim ( 1 ) - 1_pInt ) * nGDim ( 2 ) * nGDim ( 3 ) & ! total number of interfaces normal //e1
+ nGDim ( 1 ) * ( nGDim ( 2 ) - 1_pInt ) * nGDim ( 3 ) ! total number of interfaces normal //e2
endif
case default
interface4to1 = - 1_pInt
end select
2009-10-12 21:31:49 +05:30
2018-08-30 14:20:52 +05:30
end function interface4to1
2009-10-12 21:31:49 +05:30
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
!> @brief maps interface ID from 1D (global array) into 4D (normal and local position)
!--------------------------------------------------------------------------------------------------
2018-11-04 12:41:35 +05:30
pure function interface1to4 ( iFace1D , nGDim )
2012-03-09 01:55:28 +05:30
2009-10-12 21:31:49 +05:30
implicit none
2018-11-04 12:41:35 +05:30
integer ( pInt ) , dimension ( 4 ) :: interface1to4
2018-08-30 21:21:31 +05:30
integer ( pInt ) , intent ( in ) :: iFace1D !< interface ID in 1D array
2018-11-04 12:41:35 +05:30
integer ( pInt ) , dimension ( 3 ) , intent ( in ) :: nGDim
2019-01-13 03:37:35 +05:30
integer ( pInt ) , dimension ( 3 ) :: nIntFace
2009-10-12 21:31:49 +05:30
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
! compute the total number of interfaces, which ...
2018-11-04 13:49:24 +05:30
nIntFace = [ ( nGDim ( 1 ) - 1_pInt ) * nGDim ( 2 ) * nGDim ( 3 ) , & ! ... normal //e1
nGDim ( 1 ) * ( nGDim ( 2 ) - 1_pInt ) * nGDim ( 3 ) , & ! ... normal //e2
nGDim ( 1 ) * nGDim ( 2 ) * ( nGDim ( 3 ) - 1_pInt ) ] ! ... normal //e3
2013-02-21 03:36:15 +05:30
!--------------------------------------------------------------------------------------------------
! get the corresponding interface ID in 4D (normal and local position)
if ( iFace1D > 0 . and . iFace1D < = nIntFace ( 1 ) ) then ! interface with normal //e1
2018-08-30 14:20:52 +05:30
interface1to4 ( 1 ) = 1_pInt
interface1to4 ( 3 ) = mod ( ( iFace1D - 1_pInt ) , nGDim ( 2 ) ) + 1_pInt
interface1to4 ( 4 ) = mod ( &
2012-02-21 22:01:37 +05:30
int ( &
real ( iFace1D - 1_pInt , pReal ) / &
real ( nGDim ( 2 ) , pReal ) &
, pInt ) &
, nGDim ( 3 ) ) + 1_pInt
2018-08-30 14:20:52 +05:30
interface1to4 ( 2 ) = int ( &
2012-02-21 22:01:37 +05:30
real ( iFace1D - 1_pInt , pReal ) / &
real ( nGDim ( 2 ) , pReal ) / &
real ( nGDim ( 3 ) , pReal ) &
, pInt ) + 1_pInt
2013-02-21 03:36:15 +05:30
elseif ( iFace1D > nIntFace ( 1 ) . and . iFace1D < = ( nIntFace ( 2 ) + nIntFace ( 1 ) ) ) then ! interface with normal //e2
2018-08-30 14:20:52 +05:30
interface1to4 ( 1 ) = 2_pInt
interface1to4 ( 4 ) = mod ( ( iFace1D - nIntFace ( 1 ) - 1_pInt ) , nGDim ( 3 ) ) + 1_pInt
interface1to4 ( 2 ) = mod ( &
2012-02-21 22:01:37 +05:30
int ( &
real ( iFace1D - nIntFace ( 1 ) - 1_pInt , pReal ) / &
real ( nGDim ( 3 ) , pReal ) &
, pInt ) &
, nGDim ( 1 ) ) + 1_pInt
2018-08-30 14:20:52 +05:30
interface1to4 ( 3 ) = int ( &
2012-02-21 22:01:37 +05:30
real ( iFace1D - nIntFace ( 1 ) - 1_pInt , pReal ) / &
real ( nGDim ( 3 ) , pReal ) / &
real ( nGDim ( 1 ) , pReal ) &
, pInt ) + 1_pInt
2013-02-21 03:36:15 +05:30
elseif ( iFace1D > nIntFace ( 2 ) + nIntFace ( 1 ) . and . iFace1D < = ( nIntFace ( 3 ) + nIntFace ( 2 ) + nIntFace ( 1 ) ) ) then ! interface with normal //e3
2018-08-30 14:20:52 +05:30
interface1to4 ( 1 ) = 3_pInt
interface1to4 ( 2 ) = mod ( ( iFace1D - nIntFace ( 2 ) - nIntFace ( 1 ) - 1_pInt ) , nGDim ( 1 ) ) + 1_pInt
interface1to4 ( 3 ) = mod ( &
2012-02-21 22:01:37 +05:30
int ( &
real ( iFace1D - nIntFace ( 2 ) - nIntFace ( 1 ) - 1_pInt , pReal ) / &
real ( nGDim ( 1 ) , pReal ) &
, pInt ) &
, nGDim ( 2 ) ) + 1_pInt
2018-08-30 14:20:52 +05:30
interface1to4 ( 4 ) = int ( &
2012-02-21 22:01:37 +05:30
real ( iFace1D - nIntFace ( 2 ) - nIntFace ( 1 ) - 1_pInt , pReal ) / &
real ( nGDim ( 1 ) , pReal ) / &
real ( nGDim ( 2 ) , pReal ) &
, pInt ) + 1_pInt
2009-10-12 21:31:49 +05:30
endif
2018-08-30 14:20:52 +05:30
end function interface1to4
2013-02-21 03:36:15 +05:30
end module homogenization_RGC