223031012
/
DAMASK_EICMD
mirror of https://github.com/achalhp/DAMASK_EICMD.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity

parameters should be spelled in capitals

This commit is contained in:
Martin Diehl 2023-06-04 07:22:25 +02:00
parent 319489fad8
commit 0324e7ece1
60 changed files with 2681 additions and 2681 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
src/HDF5_utilities.f90
View File

@ -135,8 +135,8 @@ subroutine HDF5_utilities_init()
call H5Tget_size_f(H5T_NATIVE_DOUBLE,typeSize, hdferr) call H5Tget_size_f(H5T_NATIVE_DOUBLE,typeSize, hdferr)
call HDF5_chkerr(hdferr) call HDF5_chkerr(hdferr)
if (int(storage_size(0.0_pReal),SIZE_T)/=typeSize*8) & if (int(storage_size(0.0_pREAL),SIZE_T)/=typeSize*8) &
error stop 'pReal does not match H5T_NATIVE_DOUBLE' error stop 'pREAL does not match H5T_NATIVE_DOUBLE'
call H5get_libversion_f(HDF5_major,HDF5_minor,HDF5_release,hdferr) call H5get_libversion_f(HDF5_major,HDF5_minor,HDF5_release,hdferr)
call HDF5_chkerr(hdferr) call HDF5_chkerr(hdferr)
@ -443,7 +443,7 @@ subroutine HDF5_addAttribute_real(loc_id,attrLabel,attrValue,path)
integer(HID_T), intent(in) :: loc_id integer(HID_T), intent(in) :: loc_id
character(len=*), intent(in) :: attrLabel character(len=*), intent(in) :: attrLabel
real(pReal), intent(in) :: attrValue real(pREAL), intent(in) :: attrValue
character(len=*), intent(in), optional :: path character(len=*), intent(in), optional :: path
integer(HID_T) :: attr_id, space_id integer(HID_T) :: attr_id, space_id
@ -576,7 +576,7 @@ subroutine HDF5_addAttribute_real_array(loc_id,attrLabel,attrValue,path)
integer(HID_T), intent(in) :: loc_id integer(HID_T), intent(in) :: loc_id
character(len=*), intent(in) :: attrLabel character(len=*), intent(in) :: attrLabel
real(pReal), intent(in), dimension(:) :: attrValue real(pREAL), intent(in), dimension(:) :: attrValue
character(len=*), intent(in), optional :: path character(len=*), intent(in), optional :: path
integer(HSIZE_T),dimension(1) :: array_size integer(HSIZE_T),dimension(1) :: array_size
@ -640,7 +640,7 @@ end subroutine HDF5_setLink
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine HDF5_read_real1(dataset,loc_id,datasetName,parallel) subroutine HDF5_read_real1(dataset,loc_id,datasetName,parallel)
real(pReal), intent(out), dimension(:) :: dataset !< data read from file real(pREAL), intent(out), dimension(:) :: dataset !< data read from file
integer(HID_T), intent(in) :: loc_id !< file or group handle integer(HID_T), intent(in) :: loc_id !< file or group handle
character(len=*), intent(in) :: datasetName !< name of the dataset in the file character(len=*), intent(in) :: datasetName !< name of the dataset in the file
logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes
@ -674,7 +674,7 @@ end subroutine HDF5_read_real1
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine HDF5_read_real2(dataset,loc_id,datasetName,parallel) subroutine HDF5_read_real2(dataset,loc_id,datasetName,parallel)
real(pReal), intent(out), dimension(:,:) :: dataset !< data read from file real(pREAL), intent(out), dimension(:,:) :: dataset !< data read from file
integer(HID_T), intent(in) :: loc_id !< file or group handle integer(HID_T), intent(in) :: loc_id !< file or group handle
character(len=*), intent(in) :: datasetName !< name of the dataset in the file character(len=*), intent(in) :: datasetName !< name of the dataset in the file
logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes
@ -708,7 +708,7 @@ end subroutine HDF5_read_real2
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine HDF5_read_real3(dataset,loc_id,datasetName,parallel) subroutine HDF5_read_real3(dataset,loc_id,datasetName,parallel)
real(pReal), intent(out), dimension(:,:,:) :: dataset !< data read from file real(pREAL), intent(out), dimension(:,:,:) :: dataset !< data read from file
integer(HID_T), intent(in) :: loc_id !< file or group handle integer(HID_T), intent(in) :: loc_id !< file or group handle
character(len=*), intent(in) :: datasetName !< name of the dataset in the file character(len=*), intent(in) :: datasetName !< name of the dataset in the file
logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes
@ -742,7 +742,7 @@ end subroutine HDF5_read_real3
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine HDF5_read_real4(dataset,loc_id,datasetName,parallel) subroutine HDF5_read_real4(dataset,loc_id,datasetName,parallel)
real(pReal), intent(out), dimension(:,:,:,:) :: dataset !< read data real(pREAL), intent(out), dimension(:,:,:,:) :: dataset !< read data
integer(HID_T), intent(in) :: loc_id !< file or group handle integer(HID_T), intent(in) :: loc_id !< file or group handle
character(len=*), intent(in) :: datasetName !< name of the dataset in the file character(len=*), intent(in) :: datasetName !< name of the dataset in the file
logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes
@ -777,7 +777,7 @@ end subroutine HDF5_read_real4
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine HDF5_read_real5(dataset,loc_id,datasetName,parallel) subroutine HDF5_read_real5(dataset,loc_id,datasetName,parallel)
real(pReal), intent(out), dimension(:,:,:,:,:) :: dataset !< data read from file real(pREAL), intent(out), dimension(:,:,:,:,:) :: dataset !< data read from file
integer(HID_T), intent(in) :: loc_id !< file or group handle integer(HID_T), intent(in) :: loc_id !< file or group handle
character(len=*), intent(in) :: datasetName !< name of the dataset in the file character(len=*), intent(in) :: datasetName !< name of the dataset in the file
logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes
@ -812,7 +812,7 @@ end subroutine HDF5_read_real5
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine HDF5_read_real6(dataset,loc_id,datasetName,parallel) subroutine HDF5_read_real6(dataset,loc_id,datasetName,parallel)
real(pReal), intent(out), dimension(:,:,:,:,:,:) :: dataset !< data read from file real(pREAL), intent(out), dimension(:,:,:,:,:,:) :: dataset !< data read from file
integer(HID_T), intent(in) :: loc_id !< file or group handle integer(HID_T), intent(in) :: loc_id !< file or group handle
character(len=*), intent(in) :: datasetName !< name of the dataset in the file character(len=*), intent(in) :: datasetName !< name of the dataset in the file
logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes
@ -847,7 +847,7 @@ end subroutine HDF5_read_real6
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine HDF5_read_real7(dataset,loc_id,datasetName,parallel) subroutine HDF5_read_real7(dataset,loc_id,datasetName,parallel)
real(pReal), intent(out), dimension(:,:,:,:,:,:,:) :: dataset !< data read from file real(pREAL), intent(out), dimension(:,:,:,:,:,:,:) :: dataset !< data read from file
integer(HID_T), intent(in) :: loc_id !< file or group handle integer(HID_T), intent(in) :: loc_id !< file or group handle
character(len=*), intent(in) :: datasetName !< name of the dataset in the file character(len=*), intent(in) :: datasetName !< name of the dataset in the file
logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes
@ -1126,7 +1126,7 @@ end subroutine HDF5_read_int7
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine HDF5_write_real1(dataset,loc_id,datasetName,parallel) subroutine HDF5_write_real1(dataset,loc_id,datasetName,parallel)
real(pReal), intent(in), dimension(:) :: dataset !< data written to file real(pREAL), intent(in), dimension(:) :: dataset !< data written to file
integer(HID_T), intent(in) :: loc_id !< file or group handle integer(HID_T), intent(in) :: loc_id !< file or group handle
character(len=*), intent(in) :: datasetName !< name of the dataset in the file character(len=*), intent(in) :: datasetName !< name of the dataset in the file
logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes
@ -1163,7 +1163,7 @@ end subroutine HDF5_write_real1
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine HDF5_write_real2(dataset,loc_id,datasetName,parallel) subroutine HDF5_write_real2(dataset,loc_id,datasetName,parallel)
real(pReal), intent(in), dimension(:,:) :: dataset !< data written to file real(pREAL), intent(in), dimension(:,:) :: dataset !< data written to file
integer(HID_T), intent(in) :: loc_id !< file or group handle integer(HID_T), intent(in) :: loc_id !< file or group handle
character(len=*), intent(in) :: datasetName !< name of the dataset in the file character(len=*), intent(in) :: datasetName !< name of the dataset in the file
logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes
@ -1200,7 +1200,7 @@ end subroutine HDF5_write_real2
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine HDF5_write_real3(dataset,loc_id,datasetName,parallel) subroutine HDF5_write_real3(dataset,loc_id,datasetName,parallel)
real(pReal), intent(in), dimension(:,:,:) :: dataset !< data written to file real(pREAL), intent(in), dimension(:,:,:) :: dataset !< data written to file
integer(HID_T), intent(in) :: loc_id !< file or group handle integer(HID_T), intent(in) :: loc_id !< file or group handle
character(len=*), intent(in) :: datasetName !< name of the dataset in the file character(len=*), intent(in) :: datasetName !< name of the dataset in the file
logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes
@ -1237,7 +1237,7 @@ end subroutine HDF5_write_real3
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine HDF5_write_real4(dataset,loc_id,datasetName,parallel) subroutine HDF5_write_real4(dataset,loc_id,datasetName,parallel)
real(pReal), intent(in), dimension(:,:,:,:) :: dataset !< data written to file real(pREAL), intent(in), dimension(:,:,:,:) :: dataset !< data written to file
integer(HID_T), intent(in) :: loc_id !< file or group handle integer(HID_T), intent(in) :: loc_id !< file or group handle
character(len=*), intent(in) :: datasetName !< name of the dataset in the file character(len=*), intent(in) :: datasetName !< name of the dataset in the file
logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes
@ -1275,7 +1275,7 @@ end subroutine HDF5_write_real4
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine HDF5_write_real5(dataset,loc_id,datasetName,parallel) subroutine HDF5_write_real5(dataset,loc_id,datasetName,parallel)
real(pReal), intent(in), dimension(:,:,:,:,:) :: dataset !< data written to file real(pREAL), intent(in), dimension(:,:,:,:,:) :: dataset !< data written to file
integer(HID_T), intent(in) :: loc_id !< file or group handle integer(HID_T), intent(in) :: loc_id !< file or group handle
character(len=*), intent(in) :: datasetName !< name of the dataset in the file character(len=*), intent(in) :: datasetName !< name of the dataset in the file
logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes
@ -1312,7 +1312,7 @@ end subroutine HDF5_write_real5
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine HDF5_write_real6(dataset,loc_id,datasetName,parallel) subroutine HDF5_write_real6(dataset,loc_id,datasetName,parallel)
real(pReal), intent(in), dimension(:,:,:,:,:,:) :: dataset !< data written to file real(pREAL), intent(in), dimension(:,:,:,:,:,:) :: dataset !< data written to file
integer(HID_T), intent(in) :: loc_id !< file or group handle integer(HID_T), intent(in) :: loc_id !< file or group handle
character(len=*), intent(in) :: datasetName !< name of the dataset in the file character(len=*), intent(in) :: datasetName !< name of the dataset in the file
logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes
@ -1349,7 +1349,7 @@ end subroutine HDF5_write_real6
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine HDF5_write_real7(dataset,loc_id,datasetName,parallel) subroutine HDF5_write_real7(dataset,loc_id,datasetName,parallel)
real(pReal), intent(in), dimension(:,:,:,:,:,:,:) :: dataset !< data written to file real(pREAL), intent(in), dimension(:,:,:,:,:,:,:) :: dataset !< data written to file
integer(HID_T), intent(in) :: loc_id !< file or group handle integer(HID_T), intent(in) :: loc_id !< file or group handle
character(len=*), intent(in) :: datasetName !< name of the dataset in the file character(len=*), intent(in) :: datasetName !< name of the dataset in the file
logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes
@ -1388,7 +1388,7 @@ end subroutine HDF5_write_real7
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine HDF5_write_real(dataset,loc_id,datasetName,parallel) subroutine HDF5_write_real(dataset,loc_id,datasetName,parallel)
real(pReal), intent(in), dimension(..) :: dataset !< data written to file real(pREAL), intent(in), dimension(..) :: dataset !< data written to file
integer(HID_T), intent(in) :: loc_id !< file or group handle integer(HID_T), intent(in) :: loc_id !< file or group handle
character(len=*), intent(in) :: datasetName !< name of the dataset in the file character(len=*), intent(in) :: datasetName !< name of the dataset in the file
logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes

20
src/IO.f90
View File

@ -274,7 +274,7 @@ end function IO_intValue
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Read real value at myChunk from string. !> @brief Read real value at myChunk from string.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
real(pReal) function IO_realValue(str,chunkPos,myChunk) real(pREAL) function IO_realValue(str,chunkPos,myChunk)
character(len=*), intent(in) :: str !< raw input with known start and end of each chunk character(len=*), intent(in) :: str !< raw input with known start and end of each chunk
integer, dimension(:), intent(in) :: chunkPos !< positions of start and end of each tag/chunk in given string integer, dimension(:), intent(in) :: chunkPos !< positions of start and end of each tag/chunk in given string
@ -373,7 +373,7 @@ end function IO_strAsInt
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Return real value from given string. !> @brief Return real value from given string.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
real(pReal) function IO_strAsReal(str) real(pREAL) function IO_strAsReal(str)
character(len=*), intent(in) :: str !< string for conversion to real value character(len=*), intent(in) :: str !< string for conversion to real value
@ -385,7 +385,7 @@ real(pReal) function IO_strAsReal(str)
read(str,*,iostat=readStatus) IO_strAsReal read(str,*,iostat=readStatus) IO_strAsReal
if (readStatus /= 0) call IO_error(112,str) if (readStatus /= 0) call IO_error(112,str)
else valid else valid
IO_strAsReal = 0.0_pReal IO_strAsReal = 0.0_pREAL
call IO_error(112,str) call IO_error(112,str)
end if valid end if valid
@ -733,12 +733,12 @@ subroutine selfTest()
character(len=:), allocatable :: str,out character(len=:), allocatable :: str,out
if (dNeq(1.0_pReal, IO_strAsReal('1.0'))) error stop 'IO_strAsReal' if (dNeq(1.0_pREAL, IO_strAsReal('1.0'))) error stop 'IO_strAsReal'
if (dNeq(1.0_pReal, IO_strAsReal('1e0'))) error stop 'IO_strAsReal' if (dNeq(1.0_pREAL, IO_strAsReal('1e0'))) error stop 'IO_strAsReal'
if (dNeq(0.1_pReal, IO_strAsReal('1e-1'))) error stop 'IO_strAsReal' if (dNeq(0.1_pREAL, IO_strAsReal('1e-1'))) error stop 'IO_strAsReal'
if (dNeq(0.1_pReal, IO_strAsReal('1.0e-1'))) error stop 'IO_strAsReal' if (dNeq(0.1_pREAL, IO_strAsReal('1.0e-1'))) error stop 'IO_strAsReal'
if (dNeq(0.1_pReal, IO_strAsReal('1.00e-1'))) error stop 'IO_strAsReal' if (dNeq(0.1_pREAL, IO_strAsReal('1.00e-1'))) error stop 'IO_strAsReal'
if (dNeq(10._pReal, IO_strAsReal(' 1.0e+1 '))) error stop 'IO_strAsReal' if (dNeq(10._pREAL, IO_strAsReal(' 1.0e+1 '))) error stop 'IO_strAsReal'
if (3112019 /= IO_strAsInt( '3112019')) error stop 'IO_strAsInt' if (3112019 /= IO_strAsInt( '3112019')) error stop 'IO_strAsInt'
if (3112019 /= IO_strAsInt(' 3112019')) error stop 'IO_strAsInt' if (3112019 /= IO_strAsInt(' 3112019')) error stop 'IO_strAsInt'
@ -760,7 +760,7 @@ subroutine selfTest()
str = ' 1.0 xxx' str = ' 1.0 xxx'
chunkPos = IO_strPos(str) chunkPos = IO_strPos(str)
if (dNeq(1.0_pReal,IO_realValue(str,chunkPos,1))) error stop 'IO_realValue' if (dNeq(1.0_pREAL,IO_realValue(str,chunkPos,1))) error stop 'IO_realValue'
str = 'M 3112019 F' str = 'M 3112019 F'
chunkPos = IO_strPos(str) chunkPos = IO_strPos(str)

26
src/LAPACK_interface.f90
View File

@ -12,11 +12,11 @@ module LAPACK_interface
character, intent(in) :: jobvl,jobvr character, intent(in) :: jobvl,jobvr
integer, intent(in) :: n,lda,ldvl,ldvr,lwork integer, intent(in) :: n,lda,ldvl,ldvr,lwork
real(pReal), intent(inout), dimension(lda,n) :: a real(pREAL), intent(inout), dimension(lda,n) :: a
real(pReal), intent(out), dimension(n) :: wr,wi real(pREAL), intent(out), dimension(n) :: wr,wi
real(pReal), intent(out), dimension(ldvl,n) :: vl real(pREAL), intent(out), dimension(ldvl,n) :: vl
real(pReal), intent(out), dimension(ldvr,n) :: vr real(pREAL), intent(out), dimension(ldvr,n) :: vr
real(pReal), intent(out), dimension(max(1,lwork)) :: work real(pREAL), intent(out), dimension(max(1,lwork)) :: work
integer, intent(out) :: info integer, intent(out) :: info
end subroutine dgeev end subroutine dgeev
@ -25,9 +25,9 @@ module LAPACK_interface
implicit none(type,external) implicit none(type,external)
integer, intent(in) :: n,nrhs,lda,ldb integer, intent(in) :: n,nrhs,lda,ldb
real(pReal), intent(inout), dimension(lda,n) :: a real(pREAL), intent(inout), dimension(lda,n) :: a
integer, intent(out), dimension(n) :: ipiv integer, intent(out), dimension(n) :: ipiv
real(pReal), intent(inout), dimension(ldb,nrhs) :: b real(pREAL), intent(inout), dimension(ldb,nrhs) :: b
integer, intent(out) :: info integer, intent(out) :: info
end subroutine dgesv end subroutine dgesv
@ -36,7 +36,7 @@ module LAPACK_interface
implicit none(type,external) implicit none(type,external)
integer, intent(in) :: m,n,lda integer, intent(in) :: m,n,lda
real(pReal), intent(inout), dimension(lda,n) :: a real(pREAL), intent(inout), dimension(lda,n) :: a
integer, intent(out), dimension(min(m,n)) :: ipiv integer, intent(out), dimension(min(m,n)) :: ipiv
integer, intent(out) :: info integer, intent(out) :: info
end subroutine dgetrf end subroutine dgetrf
@ -46,9 +46,9 @@ module LAPACK_interface
implicit none(type,external) implicit none(type,external)
integer, intent(in) :: n,lda,lwork integer, intent(in) :: n,lda,lwork
real(pReal), intent(inout), dimension(lda,n) :: a real(pREAL), intent(inout), dimension(lda,n) :: a
integer, intent(in), dimension(n) :: ipiv integer, intent(in), dimension(n) :: ipiv
real(pReal), intent(out), dimension(max(1,lwork)) :: work real(pREAL), intent(out), dimension(max(1,lwork)) :: work
integer, intent(out) :: info integer, intent(out) :: info
end subroutine dgetri end subroutine dgetri
@ -58,9 +58,9 @@ module LAPACK_interface
character, intent(in) :: jobz,uplo character, intent(in) :: jobz,uplo
integer, intent(in) :: n,lda,lwork integer, intent(in) :: n,lda,lwork
real(pReal), intent(inout), dimension(lda,n) :: a real(pREAL), intent(inout), dimension(lda,n) :: a
real(pReal), intent(out), dimension(n) :: w real(pREAL), intent(out), dimension(n) :: w
real(pReal), intent(out), dimension(max(1,lwork)) :: work real(pREAL), intent(out), dimension(max(1,lwork)) :: work
integer, intent(out) :: info integer, intent(out) :: info
end subroutine dsyev end subroutine dsyev

44
src/Marc/DAMASK_Marc.f90
View File

@ -233,32 +233,32 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, &
matus, & !< (1) user material identification number, (2) internal material identification number matus, & !< (1) user material identification number, (2) internal material identification number
kcus, & !< (1) layer number, (2) internal layer number kcus, & !< (1) layer number, (2) internal layer number
lclass !< (1) element class, (2) 0: displacement, 1: low order Herrmann, 2: high order Herrmann lclass !< (1) element class, (2) 0: displacement, 1: low order Herrmann, 2: high order Herrmann
real(pReal), dimension(*), intent(in) :: & ! has dimension(1) according to MSC.Marc 2012 Manual D, but according to example hypela2.f dimension(*) real(pREAL), dimension(*), intent(in) :: & ! has dimension(1) according to MSC.Marc 2012 Manual D, but according to example hypela2.f dimension(*)
e, & !< total elastic strain e, & !< total elastic strain
de, & !< increment of strain de, & !< increment of strain
dt !< increment of state variables dt !< increment of state variables
real(pReal), dimension(itel), intent(in) :: & ! according to MSC.Marc 2012 Manual D real(pREAL), dimension(itel), intent(in) :: & ! according to MSC.Marc 2012 Manual D
strechn, & !< square of principal stretch ratios, lambda(i) at t=n strechn, & !< square of principal stretch ratios, lambda(i) at t=n
strechn1 !< square of principal stretch ratios, lambda(i) at t=n+1 strechn1 !< square of principal stretch ratios, lambda(i) at t=n+1
real(pReal), dimension(3,3), intent(in) :: & ! has dimension(itel,*) according to MSC.Marc 2012 Manual D, but we alway assume dimension(3,3) real(pREAL), dimension(3,3), intent(in) :: & ! has dimension(itel,*) according to MSC.Marc 2012 Manual D, but we alway assume dimension(3,3)
ffn, & !< deformation gradient at t=n ffn, & !< deformation gradient at t=n
ffn1 !< deformation gradient at t=n+1 ffn1 !< deformation gradient at t=n+1
real(pReal), dimension(itel,*), intent(in) :: & ! according to MSC.Marc 2012 Manual D real(pREAL), dimension(itel,*), intent(in) :: & ! according to MSC.Marc 2012 Manual D
frotn, & !< rotation tensor at t=n frotn, & !< rotation tensor at t=n
eigvn, & !< i principal direction components for j eigenvalues at t=n eigvn, & !< i principal direction components for j eigenvalues at t=n
frotn1, & !< rotation tensor at t=n+1 frotn1, & !< rotation tensor at t=n+1
eigvn1 !< i principal direction components for j eigenvalues at t=n+1 eigvn1 !< i principal direction components for j eigenvalues at t=n+1
real(pReal), dimension(ndeg,*), intent(in) :: & ! according to MSC.Marc 2012 Manual D real(pREAL), dimension(ndeg,*), intent(in) :: & ! according to MSC.Marc 2012 Manual D
disp, & !< incremental displacements disp, & !< incremental displacements
dispt !< displacements at t=n (at assembly, lovl=4) and displacements at t=n+1 (at stress recovery, lovl=6) dispt !< displacements at t=n (at assembly, lovl=4) and displacements at t=n+1 (at stress recovery, lovl=6)
real(pReal), dimension(ncrd,*), intent(in) :: & ! according to MSC.Marc 2012 Manual D real(pREAL), dimension(ncrd,*), intent(in) :: & ! according to MSC.Marc 2012 Manual D
coord !< coordinates coord !< coordinates
real(pReal), dimension(*), intent(inout) :: & ! according to MSC.Marc 2012 Manual D real(pREAL), dimension(*), intent(inout) :: & ! according to MSC.Marc 2012 Manual D
t !< state variables (comes in at t=n, must be updated to have state variables at t=n+1) t !< state variables (comes in at t=n, must be updated to have state variables at t=n+1)
real(pReal), dimension(ndi+nshear), intent(out) :: & ! has dimension(*) according to MSC.Marc 2012 Manual D, but we need to loop over it real(pREAL), dimension(ndi+nshear), intent(out) :: & ! has dimension(*) according to MSC.Marc 2012 Manual D, but we need to loop over it
s, & !< stress - should be updated by user s, & !< stress - should be updated by user
g !< change in stress due to temperature effects g !< change in stress due to temperature effects
real(pReal), dimension(ngens,ngens), intent(out) :: & ! according to MSC.Marc 2012 Manual D, but according to example hypela2.f dimension(ngens,*) real(pREAL), dimension(ngens,ngens), intent(out) :: & ! according to MSC.Marc 2012 Manual D, but according to example hypela2.f dimension(ngens,*)
d !< stress-strain law to be formed d !< stress-strain law to be formed
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
@ -269,17 +269,17 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, &
#include QUOTE(PASTE(include/creeps,MARC4DAMASK)) ! creeps is needed for timinc (time increment) #include QUOTE(PASTE(include/creeps,MARC4DAMASK)) ! creeps is needed for timinc (time increment)
logical :: cutBack logical :: cutBack
real(pReal), dimension(6) :: stress real(pREAL), dimension(6) :: stress
real(pReal), dimension(6,6) :: ddsdde real(pREAL), dimension(6,6) :: ddsdde
integer :: computationMode, i, node, CPnodeID integer :: computationMode, i, node, CPnodeID
integer(pI32) :: defaultNumThreadsInt !< default value set by Marc integer(pI32) :: defaultNumThreadsInt !< default value set by Marc
integer, save :: & integer, save :: &
theInc = -1, & !< needs description theInc = -1, & !< needs description
lastLovl = 0 !< lovl in previous call to marc hypela2 lastLovl = 0 !< lovl in previous call to marc hypela2
real(pReal), save :: & real(pREAL), save :: &
theTime = 0.0_pReal, & !< needs description theTime = 0.0_pREAL, & !< needs description
theDelta = 0.0_pReal theDelta = 0.0_pREAL
logical, save :: & logical, save :: &
lastIncConverged = .false., & !< needs description lastIncConverged = .false., & !< needs description
outdatedByNewInc = .false., & !< needs description outdatedByNewInc = .false., & !< needs description
@ -351,8 +351,8 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, &
d = ddsdde(1:ngens,1:ngens) d = ddsdde(1:ngens,1:ngens)
s = stress(1:ndi+nshear) s = stress(1:ndi+nshear)
g = 0.0_pReal g = 0.0_pREAL
if (symmetricSolver) d = 0.5_pReal*(d+transpose(d)) if (symmetricSolver) d = 0.5_pREAL*(d+transpose(d))
call omp_set_num_threads(defaultNumThreadsInt) ! reset number of threads to stored default value call omp_set_num_threads(defaultNumThreadsInt) ! reset number of threads to stored default value
@ -368,18 +368,18 @@ subroutine flux(f,ts,n,time)
use discretization_Marc use discretization_Marc
implicit none(type,external) implicit none(type,external)
real(pReal), dimension(6), intent(in) :: & real(pREAL), dimension(6), intent(in) :: &
ts ts
integer(pI64), dimension(10), intent(in) :: & integer(pI64), dimension(10), intent(in) :: &
n n
real(pReal), intent(in) :: & real(pREAL), intent(in) :: &
time time
real(pReal), dimension(2), intent(out) :: & real(pREAL), dimension(2), intent(out) :: &
f f
f(1) = homogenization_f_T(discretization_Marc_FEM2DAMASK_cell(int(n(3)),int(n(1)))) f(1) = homogenization_f_T(discretization_Marc_FEM2DAMASK_cell(int(n(3)),int(n(1))))
f(2) = 0.0_pReal f(2) = 0.0_pREAL
end subroutine flux end subroutine flux
@ -402,7 +402,7 @@ subroutine uedinc(inc,incsub)
integer :: n, nqncomp, nqdatatype integer :: n, nqncomp, nqdatatype
integer, save :: inc_written integer, save :: inc_written
real(pReal), allocatable, dimension(:,:) :: d_n real(pREAL), allocatable, dimension(:,:) :: d_n
#include QUOTE(PASTE(include/creeps,MARC4DAMASK)) ! creeps is needed for timinc (time increment) #include QUOTE(PASTE(include/creeps,MARC4DAMASK)) ! creeps is needed for timinc (time increment)
@ -411,7 +411,7 @@ subroutine uedinc(inc,incsub)
do n = lbound(discretization_Marc_FEM2DAMASK_node,1), ubound(discretization_Marc_FEM2DAMASK_node,1) do n = lbound(discretization_Marc_FEM2DAMASK_node,1), ubound(discretization_Marc_FEM2DAMASK_node,1)
if (discretization_Marc_FEM2DAMASK_node(n) /= -1) then if (discretization_Marc_FEM2DAMASK_node(n) /= -1) then
call nodvar(1,n,d_n(1:3,discretization_Marc_FEM2DAMASK_node(n)),nqncomp,nqdatatype) call nodvar(1,n,d_n(1:3,discretization_Marc_FEM2DAMASK_node(n)),nqncomp,nqdatatype)
if (nqncomp == 2) d_n(3,discretization_Marc_FEM2DAMASK_node(n)) = 0.0_pReal if (nqncomp == 2) d_n(3,discretization_Marc_FEM2DAMASK_node(n)) = 0.0_pREAL
end if end if
end do end do

62
src/Marc/discretization_Marc.f90
View File

@ -20,7 +20,7 @@ module discretization_Marc
implicit none(type,external) implicit none(type,external)
private private
real(pReal), public, protected :: & real(pREAL), public, protected :: &
mesh_unitlength !< physical length of one unit in mesh MD: needs systematic_name mesh_unitlength !< physical length of one unit in mesh MD: needs systematic_name
integer, dimension(:), allocatable, public, protected :: & integer, dimension(:), allocatable, public, protected :: &
@ -51,7 +51,7 @@ contains
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine discretization_Marc_init subroutine discretization_Marc_init
real(pReal), dimension(:,:), allocatable :: & real(pREAL), dimension(:,:), allocatable :: &
node0_elem, & !< node x,y,z coordinates (initially!) node0_elem, & !< node x,y,z coordinates (initially!)
node0_cell node0_cell
type(tElement) :: elem type(tElement) :: elem
@ -61,11 +61,11 @@ subroutine discretization_Marc_init
integer:: & integer:: &
Nelems !< total number of elements in the mesh Nelems !< total number of elements in the mesh
real(pReal), dimension(:,:), allocatable :: & real(pREAL), dimension(:,:), allocatable :: &
IP_reshaped IP_reshaped
integer, dimension(:,:), allocatable :: & integer, dimension(:,:), allocatable :: &
connectivity_elem connectivity_elem
real(pReal), dimension(:,:,:,:), allocatable :: & real(pREAL), dimension(:,:,:,:), allocatable :: &
unscaledNormals unscaledNormals
type(tDict), pointer :: & type(tDict), pointer :: &
@ -75,8 +75,8 @@ subroutine discretization_Marc_init
print'(/,a)', ' <<<+- discretization_Marc init -+>>>'; flush(6) print'(/,a)', ' <<<+- discretization_Marc init -+>>>'; flush(6)
num_commercialFEM => config_numerics%get_dict('commercialFEM',defaultVal = emptyDict) num_commercialFEM => config_numerics%get_dict('commercialFEM',defaultVal = emptyDict)
mesh_unitlength = num_commercialFEM%get_asReal('unitlength',defaultVal=1.0_pReal) ! set physical extent of a length unit in mesh mesh_unitlength = num_commercialFEM%get_asReal('unitlength',defaultVal=1.0_pREAL) ! set physical extent of a length unit in mesh
if (mesh_unitlength <= 0.0_pReal) call IO_error(301,'unitlength') if (mesh_unitlength <= 0.0_pREAL) call IO_error(301,'unitlength')
call inputRead(elem,node0_elem,connectivity_elem,materialAt) call inputRead(elem,node0_elem,connectivity_elem,materialAt)
nElems = size(connectivity_elem,2) nElems = size(connectivity_elem,2)
@ -113,9 +113,9 @@ end subroutine discretization_Marc_init
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine discretization_Marc_updateNodeAndIpCoords(d_n) subroutine discretization_Marc_updateNodeAndIpCoords(d_n)
real(pReal), dimension(:,:), intent(in) :: d_n real(pREAL), dimension(:,:), intent(in) :: d_n
real(pReal), dimension(:,:), allocatable :: node_cell real(pREAL), dimension(:,:), allocatable :: node_cell
node_cell = buildCellNodes(discretization_NodeCoords0(1:3,1:maxval(discretization_Marc_FEM2DAMASK_node)) + d_n) node_cell = buildCellNodes(discretization_NodeCoords0(1:3,1:maxval(discretization_Marc_FEM2DAMASK_node)) + d_n)
@ -134,7 +134,7 @@ function discretization_Marc_FEM2DAMASK_cell(IP_FEM,elem_FEM) result(cell)
integer, intent(in) :: IP_FEM, elem_FEM integer, intent(in) :: IP_FEM, elem_FEM
integer :: cell integer :: cell
real(pReal), dimension(:,:), allocatable :: node_cell real(pREAL), dimension(:,:), allocatable :: node_cell
cell = (discretization_Marc_FEM2DAMASK_elem(elem_FEM)-1)*discretization_nIPs + IP_FEM cell = (discretization_Marc_FEM2DAMASK_elem(elem_FEM)-1)*discretization_nIPs + IP_FEM
@ -155,7 +155,7 @@ subroutine writeGeometry(elem, &
integer, dimension(:,:), intent(in) :: & integer, dimension(:,:), intent(in) :: &
connectivity_elem, & connectivity_elem, &
connectivity_cell_reshaped connectivity_cell_reshaped
real(pReal), dimension(:,:), intent(in) :: & real(pREAL), dimension(:,:), intent(in) :: &
coordinates_nodes, & coordinates_nodes, &
coordinates_points coordinates_points
@ -187,7 +187,7 @@ end subroutine writeGeometry
subroutine inputRead(elem,node0_elem,connectivity_elem,materialAt) subroutine inputRead(elem,node0_elem,connectivity_elem,materialAt)
type(tElement), intent(out) :: elem type(tElement), intent(out) :: elem
real(pReal), dimension(:,:), allocatable, intent(out) :: & real(pREAL), dimension(:,:), allocatable, intent(out) :: &
node0_elem !< node x,y,z coordinates (initially!) node0_elem !< node x,y,z coordinates (initially!)
integer, dimension(:,:), allocatable, intent(out) :: & integer, dimension(:,:), allocatable, intent(out) :: &
connectivity_elem connectivity_elem
@ -535,7 +535,7 @@ end subroutine inputRead_mapNodes
subroutine inputRead_elemNodes(nodes, & subroutine inputRead_elemNodes(nodes, &
nNode,fileContent) nNode,fileContent)
real(pReal), allocatable, dimension(:,:), intent(out) :: nodes real(pREAL), allocatable, dimension(:,:), intent(out) :: nodes
integer, intent(in) :: nNode integer, intent(in) :: nNode
character(len=*), dimension(:), intent(in) :: fileContent !< file content, separated per lines character(len=*), dimension(:), intent(in) :: fileContent !< file content, separated per lines
@ -914,8 +914,8 @@ end subroutine buildCells
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function buildCellNodes(node_elem) pure function buildCellNodes(node_elem)
real(pReal), dimension(:,:), intent(in) :: node_elem !< element nodes real(pREAL), dimension(:,:), intent(in) :: node_elem !< element nodes
real(pReal), dimension(:,:), allocatable :: buildCellNodes !< cell node coordinates real(pREAL), dimension(:,:), allocatable :: buildCellNodes !< cell node coordinates
integer :: i, j, k, n integer :: i, j, k, n
@ -927,13 +927,13 @@ pure function buildCellNodes(node_elem)
do i = 1, size(cellNodeDefinition) do i = 1, size(cellNodeDefinition)
do j = 1, size(cellNodeDefinition(i)%parents,1) do j = 1, size(cellNodeDefinition(i)%parents,1)
n = n+1 n = n+1
buildCellNodes(:,n) = 0.0_pReal buildCellNodes(:,n) = 0.0_pREAL
do k = 1, size(cellNodeDefinition(i)%parents,2) do k = 1, size(cellNodeDefinition(i)%parents,2)
buildCellNodes(:,n) = buildCellNodes(:,n) & buildCellNodes(:,n) = buildCellNodes(:,n) &
+ buildCellNodes(:,cellNodeDefinition(i)%parents(j,k)) & + buildCellNodes(:,cellNodeDefinition(i)%parents(j,k)) &
* real(cellNodeDefinition(i)%weights(j,k),pReal) * real(cellNodeDefinition(i)%weights(j,k),pREAL)
end do end do
buildCellNodes(:,n) = buildCellNodes(:,n)/real(sum(cellNodeDefinition(i)%weights(j,:)),pReal) buildCellNodes(:,n) = buildCellNodes(:,n)/real(sum(cellNodeDefinition(i)%weights(j,:)),pREAL)
end do end do
end do end do
@ -945,8 +945,8 @@ end function buildCellNodes
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function buildIPcoordinates(node_cell) pure function buildIPcoordinates(node_cell)
real(pReal), dimension(:,:), intent(in) :: node_cell !< cell node coordinates real(pREAL), dimension(:,:), intent(in) :: node_cell !< cell node coordinates
real(pReal), dimension(:,:), allocatable :: buildIPcoordinates !< cell-center/IP coordinates real(pREAL), dimension(:,:), allocatable :: buildIPcoordinates !< cell-center/IP coordinates
integer, dimension(:,:), allocatable :: connectivity_cell_reshaped integer, dimension(:,:), allocatable :: connectivity_cell_reshaped
integer :: i, n, NcellNodesPerCell,Ncells integer :: i, n, NcellNodesPerCell,Ncells
@ -959,12 +959,12 @@ pure function buildIPcoordinates(node_cell)
allocate(buildIPcoordinates(3,Ncells)) allocate(buildIPcoordinates(3,Ncells))
do i = 1, size(connectivity_cell_reshaped,2) do i = 1, size(connectivity_cell_reshaped,2)
buildIPcoordinates(:,i) = 0.0_pReal buildIPcoordinates(:,i) = 0.0_pREAL
do n = 1, size(connectivity_cell_reshaped,1) do n = 1, size(connectivity_cell_reshaped,1)
buildIPcoordinates(:,i) = buildIPcoordinates(:,i) & buildIPcoordinates(:,i) = buildIPcoordinates(:,i) &
+ node_cell(:,connectivity_cell_reshaped(n,i)) + node_cell(:,connectivity_cell_reshaped(n,i))
end do end do
buildIPcoordinates(:,i) = buildIPcoordinates(:,i)/real(size(connectivity_cell_reshaped,1),pReal) buildIPcoordinates(:,i) = buildIPcoordinates(:,i)/real(size(connectivity_cell_reshaped,1),pREAL)
end do end do
end function buildIPcoordinates end function buildIPcoordinates
@ -978,10 +978,10 @@ end function buildIPcoordinates
pure function IPvolume(elem,node) pure function IPvolume(elem,node)
type(tElement), intent(in) :: elem type(tElement), intent(in) :: elem
real(pReal), dimension(:,:), intent(in) :: node real(pREAL), dimension(:,:), intent(in) :: node
real(pReal), dimension(elem%nIPs,size(connectivity_cell,3)) :: IPvolume real(pREAL), dimension(elem%nIPs,size(connectivity_cell,3)) :: IPvolume
real(pReal), dimension(3) :: x0,x1,x2,x3,x4,x5,x6,x7 real(pREAL), dimension(3) :: x0,x1,x2,x3,x4,x5,x6,x7
integer :: e,i integer :: e,i
@ -1022,7 +1022,7 @@ pure function IPvolume(elem,node)
IPvolume(i,e) = dot_product((x7-x1)+(x6-x0),math_cross((x7-x2), (x3-x0))) & IPvolume(i,e) = dot_product((x7-x1)+(x6-x0),math_cross((x7-x2), (x3-x0))) &
+ dot_product((x6-x0), math_cross((x7-x2)+(x5-x0),(x7-x4))) & + dot_product((x6-x0), math_cross((x7-x2)+(x5-x0),(x7-x4))) &
+ dot_product((x7-x1), math_cross((x5-x0), (x7-x4)+(x3-x0))) + dot_product((x7-x1), math_cross((x5-x0), (x7-x4)+(x3-x0)))
IPvolume(i,e) = IPvolume(i,e)/12.0_pReal IPvolume(i,e) = IPvolume(i,e)/12.0_pREAL
end select end select
end do end do
end do end do
@ -1037,11 +1037,11 @@ pure function IPareaNormal(elem,nElem,node)
type(tElement), intent(in) :: elem type(tElement), intent(in) :: elem
integer, intent(in) :: nElem integer, intent(in) :: nElem
real(pReal), dimension(:,:), intent(in) :: node real(pREAL), dimension(:,:), intent(in) :: node
real(pReal), dimension(3,elem%nIPneighbors,elem%nIPs,nElem) :: ipAreaNormal real(pREAL), dimension(3,elem%nIPneighbors,elem%nIPs,nElem) :: ipAreaNormal
real(pReal), dimension (3,size(elem%cellFace,1)) :: nodePos real(pREAL), dimension (3,size(elem%cellFace,1)) :: nodePos
integer :: e,i,f,n,m integer :: e,i,f,n,m
m = size(elem%cellFace,1) m = size(elem%cellFace,1)
@ -1055,7 +1055,7 @@ pure function IPareaNormal(elem,nElem,node)
case (1,2) ! 2D 3 or 4 node case (1,2) ! 2D 3 or 4 node
IPareaNormal(1,f,i,e) = nodePos(2,2) - nodePos(2,1) ! x_normal = y_connectingVector IPareaNormal(1,f,i,e) = nodePos(2,2) - nodePos(2,1) ! x_normal = y_connectingVector
IPareaNormal(2,f,i,e) = -(nodePos(1,2) - nodePos(1,1)) ! y_normal = -x_connectingVector IPareaNormal(2,f,i,e) = -(nodePos(1,2) - nodePos(1,1)) ! y_normal = -x_connectingVector
IPareaNormal(3,f,i,e) = 0.0_pReal IPareaNormal(3,f,i,e) = 0.0_pREAL
case (3) ! 3D 4node case (3) ! 3D 4node
IPareaNormal(1:3,f,i,e) = math_cross(nodePos(1:3,2) - nodePos(1:3,1), & IPareaNormal(1:3,f,i,e) = math_cross(nodePos(1:3,2) - nodePos(1:3,1), &
nodePos(1:3,3) - nodePos(1:3,1)) nodePos(1:3,3) - nodePos(1:3,1))
@ -1063,11 +1063,11 @@ pure function IPareaNormal(elem,nElem,node)
! Get the normal of the quadrilateral face as the average of four normals of triangular ! Get the normal of the quadrilateral face as the average of four normals of triangular
! subfaces. Since the face consists only of two triangles, the sum has to be divided ! subfaces. Since the face consists only of two triangles, the sum has to be divided
! by two. This procedure tries to compensate for probable non-planar cell surfaces ! by two. This procedure tries to compensate for probable non-planar cell surfaces
IPareaNormal(1:3,f,i,e) = 0.0_pReal IPareaNormal(1:3,f,i,e) = 0.0_pREAL
do n = 1, m do n = 1, m
IPareaNormal(1:3,f,i,e) = IPareaNormal(1:3,f,i,e) & IPareaNormal(1:3,f,i,e) = IPareaNormal(1:3,f,i,e) &
+ math_cross(nodePos(1:3,mod(n+0,m)+1) - nodePos(1:3,n), & + math_cross(nodePos(1:3,mod(n+0,m)+1) - nodePos(1:3,n), &
nodePos(1:3,mod(n+1,m)+1) - nodePos(1:3,n)) * 0.5_pReal nodePos(1:3,mod(n+1,m)+1) - nodePos(1:3,n)) * 0.5_pREAL
end do end do
end select end select
end do end do

48
src/Marc/materialpoint_Marc.f90
View File

@ -27,11 +27,11 @@ module materialpoint_Marc
implicit none(type,external) implicit none(type,external)
private private
real(pReal), dimension (:,:,:), allocatable, private :: & real(pREAL), dimension (:,:,:), allocatable, private :: &
materialpoint_cs !< Cauchy stress materialpoint_cs !< Cauchy stress
real(pReal), dimension (:,:,:,:), allocatable, private :: & real(pREAL), dimension (:,:,:,:), allocatable, private :: &
materialpoint_dcsdE !< Cauchy stress tangent materialpoint_dcsdE !< Cauchy stress tangent
real(pReal), dimension (:,:,:,:), allocatable, private :: & real(pREAL), dimension (:,:,:,:), allocatable, private :: &
materialpoint_dcsdE_knownGood !< known good tangent materialpoint_dcsdE_knownGood !< known good tangent
integer, public :: & integer, public :: &
@ -95,9 +95,9 @@ subroutine materialpoint_init()
print'(/,1x,a)', '<<<+- materialpoint init -+>>>'; flush(IO_STDOUT) print'(/,1x,a)', '<<<+- materialpoint init -+>>>'; flush(IO_STDOUT)
allocate(materialpoint_cs( 6,discretization_nIPs,discretization_Nelems), source= 0.0_pReal) allocate(materialpoint_cs( 6,discretization_nIPs,discretization_Nelems), source= 0.0_pREAL)
allocate(materialpoint_dcsdE( 6,6,discretization_nIPs,discretization_Nelems), source= 0.0_pReal) allocate(materialpoint_dcsdE( 6,6,discretization_nIPs,discretization_Nelems), source= 0.0_pREAL)
allocate(materialpoint_dcsdE_knownGood(6,6,discretization_nIPs,discretization_Nelems), source= 0.0_pReal) allocate(materialpoint_dcsdE_knownGood(6,6,discretization_nIPs,discretization_Nelems), source= 0.0_pREAL)
end subroutine materialpoint_init end subroutine materialpoint_init
@ -110,25 +110,25 @@ subroutine materialpoint_general(mode, ffn, ffn1, temperature_inp, dt, elFE, ip,
integer, intent(in) :: elFE, & !< FE element number integer, intent(in) :: elFE, & !< FE element number
ip !< integration point number ip !< integration point number
real(pReal), intent(in) :: dt !< time increment real(pREAL), intent(in) :: dt !< time increment
real(pReal), dimension (3,3), intent(in) :: ffn, & !< deformation gradient for t=t0 real(pREAL), dimension (3,3), intent(in) :: ffn, & !< deformation gradient for t=t0
ffn1 !< deformation gradient for t=t1 ffn1 !< deformation gradient for t=t1
integer, intent(in) :: mode !< computation mode 1: regular computation plus aging of results integer, intent(in) :: mode !< computation mode 1: regular computation plus aging of results
real(pReal), intent(in) :: temperature_inp !< temperature real(pREAL), intent(in) :: temperature_inp !< temperature
real(pReal), dimension(6), intent(out) :: cauchyStress !< stress as 6 vector real(pREAL), dimension(6), intent(out) :: cauchyStress !< stress as 6 vector
real(pReal), dimension(6,6), intent(out) :: jacobian !< jacobian as 66 tensor (Consistent tangent dcs/dE) real(pREAL), dimension(6,6), intent(out) :: jacobian !< jacobian as 66 tensor (Consistent tangent dcs/dE)
real(pReal) J_inverse, & ! inverse of Jacobian real(pREAL) J_inverse, & ! inverse of Jacobian
rnd rnd
real(pReal), dimension (3,3) :: Kirchhoff ! Piola-Kirchhoff stress real(pREAL), dimension (3,3) :: Kirchhoff ! Piola-Kirchhoff stress
real(pReal), dimension (3,3,3,3) :: H_sym, & real(pREAL), dimension (3,3,3,3) :: H_sym, &
H H
integer elCP, & ! crystal plasticity element number integer elCP, & ! crystal plasticity element number
i, j, k, l, m, n, ph, homog, mySource,ce i, j, k, l, m, n, ph, homog, mySource,ce
real(pReal), parameter :: ODD_STRESS = 1e15_pReal, & !< return value for stress if terminallyIll real(pREAL), parameter :: ODD_STRESS = 1e15_pREAL, & !< return value for stress if terminallyIll
ODD_JACOBIAN = 1e50_pReal !< return value for jacobian if terminallyIll ODD_JACOBIAN = 1e50_pREAL !< return value for jacobian if terminallyIll
elCP = discretization_Marc_FEM2DAMASK_elem(elFE) elCP = discretization_Marc_FEM2DAMASK_elem(elFE)
@ -149,7 +149,7 @@ subroutine materialpoint_general(mode, ffn, ffn1, temperature_inp, dt, elFE, ip,
validCalculation: if (terminallyIll) then validCalculation: if (terminallyIll) then
call random_number(rnd) call random_number(rnd)
if (rnd < 0.5_pReal) rnd = rnd - 1.0_pReal if (rnd < 0.5_pREAL) rnd = rnd - 1.0_pREAL
materialpoint_cs(1:6,ip,elCP) = ODD_STRESS * rnd materialpoint_cs(1:6,ip,elCP) = ODD_STRESS * rnd
materialpoint_dcsde(1:6,1:6,ip,elCP) = ODD_JACOBIAN * math_eye(6) materialpoint_dcsde(1:6,1:6,ip,elCP) = ODD_JACOBIAN * math_eye(6)
@ -161,7 +161,7 @@ subroutine materialpoint_general(mode, ffn, ffn1, temperature_inp, dt, elFE, ip,
terminalIllness: if (terminallyIll) then terminalIllness: if (terminallyIll) then
call random_number(rnd) call random_number(rnd)
if (rnd < 0.5_pReal) rnd = rnd - 1.0_pReal if (rnd < 0.5_pREAL) rnd = rnd - 1.0_pREAL
materialpoint_cs(1:6,ip,elCP) = ODD_STRESS * rnd materialpoint_cs(1:6,ip,elCP) = ODD_STRESS * rnd
materialpoint_dcsde(1:6,1:6,ip,elCP) = ODD_JACOBIAN * math_eye(6) materialpoint_dcsde(1:6,1:6,ip,elCP) = ODD_JACOBIAN * math_eye(6)
@ -169,22 +169,22 @@ subroutine materialpoint_general(mode, ffn, ffn1, temperature_inp, dt, elFE, ip,
! translate from P to sigma ! translate from P to sigma
Kirchhoff = matmul(homogenization_P(1:3,1:3,ce), transpose(homogenization_F(1:3,1:3,ce))) Kirchhoff = matmul(homogenization_P(1:3,1:3,ce), transpose(homogenization_F(1:3,1:3,ce)))
J_inverse = 1.0_pReal / math_det33(homogenization_F(1:3,1:3,ce)) J_inverse = 1.0_pREAL / math_det33(homogenization_F(1:3,1:3,ce))
materialpoint_cs(1:6,ip,elCP) = math_sym33to6(J_inverse * Kirchhoff,weighted=.false.) materialpoint_cs(1:6,ip,elCP) = math_sym33to6(J_inverse * Kirchhoff,weighted=.false.)
! translate from dP/dF to dCS/dE ! translate from dP/dF to dCS/dE
H = 0.0_pReal H = 0.0_pREAL
do i=1,3; do j=1,3; do k=1,3; do l=1,3; do m=1,3; do n=1,3 do i=1,3; do j=1,3; do k=1,3; do l=1,3; do m=1,3; do n=1,3
H(i,j,k,l) = H(i,j,k,l) & H(i,j,k,l) = H(i,j,k,l) &
+ homogenization_F(j,m,ce) * homogenization_F(l,n,ce) & + homogenization_F(j,m,ce) * homogenization_F(l,n,ce) &
* homogenization_dPdF(i,m,k,n,ce) & * homogenization_dPdF(i,m,k,n,ce) &
- math_delta(j,l) * homogenization_F(i,m,ce) * homogenization_P(k,m,ce) & - math_delta(j,l) * homogenization_F(i,m,ce) * homogenization_P(k,m,ce) &
+ 0.5_pReal * ( Kirchhoff(j,l)*math_delta(i,k) + Kirchhoff(i,k)*math_delta(j,l) & + 0.5_pREAL * ( Kirchhoff(j,l)*math_delta(i,k) + Kirchhoff(i,k)*math_delta(j,l) &
+ Kirchhoff(j,k)*math_delta(i,l) + Kirchhoff(i,l)*math_delta(j,k)) + Kirchhoff(j,k)*math_delta(i,l) + Kirchhoff(i,l)*math_delta(j,k))
end do; end do; end do; end do; end do; end do end do; end do; end do; end do; end do; end do
forall(i=1:3, j=1:3,k=1:3,l=1:3) & forall(i=1:3, j=1:3,k=1:3,l=1:3) &
H_sym(i,j,k,l) = 0.25_pReal * (H(i,j,k,l) + H(j,i,k,l) + H(i,j,l,k) + H(j,i,l,k)) H_sym(i,j,k,l) = 0.25_pREAL * (H(i,j,k,l) + H(j,i,k,l) + H(i,j,l,k) + H(j,i,l,k))
materialpoint_dcsde(1:6,1:6,ip,elCP) = math_sym3333to66(J_inverse * H_sym,weighted=.false.) materialpoint_dcsde(1:6,1:6,ip,elCP) = math_sym3333to66(J_inverse * H_sym,weighted=.false.)
@ -193,7 +193,7 @@ subroutine materialpoint_general(mode, ffn, ffn1, temperature_inp, dt, elFE, ip,
end if end if
if (all(abs(materialpoint_dcsdE(1:6,1:6,ip,elCP)) < 1e-10_pReal)) & if (all(abs(materialpoint_dcsdE(1:6,1:6,ip,elCP)) < 1e-10_pREAL)) &
call IO_warning(601,label1='element (CP)',ID1=elCP,label2='IP',ID2=ip) call IO_warning(601,label1='element (CP)',ID1=elCP,label2='IP',ID2=ip)
cauchyStress = materialpoint_cs (1:6, ip,elCP) cauchyStress = materialpoint_cs (1:6, ip,elCP)
@ -219,7 +219,7 @@ end subroutine materialpoint_forward
subroutine materialpoint_result(inc,time) subroutine materialpoint_result(inc,time)
integer, intent(in) :: inc integer, intent(in) :: inc
real(pReal), intent(in) :: time real(pREAL), intent(in) :: time
call result_openJobFile() call result_openJobFile()
call result_addIncrement(inc,time) call result_addIncrement(inc,time)

30
src/YAML_types.f90
View File

@ -183,7 +183,7 @@ subroutine selfTest()
s = '1' s = '1'
if (s%asInt() /= 1) error stop 'tScalar_asInt' if (s%asInt() /= 1) error stop 'tScalar_asInt'
if (s_pointer%asInt() /= 1) error stop 'tScalar_asInt(pointer)' if (s_pointer%asInt() /= 1) error stop 'tScalar_asInt(pointer)'
if (dNeq(s%asReal(),1.0_pReal)) error stop 'tScalar_asReal' if (dNeq(s%asReal(),1.0_pREAL)) error stop 'tScalar_asReal'
s = 'true' s = 'true'
if (.not. s%asBool()) error stop 'tScalar_asBool' if (.not. s%asBool()) error stop 'tScalar_asBool'
if (.not. s_pointer%asBool()) error stop 'tScalar_asBool(pointer)' if (.not. s_pointer%asBool()) error stop 'tScalar_asBool(pointer)'
@ -209,11 +209,11 @@ subroutine selfTest()
call l%append(s1) call l%append(s1)
call l%append(s2) call l%append(s2)
if (l%length /= 2) error stop 'tList%len' if (l%length /= 2) error stop 'tList%len'
if (dNeq(l%get_asReal(1),1.0_pReal)) error stop 'tList_get_asReal' if (dNeq(l%get_asReal(1),1.0_pREAL)) error stop 'tList_get_asReal'
if (l%get_asInt(1) /= 1) error stop 'tList_get_asInt' if (l%get_asInt(1) /= 1) error stop 'tList_get_asInt'
if (l%get_asStr(2) /= '2') error stop 'tList_get_asStr' if (l%get_asStr(2) /= '2') error stop 'tList_get_asStr'
if (any(l%as1dInt() /= [1,2])) error stop 'tList_as1dInt' if (any(l%as1dInt() /= [1,2])) error stop 'tList_as1dInt'
if (any(dNeq(l%as1dReal(),real([1.0,2.0],pReal)))) error stop 'tList_as1dReal' if (any(dNeq(l%as1dReal(),real([1.0,2.0],pREAL)))) error stop 'tList_as1dReal'
s1 = 'true' s1 = 'true'
s2 = 'false' s2 = 'false'
if (any(l%as1dBool() .neqv. [.true.,.false.])) error stop 'tList_as1dBool' if (any(l%as1dBool() .neqv. [.true.,.false.])) error stop 'tList_as1dBool'
@ -253,7 +253,7 @@ subroutine selfTest()
if (d%asFormattedStr() /= '{one-two: [1, 2], three: 3, four: 4}') & if (d%asFormattedStr() /= '{one-two: [1, 2], three: 3, four: 4}') &
error stop 'tDict_asFormattedStr' error stop 'tDict_asFormattedStr'
if (d%get_asInt('three') /= 3) error stop 'tDict_get_asInt' if (d%get_asInt('three') /= 3) error stop 'tDict_get_asInt'
if (dNeq(d%get_asReal('three'),3.0_pReal)) error stop 'tDict_get_asReal' if (dNeq(d%get_asReal('three'),3.0_pREAL)) error stop 'tDict_get_asReal'
if (d%get_asStr('three') /= '3') error stop 'tDict_get_asStr' if (d%get_asStr('three') /= '3') error stop 'tDict_get_asStr'
if (any(d%get_as1dInt('one-two') /= [1,2])) error stop 'tDict_get_as1dInt' if (any(d%get_as1dInt('one-two') /= [1,2])) error stop 'tDict_get_as1dInt'
call d%set('one-two',s4) call d%set('one-two',s4)
@ -376,7 +376,7 @@ end function tNode_asDict
function tScalar_asReal(self) function tScalar_asReal(self)
class(tScalar), intent(in), target :: self class(tScalar), intent(in), target :: self
real(pReal) :: tScalar_asReal real(pREAL) :: tScalar_asReal
tScalar_asReal = IO_strAsReal(self%value) tScalar_asReal = IO_strAsReal(self%value)
@ -481,7 +481,7 @@ end subroutine tList_append
function tList_as1dReal(self) function tList_as1dReal(self)
class(tList), intent(in), target :: self class(tList), intent(in), target :: self
real(pReal), dimension(:), allocatable :: tList_as1dReal real(pREAL), dimension(:), allocatable :: tList_as1dReal
integer :: i integer :: i
type(tItem), pointer :: item type(tItem), pointer :: item
@ -505,7 +505,7 @@ end function tList_as1dReal
function tList_as2dReal(self) function tList_as2dReal(self)
class(tList), intent(in), target :: self class(tList), intent(in), target :: self
real(pReal), dimension(:,:), allocatable :: tList_as2dReal real(pREAL), dimension(:,:), allocatable :: tList_as2dReal
integer :: i integer :: i
type(tList), pointer :: row_data type(tList), pointer :: row_data
@ -724,7 +724,7 @@ function tList_get_asReal(self,i) result(nodeAsReal)
class(tList), intent(in) :: self class(tList), intent(in) :: self
integer, intent(in) :: i integer, intent(in) :: i
real(pReal) :: nodeAsReal real(pREAL) :: nodeAsReal
class(tScalar), pointer :: scalar class(tScalar), pointer :: scalar
@ -742,7 +742,7 @@ function tList_get_as1dReal(self,i) result(nodeAs1dReal)
class(tList), intent(in) :: self class(tList), intent(in) :: self
integer, intent(in) :: i integer, intent(in) :: i
real(pReal), dimension(:), allocatable :: nodeAs1dReal real(pREAL), dimension(:), allocatable :: nodeAs1dReal
class(tList), pointer :: list class(tList), pointer :: list
@ -1124,8 +1124,8 @@ function tDict_get_asReal(self,k,defaultVal) result(nodeAsReal)
class(tDict), intent(in) :: self class(tDict), intent(in) :: self
character(len=*), intent(in) :: k character(len=*), intent(in) :: k
real(pReal), intent(in), optional :: defaultVal real(pREAL), intent(in), optional :: defaultVal
real(pReal) :: nodeAsReal real(pREAL) :: nodeAsReal
type(tScalar), pointer :: scalar type(tScalar), pointer :: scalar
@ -1149,9 +1149,9 @@ function tDict_get_as1dReal(self,k,defaultVal,requiredSize) result(nodeAs1dReal)
class(tDict), intent(in) :: self class(tDict), intent(in) :: self
character(len=*), intent(in) :: k character(len=*), intent(in) :: k
real(pReal), intent(in), dimension(:), optional :: defaultVal real(pREAL), intent(in), dimension(:), optional :: defaultVal
integer, intent(in), optional :: requiredSize integer, intent(in), optional :: requiredSize
real(pReal), dimension(:), allocatable :: nodeAs1dReal real(pREAL), dimension(:), allocatable :: nodeAs1dReal
type(tList), pointer :: list type(tList), pointer :: list
@ -1179,9 +1179,9 @@ function tDict_get_as2dReal(self,k,defaultVal,requiredShape) result(nodeAs2dReal
class(tDict), intent(in) :: self class(tDict), intent(in) :: self
character(len=*), intent(in) :: k character(len=*), intent(in) :: k
real(pReal), intent(in), dimension(:,:), optional :: defaultVal real(pREAL), intent(in), dimension(:,:), optional :: defaultVal
integer, intent(in), dimension(2), optional :: requiredShape integer, intent(in), dimension(2), optional :: requiredShape
real(pReal), dimension(:,:), allocatable :: nodeAs2dReal real(pREAL), dimension(:,:), allocatable :: nodeAs2dReal
type(tList), pointer :: list type(tList), pointer :: list

8
src/constants.f90
View File

@ -8,9 +8,9 @@ module constants
implicit none(type,external) implicit none(type,external)
public public
real(pReal), parameter :: & real(pREAL), parameter :: &
T_ROOM = 293.15_pReal, & !< Room temperature (20°C) in K (https://en.wikipedia.org/wiki/ISO_1) T_ROOM = 293.15_pREAL, & !< Room temperature (20°C) in K (https://en.wikipedia.org/wiki/ISO_1)
K_B = 1.380649e-23_pReal, & !< Boltzmann constant in J/Kelvin (https://doi.org/10.1351/goldbook) K_B = 1.380649e-23_pREAL, & !< Boltzmann constant in J/Kelvin (https://doi.org/10.1351/goldbook)
N_A = 6.02214076e23_pReal !< Avogadro constant in 1/mol (https://doi.org/10.1351/goldbook) N_A = 6.02214076e23_pREAL !< Avogadro constant in 1/mol (https://doi.org/10.1351/goldbook)
end module constants end module constants

10
src/discretization.f90
View File

@ -18,7 +18,7 @@ module discretization
integer, public, protected, dimension(:), allocatable :: & integer, public, protected, dimension(:), allocatable :: &
discretization_materialAt !ToDo: discretization_ID_material discretization_materialAt !ToDo: discretization_ID_material
real(pReal), public, protected, dimension(:,:), allocatable :: & real(pREAL), public, protected, dimension(:,:), allocatable :: &
discretization_IPcoords0, & discretization_IPcoords0, &
discretization_IPcoords, & discretization_IPcoords, &
discretization_NodeCoords0, & discretization_NodeCoords0, &
@ -44,7 +44,7 @@ subroutine discretization_init(materialAt,&
integer, dimension(:), intent(in) :: & integer, dimension(:), intent(in) :: &
materialAt materialAt
real(pReal), dimension(:,:), intent(in) :: & real(pREAL), dimension(:,:), intent(in) :: &
IPcoords0, & IPcoords0, &
NodeCoords0 NodeCoords0
integer, optional, intent(in) :: & integer, optional, intent(in) :: &
@ -78,7 +78,7 @@ end subroutine discretization_init
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine discretization_result() subroutine discretization_result()
real(pReal), dimension(:,:), allocatable :: u real(pREAL), dimension(:,:), allocatable :: u
call result_closeGroup(result_addGroup('current/geometry')) call result_closeGroup(result_addGroup('current/geometry'))
@ -98,7 +98,7 @@ end subroutine discretization_result
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine discretization_setIPcoords(IPcoords) subroutine discretization_setIPcoords(IPcoords)
real(pReal), dimension(:,:), intent(in) :: IPcoords real(pREAL), dimension(:,:), intent(in) :: IPcoords
discretization_IPcoords = IPcoords discretization_IPcoords = IPcoords
@ -110,7 +110,7 @@ end subroutine discretization_setIPcoords
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine discretization_setNodeCoords(NodeCoords) subroutine discretization_setNodeCoords(NodeCoords)
real(pReal), dimension(:,:), intent(in) :: NodeCoords real(pREAL), dimension(:,:), intent(in) :: NodeCoords
discretization_NodeCoords = NodeCoords discretization_NodeCoords = NodeCoords

18
src/geometry_plastic_nonlocal.f90
View File

@ -18,13 +18,13 @@ module geometry_plastic_nonlocal
integer, dimension(:,:,:,:), allocatable, protected :: & integer, dimension(:,:,:,:), allocatable, protected :: &
geometry_plastic_nonlocal_IPneighborhood !< 6 or less neighboring IPs as [element ID, IP ID, face ID that point to me] geometry_plastic_nonlocal_IPneighborhood !< 6 or less neighboring IPs as [element ID, IP ID, face ID that point to me]
real(pReal), dimension(:,:), allocatable, protected :: & real(pREAL), dimension(:,:), allocatable, protected :: &
geometry_plastic_nonlocal_IPvolume0 !< volume associated with IP (initially!) geometry_plastic_nonlocal_IPvolume0 !< volume associated with IP (initially!)
real(pReal), dimension(:,:,:), allocatable, protected :: & real(pREAL), dimension(:,:,:), allocatable, protected :: &
geometry_plastic_nonlocal_IParea0 !< area of interface to neighboring IP (initially!) geometry_plastic_nonlocal_IParea0 !< area of interface to neighboring IP (initially!)
real(pReal), dimension(:,:,:,:), allocatable, protected :: & real(pREAL), dimension(:,:,:,:), allocatable, protected :: &
geometry_plastic_nonlocal_IPareaNormal0 !< area normal of interface to neighboring IP (initially!) geometry_plastic_nonlocal_IPareaNormal0 !< area normal of interface to neighboring IP (initially!)
@ -54,7 +54,7 @@ end subroutine geometry_plastic_nonlocal_setIPneighborhood
!--------------------------------------------------------------------------------------------------- !---------------------------------------------------------------------------------------------------
subroutine geometry_plastic_nonlocal_setIPvolume(IPvolume) subroutine geometry_plastic_nonlocal_setIPvolume(IPvolume)
real(pReal), dimension(:,:), intent(in) :: IPvolume real(pREAL), dimension(:,:), intent(in) :: IPvolume
geometry_plastic_nonlocal_IPvolume0 = IPvolume geometry_plastic_nonlocal_IPvolume0 = IPvolume
@ -67,7 +67,7 @@ end subroutine geometry_plastic_nonlocal_setIPvolume
!--------------------------------------------------------------------------------------------------- !---------------------------------------------------------------------------------------------------
subroutine geometry_plastic_nonlocal_setIParea(IParea) subroutine geometry_plastic_nonlocal_setIParea(IParea)
real(pReal), dimension(:,:,:), intent(in) :: IParea real(pREAL), dimension(:,:,:), intent(in) :: IParea
geometry_plastic_nonlocal_IParea0 = IParea geometry_plastic_nonlocal_IParea0 = IParea
@ -80,7 +80,7 @@ end subroutine geometry_plastic_nonlocal_setIParea
!--------------------------------------------------------------------------------------------------- !---------------------------------------------------------------------------------------------------
subroutine geometry_plastic_nonlocal_setIPareaNormal(IPareaNormal) subroutine geometry_plastic_nonlocal_setIPareaNormal(IPareaNormal)
real(pReal), dimension(:,:,:,:), intent(in) :: IPareaNormal real(pREAL), dimension(:,:,:,:), intent(in) :: IPareaNormal
geometry_plastic_nonlocal_IPareaNormal0 = IPareaNormal geometry_plastic_nonlocal_IPareaNormal0 = IPareaNormal
@ -117,7 +117,7 @@ subroutine geometry_plastic_nonlocal_result()
call result_openJobFile() call result_openJobFile()
writeVolume: block writeVolume: block
real(pReal), dimension(:), allocatable :: temp real(pREAL), dimension(:), allocatable :: temp
shp = shape(geometry_plastic_nonlocal_IPvolume0) shp = shape(geometry_plastic_nonlocal_IPvolume0)
temp = reshape(geometry_plastic_nonlocal_IPvolume0,[shp(1)*shp(2)]) temp = reshape(geometry_plastic_nonlocal_IPvolume0,[shp(1)*shp(2)])
call result_writeDataset(temp,'geometry','v_0',& call result_writeDataset(temp,'geometry','v_0',&
@ -125,7 +125,7 @@ subroutine geometry_plastic_nonlocal_result()
end block writeVolume end block writeVolume
writeAreas: block writeAreas: block
real(pReal), dimension(:,:), allocatable :: temp real(pREAL), dimension(:,:), allocatable :: temp
shp = shape(geometry_plastic_nonlocal_IParea0) shp = shape(geometry_plastic_nonlocal_IParea0)
temp = reshape(geometry_plastic_nonlocal_IParea0,[shp(1),shp(2)*shp(3)]) temp = reshape(geometry_plastic_nonlocal_IParea0,[shp(1),shp(2)*shp(3)])
call result_writeDataset(temp,'geometry','a_0',& call result_writeDataset(temp,'geometry','a_0',&
@ -133,7 +133,7 @@ subroutine geometry_plastic_nonlocal_result()
end block writeAreas end block writeAreas
writeNormals: block writeNormals: block
real(pReal), dimension(:,:,:), allocatable :: temp real(pREAL), dimension(:,:,:), allocatable :: temp
shp = shape(geometry_plastic_nonlocal_IPareaNormal0) shp = shape(geometry_plastic_nonlocal_IPareaNormal0)
temp = reshape(geometry_plastic_nonlocal_IPareaNormal0,[shp(1),shp(2),shp(3)*shp(4)]) temp = reshape(geometry_plastic_nonlocal_IPareaNormal0,[shp(1),shp(2),shp(3)*shp(4)])
call result_writeDataset(temp,'geometry','n_0',& call result_writeDataset(temp,'geometry','n_0',&

42
src/grid/DAMASK_grid.f90
View File

@ -40,7 +40,7 @@ program DAMASK_grid
type(tRotation) :: rot !< rotation of BC type(tRotation) :: rot !< rotation of BC
type(tBoundaryCondition) :: stress, & !< stress BC type(tBoundaryCondition) :: stress, & !< stress BC
deformation !< deformation BC (dot_F, F, or L) deformation !< deformation BC (dot_F, F, or L)
real(pReal) :: t, & !< length of increment real(pREAL) :: t, & !< length of increment
r !< ratio of geometric progression r !< ratio of geometric progression
integer :: N, & !< number of increments integer :: N, & !< number of increments
f_out, & !< frequency of result writes f_out, & !< frequency of result writes
@ -63,12 +63,12 @@ program DAMASK_grid
! loop variables, convergence etc. ! loop variables, convergence etc.
integer, parameter :: & integer, parameter :: &
subStepFactor = 2 !< for each substep, divide the last time increment by 2.0 subStepFactor = 2 !< for each substep, divide the last time increment by 2.0
real(pReal) :: & real(pREAL) :: &
t = 0.0_pReal, & !< elapsed time t = 0.0_pREAL, & !< elapsed time
t_0 = 0.0_pReal, & !< begin of interval t_0 = 0.0_pREAL, & !< begin of interval
Delta_t = 1.0_pReal, & !< current time interval Delta_t = 1.0_pREAL, & !< current time interval
Delta_t_prev = 0.0_pReal, & !< previous time interval Delta_t_prev = 0.0_pREAL, & !< previous time interval
t_remaining = 0.0_pReal !< remaining time of current load case t_remaining = 0.0_pREAL !< remaining time of current load case
logical :: & logical :: &
guess, & !< guess along former trajectory guess, & !< guess along former trajectory
stagIterate, & stagIterate, &
@ -234,14 +234,14 @@ program DAMASK_grid
call getMaskedTensor(loadCases(l)%stress%values,loadCases(l)%stress%mask,step_mech%get_list(m)) call getMaskedTensor(loadCases(l)%stress%values,loadCases(l)%stress%mask,step_mech%get_list(m))
#endif #endif
end select end select
call loadCases(l)%rot%fromAxisAngle(step_mech%get_as1dReal('R',defaultVal = real([0.0,0.0,1.0,0.0],pReal)),degrees=.true.) call loadCases(l)%rot%fromAxisAngle(step_mech%get_as1dReal('R',defaultVal = real([0.0,0.0,1.0,0.0],pREAL)),degrees=.true.)
end do readMech end do readMech
if (.not. allocated(loadCases(l)%deformation%myType)) call IO_error(error_ID=837,ext_msg = 'L/dot_F/F missing') if (.not. allocated(loadCases(l)%deformation%myType)) call IO_error(error_ID=837,ext_msg = 'L/dot_F/F missing')
step_discretization => load_step%get_dict('discretization') step_discretization => load_step%get_dict('discretization')
loadCases(l)%t = step_discretization%get_asReal('t') loadCases(l)%t = step_discretization%get_asReal('t')
loadCases(l)%N = step_discretization%get_asInt ('N') loadCases(l)%N = step_discretization%get_asInt ('N')
loadCases(l)%r = step_discretization%get_asReal('r',defaultVal= 1.0_pReal) loadCases(l)%r = step_discretization%get_asReal('r',defaultVal= 1.0_pREAL)
loadCases(l)%f_restart = load_step%get_asInt('f_restart', defaultVal=huge(0)) loadCases(l)%f_restart = load_step%get_asInt('f_restart', defaultVal=huge(0))
if (load_step%get_asStr('f_out',defaultVal='n/a') == 'none') then if (load_step%get_asStr('f_out',defaultVal='n/a') == 'none') then
@ -279,7 +279,7 @@ program DAMASK_grid
if (loadCases(l)%stress%mask(i,j)) then if (loadCases(l)%stress%mask(i,j)) then
write(IO_STDOUT,'(2x,12a)',advance='no') ' x ' write(IO_STDOUT,'(2x,12a)',advance='no') ' x '
else else
write(IO_STDOUT,'(2x,f12.4)',advance='no') loadCases(l)%stress%values(i,j)*1e-6_pReal write(IO_STDOUT,'(2x,f12.4)',advance='no') loadCases(l)%stress%values(i,j)*1e-6_pREAL
end if end if
end do; write(IO_STDOUT,'(/)',advance='no') end do; write(IO_STDOUT,'(/)',advance='no')
end do end do
@ -288,13 +288,13 @@ program DAMASK_grid
write(IO_STDOUT,'(2x,a,/,3(3(3x,f12.7,1x)/))',advance='no') 'R:',& write(IO_STDOUT,'(2x,a,/,3(3(3x,f12.7,1x)/))',advance='no') 'R:',&
transpose(loadCases(l)%rot%asMatrix()) transpose(loadCases(l)%rot%asMatrix())
if (loadCases(l)%r <= 0.0_pReal) errorID = 833 if (loadCases(l)%r <= 0.0_pREAL) errorID = 833
if (loadCases(l)%t < 0.0_pReal) errorID = 834 if (loadCases(l)%t < 0.0_pREAL) errorID = 834
if (loadCases(l)%N < 1) errorID = 835 if (loadCases(l)%N < 1) errorID = 835
if (loadCases(l)%f_out < 1) errorID = 836 if (loadCases(l)%f_out < 1) errorID = 836
if (loadCases(l)%f_restart < 1) errorID = 839 if (loadCases(l)%f_restart < 1) errorID = 839
if (dEq(loadCases(l)%r,1.0_pReal,1.e-9_pReal)) then if (dEq(loadCases(l)%r,1.0_pREAL,1.e-9_pREAL)) then
print'(2x,a)', 'r: 1 (constant step width)' print'(2x,a)', 'r: 1 (constant step width)'
else else
print'(2x,a,1x,f0.3)', 'r:', loadCases(l)%r print'(2x,a,1x,f0.3)', 'r:', loadCases(l)%r
@ -345,7 +345,7 @@ program DAMASK_grid
writeUndeformed: if (CLI_restartInc < 1) then writeUndeformed: if (CLI_restartInc < 1) then
print'(/,1x,a)', '... writing initial configuration to file .................................' print'(/,1x,a)', '... writing initial configuration to file .................................'
flush(IO_STDOUT) flush(IO_STDOUT)
call materialpoint_result(0,0.0_pReal) call materialpoint_result(0,0.0_pREAL)
end if writeUndeformed end if writeUndeformed
loadCaseLooping: do l = 1, size(loadCases) loadCaseLooping: do l = 1, size(loadCases)
@ -358,13 +358,13 @@ program DAMASK_grid
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! forwarding time ! forwarding time
Delta_t_prev = Delta_t ! last time intervall that brought former inc to an end Delta_t_prev = Delta_t ! last time intervall that brought former inc to an end
if (dEq(loadCases(l)%r,1.0_pReal,1.e-9_pReal)) then ! linear scale if (dEq(loadCases(l)%r,1.0_pREAL,1.e-9_pREAL)) then ! linear scale
Delta_t = loadCases(l)%t/real(loadCases(l)%N,pReal) Delta_t = loadCases(l)%t/real(loadCases(l)%N,pREAL)
else else
Delta_t = loadCases(l)%t * (loadCases(l)%r**(inc-1)-loadCases(l)%r**inc) & Delta_t = loadCases(l)%t * (loadCases(l)%r**(inc-1)-loadCases(l)%r**inc) &
/ (1.0_pReal-loadCases(l)%r**loadCases(l)%N) / (1.0_pREAL-loadCases(l)%r**loadCases(l)%N)
end if end if
Delta_t = Delta_t * real(subStepFactor,pReal)**real(-cutBackLevel,pReal) ! depending on cut back level, decrease time step Delta_t = Delta_t * real(subStepFactor,pREAL)**real(-cutBackLevel,pREAL) ! depending on cut back level, decrease time step
skipping: if (totalIncsCounter <= CLI_restartInc) then ! not yet at restart inc? skipping: if (totalIncsCounter <= CLI_restartInc) then ! not yet at restart inc?
t = t + Delta_t ! just advance time, skip already performed calculation t = t + Delta_t ! just advance time, skip already performed calculation
@ -450,7 +450,7 @@ program DAMASK_grid
stepFraction = (stepFraction - 1) * subStepFactor ! adjust to new denominator stepFraction = (stepFraction - 1) * subStepFactor ! adjust to new denominator
cutBackLevel = cutBackLevel + 1 cutBackLevel = cutBackLevel + 1
t = t - Delta_t t = t - Delta_t
Delta_t = Delta_t/real(subStepFactor,pReal) ! cut timestep Delta_t = Delta_t/real(subStepFactor,pREAL) ! cut timestep
print'(/,1x,a)', 'cutting back ' print'(/,1x,a)', 'cutting back '
else ! no more options to continue else ! no more options to continue
if (worldrank == 0) close(statUnit) if (worldrank == 0) close(statUnit)
@ -513,7 +513,7 @@ contains
subroutine getMaskedTensor(values,mask,tensor) subroutine getMaskedTensor(values,mask,tensor)
real(pReal), intent(out), dimension(3,3) :: values real(pREAL), intent(out), dimension(3,3) :: values
logical, intent(out), dimension(3,3) :: mask logical, intent(out), dimension(3,3) :: mask
type(tList), pointer :: tensor type(tList), pointer :: tensor
@ -521,7 +521,7 @@ subroutine getMaskedTensor(values,mask,tensor)
integer :: i,j integer :: i,j
values = 0.0_pReal values = 0.0_pREAL
do i = 1,3 do i = 1,3
row => tensor%get_list(i) row => tensor%get_list(i)
do j = 1,3 do j = 1,3

24
src/grid/VTI.f90
View File

@ -50,7 +50,7 @@ function VTI_readDataset_real(fileContent,label) result(dataset)
character(len=*), intent(in) :: & character(len=*), intent(in) :: &
label, & label, &
fileContent fileContent
real(pReal), dimension(:), allocatable :: & real(pREAL), dimension(:), allocatable :: &
dataset dataset
character(len=:), allocatable :: dataType, headerType, base64Str character(len=:), allocatable :: dataType, headerType, base64Str
@ -143,7 +143,7 @@ subroutine VTI_readCellsSizeOrigin(cells,geomSize,origin, &
integer, dimension(3), intent(out) :: & integer, dimension(3), intent(out) :: &
cells ! # of cells (across all processes!) cells ! # of cells (across all processes!)
real(pReal), dimension(3), intent(out) :: & real(pREAL), dimension(3), intent(out) :: &
geomSize, & ! size (across all processes!) geomSize, & ! size (across all processes!)
origin ! origin (across all processes!) origin ! origin (across all processes!)
character(len=*), intent(in) :: & character(len=*), intent(in) :: &
@ -156,7 +156,7 @@ subroutine VTI_readCellsSizeOrigin(cells,geomSize,origin, &
cells = -1 cells = -1
geomSize = -1.0_pReal geomSize = -1.0_pREAL
inFile = .false. inFile = .false.
inImage = .false. inImage = .false.
@ -198,11 +198,11 @@ end subroutine VTI_readCellsSizeOrigin
subroutine cellsSizeOrigin(c,s,o,header) subroutine cellsSizeOrigin(c,s,o,header)
integer, dimension(3), intent(out) :: c integer, dimension(3), intent(out) :: c
real(pReal), dimension(3), intent(out) :: s,o real(pREAL), dimension(3), intent(out) :: s,o
character(len=*), intent(in) :: header character(len=*), intent(in) :: header
character(len=:), allocatable :: temp character(len=:), allocatable :: temp
real(pReal), dimension(3) :: delta real(pREAL), dimension(3) :: delta
integer :: i integer :: i
@ -217,7 +217,7 @@ subroutine cellsSizeOrigin(c,s,o,header)
temp = getXMLValue(header,'Spacing') temp = getXMLValue(header,'Spacing')
delta = [(IO_realValue(temp,IO_strPos(temp),i),i=1,3)] delta = [(IO_realValue(temp,IO_strPos(temp),i),i=1,3)]
s = delta * real(c,pReal) s = delta * real(c,pREAL)
temp = getXMLValue(header,'Origin') temp = getXMLValue(header,'Origin')
o = [(IO_realValue(temp,IO_strPos(temp),i),i=1,3)] o = [(IO_realValue(temp,IO_strPos(temp),i),i=1,3)]
@ -255,7 +255,7 @@ end function as_Int
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Interpret Base64 string in vtk XML file as real of kind pReal. !> @brief Interpret Base64 string in vtk XML file as real of kind pREAL.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
function as_real(base64Str,headerType,compressed,dataType) function as_real(base64Str,headerType,compressed,dataType)
@ -264,18 +264,18 @@ function as_real(base64Str,headerType,compressed,dataType)
dataType ! data type (Int32, Int64, Float32, Float64) dataType ! data type (Int32, Int64, Float32, Float64)
logical, intent(in) :: compressed ! indicate whether data is zlib compressed logical, intent(in) :: compressed ! indicate whether data is zlib compressed
real(pReal), dimension(:), allocatable :: as_real real(pREAL), dimension(:), allocatable :: as_real
select case(dataType) select case(dataType)
case('Int32') case('Int32')
as_real = real(prec_bytesToC_INT32_T(asBytes(base64Str,headerType,compressed)),pReal) as_real = real(prec_bytesToC_INT32_T(asBytes(base64Str,headerType,compressed)),pREAL)
case('Int64') case('Int64')
as_real = real(prec_bytesToC_INT64_T(asBytes(base64Str,headerType,compressed)),pReal) as_real = real(prec_bytesToC_INT64_T(asBytes(base64Str,headerType,compressed)),pREAL)
case('Float32') case('Float32')
as_real = real(prec_bytesToC_FLOAT (asBytes(base64Str,headerType,compressed)),pReal) as_real = real(prec_bytesToC_FLOAT (asBytes(base64Str,headerType,compressed)),pREAL)
case('Float64') case('Float64')
as_real = real(prec_bytesToC_DOUBLE (asBytes(base64Str,headerType,compressed)),pReal) as_real = real(prec_bytesToC_DOUBLE (asBytes(base64Str,headerType,compressed)),pREAL)
case default case default
call IO_error(844,ext_msg='unknown data type: '//trim(dataType)) call IO_error(844,ext_msg='unknown data type: '//trim(dataType))
end select end select

52
src/grid/discretization_grid.f90
View File

@ -35,9 +35,9 @@ module discretization_grid
integer, public, protected :: & integer, public, protected :: &
cells3, & !< (local) cells in 3rd direction cells3, & !< (local) cells in 3rd direction
cells3Offset !< (local) cells offset in 3rd direction cells3Offset !< (local) cells offset in 3rd direction
real(pReal), dimension(3), public, protected :: & real(pREAL), dimension(3), public, protected :: &
geomSize !< (global) physical size geomSize !< (global) physical size
real(pReal), public, protected :: & real(pREAL), public, protected :: &
size3, & !< (local) size in 3rd direction size3, & !< (local) size in 3rd direction
size3offset !< (local) size offset in 3rd direction size3offset !< (local) size offset in 3rd direction
@ -55,7 +55,7 @@ subroutine discretization_grid_init(restart)
logical, intent(in) :: restart logical, intent(in) :: restart
real(pReal), dimension(3) :: & real(pREAL), dimension(3) :: &
mySize, & !< domain size of this process mySize, & !< domain size of this process
origin !< (global) distance to origin origin !< (global) distance to origin
integer, dimension(3) :: & integer, dimension(3) :: &
@ -119,8 +119,8 @@ subroutine discretization_grid_init(restart)
cells3 = int(z) cells3 = int(z)
cells3Offset = int(z_offset) cells3Offset = int(z_offset)
size3 = geomSize(3)*real(cells3,pReal) /real(cells(3),pReal) size3 = geomSize(3)*real(cells3,pREAL) /real(cells(3),pREAL)
size3Offset = geomSize(3)*real(cells3Offset,pReal)/real(cells(3),pReal) size3Offset = geomSize(3)*real(cells3Offset,pREAL)/real(cells(3),pREAL)
myGrid = [cells(1:2),cells3] myGrid = [cells(1:2),cells3]
mySize = [geomSize(1:2),size3] mySize = [geomSize(1:2),size3]
@ -156,7 +156,7 @@ subroutine discretization_grid_init(restart)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! geometry information required by the nonlocal CP model ! geometry information required by the nonlocal CP model
call geometry_plastic_nonlocal_setIPvolume(reshape([(product(mySize/real(myGrid,pReal)),j=1,product(myGrid))], & call geometry_plastic_nonlocal_setIPvolume(reshape([(product(mySize/real(myGrid,pREAL)),j=1,product(myGrid))], &
[1,product(myGrid)])) [1,product(myGrid)]))
call geometry_plastic_nonlocal_setIParea (cellSurfaceArea(mySize,myGrid)) call geometry_plastic_nonlocal_setIParea (cellSurfaceArea(mySize,myGrid))
call geometry_plastic_nonlocal_setIPareaNormal (cellSurfaceNormal(product(myGrid))) call geometry_plastic_nonlocal_setIPareaNormal (cellSurfaceNormal(product(myGrid)))
@ -171,10 +171,10 @@ end subroutine discretization_grid_init
function IPcoordinates0(cells,geomSize,cells3Offset) function IPcoordinates0(cells,geomSize,cells3Offset)
integer, dimension(3), intent(in) :: cells ! cells (for this process!) integer, dimension(3), intent(in) :: cells ! cells (for this process!)
real(pReal), dimension(3), intent(in) :: geomSize ! size (for this process!) real(pREAL), dimension(3), intent(in) :: geomSize ! size (for this process!)
integer, intent(in) :: cells3Offset ! cells(3) offset integer, intent(in) :: cells3Offset ! cells(3) offset
real(pReal), dimension(3,product(cells)) :: ipCoordinates0 real(pREAL), dimension(3,product(cells)) :: ipCoordinates0
integer :: & integer :: &
a,b,c, & a,b,c, &
@ -184,7 +184,7 @@ function IPcoordinates0(cells,geomSize,cells3Offset)
i = 0 i = 0
do c = 1, cells(3); do b = 1, cells(2); do a = 1, cells(1) do c = 1, cells(3); do b = 1, cells(2); do a = 1, cells(1)
i = i + 1 i = i + 1
IPcoordinates0(1:3,i) = geomSize/real(cells,pReal) * (real([a,b,cells3Offset+c],pReal) -0.5_pReal) IPcoordinates0(1:3,i) = geomSize/real(cells,pREAL) * (real([a,b,cells3Offset+c],pREAL) -0.5_pREAL)
end do; end do; end do end do; end do; end do
end function IPcoordinates0 end function IPcoordinates0
@ -196,10 +196,10 @@ end function IPcoordinates0
pure function nodes0(cells,geomSize,cells3Offset) pure function nodes0(cells,geomSize,cells3Offset)
integer, dimension(3), intent(in) :: cells ! cells (for this process!) integer, dimension(3), intent(in) :: cells ! cells (for this process!)
real(pReal), dimension(3), intent(in) :: geomSize ! size (for this process!) real(pREAL), dimension(3), intent(in) :: geomSize ! size (for this process!)
integer, intent(in) :: cells3Offset ! cells(3) offset integer, intent(in) :: cells3Offset ! cells(3) offset
real(pReal), dimension(3,product(cells+1)) :: nodes0 real(pREAL), dimension(3,product(cells+1)) :: nodes0
integer :: & integer :: &
a,b,c, & a,b,c, &
@ -208,7 +208,7 @@ pure function nodes0(cells,geomSize,cells3Offset)
n = 0 n = 0
do c = 0, cells3; do b = 0, cells(2); do a = 0, cells(1) do c = 0, cells3; do b = 0, cells(2); do a = 0, cells(1)
n = n + 1 n = n + 1
nodes0(1:3,n) = geomSize/real(cells,pReal) * real([a,b,cells3Offset+c],pReal) nodes0(1:3,n) = geomSize/real(cells,pREAL) * real([a,b,cells3Offset+c],pREAL)
end do; end do; end do end do; end do; end do
end function nodes0 end function nodes0
@ -219,15 +219,15 @@ end function nodes0
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function cellSurfaceArea(geomSize,cells) pure function cellSurfaceArea(geomSize,cells)
real(pReal), dimension(3), intent(in) :: geomSize ! size (for this process!) real(pREAL), dimension(3), intent(in) :: geomSize ! size (for this process!)
integer, dimension(3), intent(in) :: cells ! cells (for this process!) integer, dimension(3), intent(in) :: cells ! cells (for this process!)
real(pReal), dimension(6,1,product(cells)) :: cellSurfaceArea real(pREAL), dimension(6,1,product(cells)) :: cellSurfaceArea
cellSurfaceArea(1:2,1,:) = geomSize(2)/real(cells(2),pReal) * geomSize(3)/real(cells(3),pReal) cellSurfaceArea(1:2,1,:) = geomSize(2)/real(cells(2),pREAL) * geomSize(3)/real(cells(3),pREAL)
cellSurfaceArea(3:4,1,:) = geomSize(3)/real(cells(3),pReal) * geomSize(1)/real(cells(1),pReal) cellSurfaceArea(3:4,1,:) = geomSize(3)/real(cells(3),pREAL) * geomSize(1)/real(cells(1),pREAL)
cellSurfaceArea(5:6,1,:) = geomSize(1)/real(cells(1),pReal) * geomSize(2)/real(cells(2),pReal) cellSurfaceArea(5:6,1,:) = geomSize(1)/real(cells(1),pREAL) * geomSize(2)/real(cells(2),pREAL)
end function cellSurfaceArea end function cellSurfaceArea
@ -239,14 +239,14 @@ pure function cellSurfaceNormal(nElems)
integer, intent(in) :: nElems integer, intent(in) :: nElems
real(pReal), dimension(3,6,1,nElems) :: cellSurfaceNormal real(pREAL), dimension(3,6,1,nElems) :: cellSurfaceNormal
cellSurfaceNormal(1:3,1,1,:) = spread([+1.0_pReal, 0.0_pReal, 0.0_pReal],2,nElems) cellSurfaceNormal(1:3,1,1,:) = spread([+1.0_pREAL, 0.0_pREAL, 0.0_pREAL],2,nElems)
cellSurfaceNormal(1:3,2,1,:) = spread([-1.0_pReal, 0.0_pReal, 0.0_pReal],2,nElems) cellSurfaceNormal(1:3,2,1,:) = spread([-1.0_pREAL, 0.0_pREAL, 0.0_pREAL],2,nElems)
cellSurfaceNormal(1:3,3,1,:) = spread([ 0.0_pReal,+1.0_pReal, 0.0_pReal],2,nElems) cellSurfaceNormal(1:3,3,1,:) = spread([ 0.0_pREAL,+1.0_pREAL, 0.0_pREAL],2,nElems)
cellSurfaceNormal(1:3,4,1,:) = spread([ 0.0_pReal,-1.0_pReal, 0.0_pReal],2,nElems) cellSurfaceNormal(1:3,4,1,:) = spread([ 0.0_pREAL,-1.0_pREAL, 0.0_pREAL],2,nElems)
cellSurfaceNormal(1:3,5,1,:) = spread([ 0.0_pReal, 0.0_pReal,+1.0_pReal],2,nElems) cellSurfaceNormal(1:3,5,1,:) = spread([ 0.0_pREAL, 0.0_pREAL,+1.0_pREAL],2,nElems)
cellSurfaceNormal(1:3,6,1,:) = spread([ 0.0_pReal, 0.0_pReal,-1.0_pReal],2,nElems) cellSurfaceNormal(1:3,6,1,:) = spread([ 0.0_pREAL, 0.0_pREAL,-1.0_pREAL],2,nElems)
end function cellSurfaceNormal end function cellSurfaceNormal
@ -314,9 +314,9 @@ end function IPneighborhood
function discretization_grid_getInitialCondition(label) result(ic) function discretization_grid_getInitialCondition(label) result(ic)
character(len=*), intent(in) :: label character(len=*), intent(in) :: label
real(pReal), dimension(cells(1),cells(2),cells3) :: ic real(pREAL), dimension(cells(1),cells(2),cells3) :: ic
real(pReal), dimension(:), allocatable :: ic_global, ic_local real(pREAL), dimension(:), allocatable :: ic_global, ic_local
integer(MPI_INTEGER_KIND) :: err_MPI integer(MPI_INTEGER_KIND) :: err_MPI
integer, dimension(worldsize) :: & integer, dimension(worldsize) :: &

42
src/grid/grid_damage_spectral.f90
View File

@ -35,7 +35,7 @@ module grid_damage_spectral
type :: tNumerics type :: tNumerics
integer :: & integer :: &
itmax !< maximum number of iterations itmax !< maximum number of iterations
real(pReal) :: & real(pREAL) :: &
phi_min, & !< non-zero residual damage phi_min, & !< non-zero residual damage
eps_damage_atol, & !< absolute tolerance for damage evolution eps_damage_atol, & !< absolute tolerance for damage evolution
eps_damage_rtol !< relative tolerance for damage evolution eps_damage_rtol !< relative tolerance for damage evolution
@ -48,7 +48,7 @@ module grid_damage_spectral
! PETSc data ! PETSc data
SNES :: SNES_damage SNES :: SNES_damage
Vec :: solution_vec Vec :: solution_vec
real(pReal), dimension(:,:,:), allocatable :: & real(pREAL), dimension(:,:,:), allocatable :: &
phi, & !< field of current damage phi, & !< field of current damage
phi_lastInc, & !< field of previous damage phi_lastInc, & !< field of previous damage
phi_stagInc !< field of staggered damage phi_stagInc !< field of staggered damage
@ -56,8 +56,8 @@ module grid_damage_spectral
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! reference diffusion tensor, mobility etc. ! reference diffusion tensor, mobility etc.
integer :: totalIter = 0 !< total iteration in current increment integer :: totalIter = 0 !< total iteration in current increment
real(pReal), dimension(3,3) :: K_ref real(pREAL), dimension(3,3) :: K_ref
real(pReal) :: mu_ref real(pREAL) :: mu_ref
public :: & public :: &
grid_damage_spectral_init, & grid_damage_spectral_init, &
@ -75,12 +75,12 @@ subroutine grid_damage_spectral_init()
PetscInt, dimension(0:worldsize-1) :: localK PetscInt, dimension(0:worldsize-1) :: localK
integer :: i, j, k, ce integer :: i, j, k, ce
DM :: damage_grid DM :: damage_grid
real(pReal), dimension(:,:,:), pointer :: phi_PETSc real(pREAL), dimension(:,:,:), pointer :: phi_PETSc
Vec :: uBound, lBound Vec :: uBound, lBound
integer(MPI_INTEGER_KIND) :: err_MPI integer(MPI_INTEGER_KIND) :: err_MPI
PetscErrorCode :: err_PETSc PetscErrorCode :: err_PETSc
integer(HID_T) :: fileHandle, groupHandle integer(HID_T) :: fileHandle, groupHandle
real(pReal), dimension(1,product(cells(1:2))*cells3) :: tempN real(pREAL), dimension(1,product(cells(1:2))*cells3) :: tempN
type(tDict), pointer :: & type(tDict), pointer :: &
num_grid, & num_grid, &
num_generic num_generic
@ -98,16 +98,16 @@ subroutine grid_damage_spectral_init()
! read numerical parameters and do sanity checks ! read numerical parameters and do sanity checks
num_grid => config_numerics%get_dict('grid',defaultVal=emptyDict) num_grid => config_numerics%get_dict('grid',defaultVal=emptyDict)
num%itmax = num_grid%get_asInt ('itmax',defaultVal=250) num%itmax = num_grid%get_asInt ('itmax',defaultVal=250)
num%eps_damage_atol = num_grid%get_asReal ('eps_damage_atol',defaultVal=1.0e-2_pReal) num%eps_damage_atol = num_grid%get_asReal ('eps_damage_atol',defaultVal=1.0e-2_pREAL)
num%eps_damage_rtol = num_grid%get_asReal ('eps_damage_rtol',defaultVal=1.0e-6_pReal) num%eps_damage_rtol = num_grid%get_asReal ('eps_damage_rtol',defaultVal=1.0e-6_pREAL)
num_generic => config_numerics%get_dict('generic',defaultVal=emptyDict) num_generic => config_numerics%get_dict('generic',defaultVal=emptyDict)
num%phi_min = num_generic%get_asReal('phi_min', defaultVal=1.0e-6_pReal) num%phi_min = num_generic%get_asReal('phi_min', defaultVal=1.0e-6_pREAL)
if (num%phi_min < 0.0_pReal) call IO_error(301,ext_msg='phi_min') if (num%phi_min < 0.0_pREAL) call IO_error(301,ext_msg='phi_min')
if (num%itmax <= 1) call IO_error(301,ext_msg='itmax') if (num%itmax <= 1) call IO_error(301,ext_msg='itmax')
if (num%eps_damage_atol <= 0.0_pReal) call IO_error(301,ext_msg='eps_damage_atol') if (num%eps_damage_atol <= 0.0_pREAL) call IO_error(301,ext_msg='eps_damage_atol')
if (num%eps_damage_rtol <= 0.0_pReal) call IO_error(301,ext_msg='eps_damage_rtol') if (num%eps_damage_rtol <= 0.0_pREAL) call IO_error(301,ext_msg='eps_damage_rtol')
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! set default and user defined options for PETSc ! set default and user defined options for PETSc
@ -162,9 +162,9 @@ subroutine grid_damage_spectral_init()
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call DMGetGlobalVector(damage_grid,uBound,err_PETSc) call DMGetGlobalVector(damage_grid,uBound,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call VecSet(lBound,0.0_pReal,err_PETSc) call VecSet(lBound,0.0_pREAL,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call VecSet(uBound,1.0_pReal,err_PETSc) call VecSet(uBound,1.0_pREAL,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call SNESVISetVariableBounds(SNES_damage,lBound,uBound,err_PETSc) ! variable bounds for variational inequalities call SNESVISetVariableBounds(SNES_damage,lBound,uBound,err_PETSc) ! variable bounds for variational inequalities
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
@ -208,7 +208,7 @@ end subroutine grid_damage_spectral_init
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
function grid_damage_spectral_solution(Delta_t) result(solution) function grid_damage_spectral_solution(Delta_t) result(solution)
real(pReal), intent(in) :: & real(pREAL), intent(in) :: &
Delta_t !< increment in time for current solution Delta_t !< increment in time for current solution
integer :: i, j, k, ce integer :: i, j, k, ce
type(tSolutionState) :: solution type(tSolutionState) :: solution
@ -275,7 +275,7 @@ subroutine grid_damage_spectral_forward(cutBack)
integer :: i, j, k, ce integer :: i, j, k, ce
DM :: dm_local DM :: dm_local
real(pReal), dimension(:,:,:), pointer :: phi_PETSc real(pREAL), dimension(:,:,:), pointer :: phi_PETSc
PetscErrorCode :: err_PETSc PetscErrorCode :: err_PETSc
@ -341,15 +341,15 @@ subroutine formResidual(residual_subdomain,x_scal,r,dummy,err_PETSc)
DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: & DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: &
residual_subdomain residual_subdomain
real(pReal), dimension(cells(1),cells(2),cells3), intent(in) :: & real(pREAL), dimension(cells(1),cells(2),cells3), intent(in) :: &
x_scal x_scal
real(pReal), dimension(cells(1),cells(2),cells3), intent(out) :: & real(pREAL), dimension(cells(1),cells(2),cells3), intent(out) :: &
r !< residual r !< residual
PetscObject :: dummy PetscObject :: dummy
PetscErrorCode, intent(out) :: err_PETSc PetscErrorCode, intent(out) :: err_PETSc
integer :: i, j, k, ce integer :: i, j, k, ce
real(pReal), dimension(3,cells(1),cells(2),cells3) :: vectorField real(pREAL), dimension(3,cells(1),cells(2),cells3) :: vectorField
phi = x_scal phi = x_scal
@ -384,8 +384,8 @@ subroutine updateReference()
integer(MPI_INTEGER_KIND) :: err_MPI integer(MPI_INTEGER_KIND) :: err_MPI
K_ref = 0.0_pReal K_ref = 0.0_pREAL
mu_ref = 0.0_pReal mu_ref = 0.0_pREAL
do ce = 1, product(cells(1:2))*cells3 do ce = 1, product(cells(1:2))*cells3
K_ref = K_ref + homogenization_K_phi(ce) K_ref = K_ref + homogenization_K_phi(ce)
mu_ref = mu_ref + homogenization_mu_phi(ce) mu_ref = mu_ref + homogenization_mu_phi(ce)

166
src/grid/grid_mech_FEM.f90
View File

@ -41,7 +41,7 @@ module grid_mechanical_FEM
integer :: & integer :: &
itmin, & !< minimum number of iterations itmin, & !< minimum number of iterations
itmax !< maximum number of iterations itmax !< maximum number of iterations
real(pReal) :: & real(pREAL) :: &
eps_div_atol, & !< absolute tolerance for equilibrium eps_div_atol, & !< absolute tolerance for equilibrium
eps_div_rtol, & !< relative tolerance for equilibrium eps_div_rtol, & !< relative tolerance for equilibrium
eps_stress_atol, & !< absolute tolerance for fullfillment of stress BC eps_stress_atol, & !< absolute tolerance for fullfillment of stress BC
@ -58,27 +58,27 @@ module grid_mechanical_FEM
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! common pointwise data ! common pointwise data
real(pReal), dimension(:,:,:,:,:), allocatable :: F, P_current, F_lastInc real(pREAL), dimension(:,:,:,:,:), allocatable :: F, P_current, F_lastInc
real(pReal) :: detJ real(pREAL) :: detJ
real(pReal), dimension(3) :: delta real(pREAL), dimension(3) :: delta
real(pReal), dimension(3,8) :: BMat real(pREAL), dimension(3,8) :: BMat
real(pReal), dimension(8,8) :: HGMat real(pREAL), dimension(8,8) :: HGMat
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! stress, stiffness and compliance average etc. ! stress, stiffness and compliance average etc.
real(pReal), dimension(3,3) :: & real(pREAL), dimension(3,3) :: &
F_aimDot = 0.0_pReal, & !< assumed rate of average deformation gradient F_aimDot = 0.0_pREAL, & !< assumed rate of average deformation gradient
F_aim = math_I3, & !< current prescribed deformation gradient F_aim = math_I3, & !< current prescribed deformation gradient
F_aim_lastInc = math_I3, & !< previous average deformation gradient F_aim_lastInc = math_I3, & !< previous average deformation gradient
P_av = 0.0_pReal, & !< average 1st Piola--Kirchhoff stress P_av = 0.0_pREAL, & !< average 1st Piola--Kirchhoff stress
P_aim = 0.0_pReal P_aim = 0.0_pREAL
character(len=:), allocatable :: incInfo !< time and increment information character(len=:), allocatable :: incInfo !< time and increment information
real(pReal), dimension(3,3,3,3) :: & real(pREAL), dimension(3,3,3,3) :: &
C_volAvg = 0.0_pReal, & !< current volume average stiffness C_volAvg = 0.0_pREAL, & !< current volume average stiffness
C_volAvgLastInc = 0.0_pReal, & !< previous volume average stiffness C_volAvgLastInc = 0.0_pREAL, & !< previous volume average stiffness
S = 0.0_pReal !< current compliance (filled up with zeros) S = 0.0_pREAL !< current compliance (filled up with zeros)
real(pReal) :: & real(pREAL) :: &
err_BC !< deviation from stress BC err_BC !< deviation from stress BC
integer :: & integer :: &
@ -98,19 +98,19 @@ contains
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine grid_mechanical_FEM_init subroutine grid_mechanical_FEM_init
real(pReal), parameter :: HGCoeff = 0.0e-2_pReal real(pREAL), parameter :: HGCoeff = 0.0e-2_pREAL
real(pReal), parameter, dimension(4,8) :: & real(pREAL), parameter, dimension(4,8) :: &
HGcomp = reshape([ 1.0_pReal, 1.0_pReal, 1.0_pReal,-1.0_pReal, & HGcomp = reshape([ 1.0_pREAL, 1.0_pREAL, 1.0_pREAL,-1.0_pREAL, &
1.0_pReal,-1.0_pReal,-1.0_pReal, 1.0_pReal, & 1.0_pREAL,-1.0_pREAL,-1.0_pREAL, 1.0_pREAL, &
-1.0_pReal, 1.0_pReal,-1.0_pReal, 1.0_pReal, & -1.0_pREAL, 1.0_pREAL,-1.0_pREAL, 1.0_pREAL, &
-1.0_pReal,-1.0_pReal, 1.0_pReal,-1.0_pReal, & -1.0_pREAL,-1.0_pREAL, 1.0_pREAL,-1.0_pREAL, &
-1.0_pReal,-1.0_pReal, 1.0_pReal, 1.0_pReal, & -1.0_pREAL,-1.0_pREAL, 1.0_pREAL, 1.0_pREAL, &
-1.0_pReal, 1.0_pReal,-1.0_pReal,-1.0_pReal, & -1.0_pREAL, 1.0_pREAL,-1.0_pREAL,-1.0_pREAL, &
1.0_pReal,-1.0_pReal,-1.0_pReal,-1.0_pReal, & 1.0_pREAL,-1.0_pREAL,-1.0_pREAL,-1.0_pREAL, &
1.0_pReal, 1.0_pReal, 1.0_pReal, 1.0_pReal], [4,8]) 1.0_pREAL, 1.0_pREAL, 1.0_pREAL, 1.0_pREAL], [4,8])
real(pReal), dimension(3,3,3,3) :: devNull real(pREAL), dimension(3,3,3,3) :: devNull
real(pReal), dimension(3,3,product(cells(1:2))*cells3) :: temp33n real(pREAL), dimension(3,3,product(cells(1:2))*cells3) :: temp33n
real(pReal), dimension(3,product(cells(1:2))*cells3) :: temp3n real(pREAL), dimension(3,product(cells(1:2))*cells3) :: temp3n
PetscErrorCode :: err_PETSc PetscErrorCode :: err_PETSc
integer(MPI_INTEGER_KIND) :: err_MPI integer(MPI_INTEGER_KIND) :: err_MPI
PetscScalar, pointer, dimension(:,:,:,:) :: & PetscScalar, pointer, dimension(:,:,:,:) :: &
@ -129,17 +129,17 @@ subroutine grid_mechanical_FEM_init
! read numerical parameters and do sanity checks ! read numerical parameters and do sanity checks
num_grid => config_numerics%get_dict('grid',defaultVal=emptyDict) num_grid => config_numerics%get_dict('grid',defaultVal=emptyDict)
num%eps_div_atol = num_grid%get_asReal('eps_div_atol', defaultVal=1.0e-4_pReal) num%eps_div_atol = num_grid%get_asReal('eps_div_atol', defaultVal=1.0e-4_pREAL)
num%eps_div_rtol = num_grid%get_asReal('eps_div_rtol', defaultVal=5.0e-4_pReal) num%eps_div_rtol = num_grid%get_asReal('eps_div_rtol', defaultVal=5.0e-4_pREAL)
num%eps_stress_atol = num_grid%get_asReal('eps_stress_atol',defaultVal=1.0e3_pReal) num%eps_stress_atol = num_grid%get_asReal('eps_stress_atol',defaultVal=1.0e3_pREAL)
num%eps_stress_rtol = num_grid%get_asReal('eps_stress_rtol',defaultVal=1.0e-3_pReal) num%eps_stress_rtol = num_grid%get_asReal('eps_stress_rtol',defaultVal=1.0e-3_pREAL)
num%itmin = num_grid%get_asInt ('itmin',defaultVal=1) num%itmin = num_grid%get_asInt ('itmin',defaultVal=1)
num%itmax = num_grid%get_asInt ('itmax',defaultVal=250) num%itmax = num_grid%get_asInt ('itmax',defaultVal=250)
if (num%eps_div_atol <= 0.0_pReal) extmsg = trim(extmsg)//' eps_div_atol' if (num%eps_div_atol <= 0.0_pREAL) extmsg = trim(extmsg)//' eps_div_atol'
if (num%eps_div_rtol < 0.0_pReal) extmsg = trim(extmsg)//' eps_div_rtol' if (num%eps_div_rtol < 0.0_pREAL) extmsg = trim(extmsg)//' eps_div_rtol'
if (num%eps_stress_atol <= 0.0_pReal) extmsg = trim(extmsg)//' eps_stress_atol' if (num%eps_stress_atol <= 0.0_pREAL) extmsg = trim(extmsg)//' eps_stress_atol'
if (num%eps_stress_rtol < 0.0_pReal) extmsg = trim(extmsg)//' eps_stress_rtol' if (num%eps_stress_rtol < 0.0_pREAL) extmsg = trim(extmsg)//' eps_stress_rtol'
if (num%itmax <= 1) extmsg = trim(extmsg)//' itmax' if (num%itmax <= 1) extmsg = trim(extmsg)//' itmax'
if (num%itmin > num%itmax .or. num%itmin < 1) extmsg = trim(extmsg)//' itmin' if (num%itmin > num%itmax .or. num%itmin < 1) extmsg = trim(extmsg)//' itmin'
@ -157,9 +157,9 @@ subroutine grid_mechanical_FEM_init
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! allocate global fields ! allocate global fields
allocate(F (3,3,cells(1),cells(2),cells3),source = 0.0_pReal) allocate(F (3,3,cells(1),cells(2),cells3),source = 0.0_pREAL)
allocate(P_current (3,3,cells(1),cells(2),cells3),source = 0.0_pReal) allocate(P_current (3,3,cells(1),cells(2),cells3),source = 0.0_pREAL)
allocate(F_lastInc (3,3,cells(1),cells(2),cells3),source = 0.0_pReal) allocate(F_lastInc (3,3,cells(1),cells(2),cells3),source = 0.0_pREAL)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! initialize solver specific parts of PETSc ! initialize solver specific parts of PETSc
@ -184,7 +184,7 @@ subroutine grid_mechanical_FEM_init
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call DMsetUp(mechanical_grid,err_PETSc) call DMsetUp(mechanical_grid,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call DMDASetUniformCoordinates(mechanical_grid,0.0_pReal,geomSize(1),0.0_pReal,geomSize(2),0.0_pReal,geomSize(3),err_PETSc) call DMDASetUniformCoordinates(mechanical_grid,0.0_pREAL,geomSize(1),0.0_pREAL,geomSize(2),0.0_pREAL,geomSize(3),err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call DMCreateGlobalVector(mechanical_grid,solution_current,err_PETSc) call DMCreateGlobalVector(mechanical_grid,solution_current,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
@ -207,18 +207,18 @@ subroutine grid_mechanical_FEM_init
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! init fields ! init fields
call VecSet(solution_current,0.0_pReal,err_PETSc) call VecSet(solution_current,0.0_pREAL,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call VecSet(solution_lastInc,0.0_pReal,err_PETSc) call VecSet(solution_lastInc,0.0_pREAL,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call VecSet(solution_rate ,0.0_pReal,err_PETSc) call VecSet(solution_rate ,0.0_pREAL,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call DMDAVecGetArrayF90(mechanical_grid,solution_current,u,err_PETSc) call DMDAVecGetArrayF90(mechanical_grid,solution_current,u,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call DMDAVecGetArrayF90(mechanical_grid,solution_lastInc,u_lastInc,err_PETSc) call DMDAVecGetArrayF90(mechanical_grid,solution_lastInc,u_lastInc,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
delta = geomSize/real(cells,pReal) ! grid spacing delta = geomSize/real(cells,pREAL) ! grid spacing
detJ = product(delta) ! cell volume detJ = product(delta) ! cell volume
BMat = reshape(real([-delta(1)**(-1),-delta(2)**(-1),-delta(3)**(-1), & BMat = reshape(real([-delta(1)**(-1),-delta(2)**(-1),-delta(3)**(-1), &
@ -228,10 +228,10 @@ subroutine grid_mechanical_FEM_init
-delta(1)**(-1),-delta(2)**(-1), delta(3)**(-1), & -delta(1)**(-1),-delta(2)**(-1), delta(3)**(-1), &
delta(1)**(-1),-delta(2)**(-1), delta(3)**(-1), & delta(1)**(-1),-delta(2)**(-1), delta(3)**(-1), &
-delta(1)**(-1), delta(2)**(-1), delta(3)**(-1), & -delta(1)**(-1), delta(2)**(-1), delta(3)**(-1), &
delta(1)**(-1), delta(2)**(-1), delta(3)**(-1)],pReal), [3,8])/4.0_pReal ! shape function derivative matrix delta(1)**(-1), delta(2)**(-1), delta(3)**(-1)],pREAL), [3,8])/4.0_pREAL ! shape function derivative matrix
HGMat = matmul(transpose(HGcomp),HGcomp) & HGMat = matmul(transpose(HGcomp),HGcomp) &
* HGCoeff*(delta(1)*delta(2) + delta(2)*delta(3) + delta(3)*delta(1))/16.0_pReal ! hourglass stabilization matrix * HGCoeff*(delta(1)*delta(2) + delta(2)*delta(3) + delta(3)*delta(1))/16.0_pREAL ! hourglass stabilization matrix
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! init fields ! init fields
@ -271,7 +271,7 @@ subroutine grid_mechanical_FEM_init
call utilities_updateCoords(F) call utilities_updateCoords(F)
call utilities_constitutiveResponse(P_current,P_av,C_volAvg,devNull, & ! stress field, stress avg, global average of stiffness and (min+max)/2 call utilities_constitutiveResponse(P_current,P_av,C_volAvg,devNull, & ! stress field, stress avg, global average of stiffness and (min+max)/2
F, & ! target F F, & ! target F
0.0_pReal) ! time increment 0.0_pREAL) ! time increment
call DMDAVecRestoreArrayF90(mechanical_grid,solution_current,u,err_PETSc) call DMDAVecRestoreArrayF90(mechanical_grid,solution_current,u,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call DMDAVecRestoreArrayF90(mechanical_grid,solution_lastInc,u_lastInc,err_PETSc) call DMDAVecRestoreArrayF90(mechanical_grid,solution_lastInc,u_lastInc,err_PETSc)
@ -340,7 +340,7 @@ subroutine grid_mechanical_FEM_forward(cutBack,guess,Delta_t,Delta_t_old,t_remai
logical, intent(in) :: & logical, intent(in) :: &
cutBack, & cutBack, &
guess guess
real(pReal), intent(in) :: & real(pREAL), intent(in) :: &
Delta_t_old, & Delta_t_old, &
Delta_t, & Delta_t, &
t_remaining !< remaining time of current load case t_remaining !< remaining time of current load case
@ -365,29 +365,29 @@ subroutine grid_mechanical_FEM_forward(cutBack,guess,Delta_t,Delta_t_old,t_remai
else else
C_volAvgLastInc = C_volAvg C_volAvgLastInc = C_volAvg
F_aimDot = merge(merge(.0_pReal,(F_aim-F_aim_lastInc)/Delta_t_old,stress_BC%mask),.0_pReal,guess) ! estimate deformation rate for prescribed stress components F_aimDot = merge(merge(.0_pREAL,(F_aim-F_aim_lastInc)/Delta_t_old,stress_BC%mask),.0_pREAL,guess) ! estimate deformation rate for prescribed stress components
F_aim_lastInc = F_aim F_aim_lastInc = F_aim
!----------------------------------------------------------------------------------------------- !-----------------------------------------------------------------------------------------------
! calculate rate for aim ! calculate rate for aim
if (deformation_BC%myType=='L') then ! calculate F_aimDot from given L and current F if (deformation_BC%myType=='L') then ! calculate F_aimDot from given L and current F
F_aimDot = F_aimDot & F_aimDot = F_aimDot &
+ matmul(merge(.0_pReal,deformation_BC%values,deformation_BC%mask),F_aim_lastInc) + matmul(merge(.0_pREAL,deformation_BC%values,deformation_BC%mask),F_aim_lastInc)
elseif (deformation_BC%myType=='dot_F') then ! F_aimDot is prescribed elseif (deformation_BC%myType=='dot_F') then ! F_aimDot is prescribed
F_aimDot = F_aimDot & F_aimDot = F_aimDot &
+ merge(.0_pReal,deformation_BC%values,deformation_BC%mask) + merge(.0_pREAL,deformation_BC%values,deformation_BC%mask)
elseif (deformation_BC%myType=='F') then ! aim at end of load case is prescribed elseif (deformation_BC%myType=='F') then ! aim at end of load case is prescribed
F_aimDot = F_aimDot & F_aimDot = F_aimDot &
+ merge(.0_pReal,(deformation_BC%values - F_aim_lastInc)/t_remaining,deformation_BC%mask) + merge(.0_pREAL,(deformation_BC%values - F_aim_lastInc)/t_remaining,deformation_BC%mask)
end if end if
if (guess) then if (guess) then
call VecWAXPY(solution_rate,-1.0_pReal,solution_lastInc,solution_current,err_PETSc) call VecWAXPY(solution_rate,-1.0_pREAL,solution_lastInc,solution_current,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call VecScale(solution_rate,1.0_pReal/Delta_t_old,err_PETSc) call VecScale(solution_rate,1.0_pREAL/Delta_t_old,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
else else
call VecSet(solution_rate,0.0_pReal,err_PETSc) call VecSet(solution_rate,0.0_pREAL,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
end if end if
call VecCopy(solution_current,solution_lastInc,err_PETSc) call VecCopy(solution_current,solution_lastInc,err_PETSc)
@ -402,9 +402,9 @@ subroutine grid_mechanical_FEM_forward(cutBack,guess,Delta_t,Delta_t_old,t_remai
! update average and local deformation gradients ! update average and local deformation gradients
F_aim = F_aim_lastInc + F_aimDot * Delta_t F_aim = F_aim_lastInc + F_aimDot * Delta_t
if (stress_BC%myType=='P') P_aim = P_aim & if (stress_BC%myType=='P') P_aim = P_aim &
+ merge(.0_pReal,(stress_BC%values - P_aim)/t_remaining,stress_BC%mask)*Delta_t + merge(.0_pREAL,(stress_BC%values - P_aim)/t_remaining,stress_BC%mask)*Delta_t
if (stress_BC%myType=='dot_P') P_aim = P_aim & if (stress_BC%myType=='dot_P') P_aim = P_aim &
+ merge(.0_pReal,stress_BC%values,stress_BC%mask)*Delta_t + merge(.0_pREAL,stress_BC%values,stress_BC%mask)*Delta_t
call VecAXPY(solution_current,Delta_t,solution_rate,err_PETSc) call VecAXPY(solution_current,Delta_t,solution_rate,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
@ -493,7 +493,7 @@ subroutine converged(snes_local,PETScIter,devNull1,devNull2,fnorm,reason,dummy,e
SNESConvergedReason :: reason SNESConvergedReason :: reason
PetscObject :: dummy PetscObject :: dummy
PetscErrorCode :: err_PETSc PetscErrorCode :: err_PETSc
real(pReal) :: & real(pREAL) :: &
err_div, & err_div, &
divTol, & divTol, &
BCTol BCTol
@ -502,7 +502,7 @@ subroutine converged(snes_local,PETScIter,devNull1,devNull2,fnorm,reason,dummy,e
divTol = max(maxval(abs(P_av))*num%eps_div_rtol, num%eps_div_atol) divTol = max(maxval(abs(P_av))*num%eps_div_rtol, num%eps_div_atol)
BCTol = max(maxval(abs(P_av))*num%eps_stress_rtol, num%eps_stress_atol) BCTol = max(maxval(abs(P_av))*num%eps_stress_rtol, num%eps_stress_atol)
if ((totalIter >= num%itmin .and. all([err_div/divTol, err_BC/BCTol] < 1.0_pReal)) & if ((totalIter >= num%itmin .and. all([err_div/divTol, err_BC/BCTol] < 1.0_pREAL)) &
.or. terminallyIll) then .or. terminallyIll) then
reason = 1 reason = 1
elseif (totalIter >= num%itmax) then elseif (totalIter >= num%itmax) then
@ -534,14 +534,14 @@ subroutine formResidual(da_local,x_local, &
PetscObject :: dummy PetscObject :: dummy
PetscErrorCode :: err_PETSc PetscErrorCode :: err_PETSc
real(pReal), pointer,dimension(:,:,:,:) :: x_scal, r real(pREAL), pointer,dimension(:,:,:,:) :: x_scal, r
real(pReal), dimension(8,3) :: x_elem, f_elem real(pREAL), dimension(8,3) :: x_elem, f_elem
PetscInt :: i, ii, j, jj, k, kk, ctr, ele PetscInt :: i, ii, j, jj, k, kk, ctr, ele
PetscInt :: & PetscInt :: &
PETScIter, & PETScIter, &
nfuncs nfuncs
integer(MPI_INTEGER_KIND) :: err_MPI integer(MPI_INTEGER_KIND) :: err_MPI
real(pReal), dimension(3,3,3,3) :: devNull real(pREAL), dimension(3,3,3,3) :: devNull
call SNESGetNumberFunctionEvals(SNES_mechanical,nfuncs,err_PETSc) call SNESGetNumberFunctionEvals(SNES_mechanical,nfuncs,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
@ -556,7 +556,7 @@ subroutine formResidual(da_local,x_local, &
newIteration: if (totalIter <= PETScIter) then newIteration: if (totalIter <= PETScIter) then
totalIter = totalIter + 1 totalIter = totalIter + 1
print'(1x,a,3(a,i0))', trim(incInfo), ' @ Iteration ', num%itmin, '≤',totalIter+1, '≤', num%itmax print'(1x,a,3(a,i0))', trim(incInfo), ' @ Iteration ', num%itmin, '≤',totalIter+1, '≤', num%itmax
if (any(dNeq(params%rotation_BC%asQuaternion(), real([1.0, 0.0, 0.0, 0.0],pReal)))) & if (any(dNeq(params%rotation_BC%asQuaternion(), real([1.0, 0.0, 0.0, 0.0],pREAL)))) &
print'(/,1x,a,/,2(3(f12.7,1x)/),3(f12.7,1x))', & print'(/,1x,a,/,2(3(f12.7,1x)/),3(f12.7,1x))', &
'deformation gradient aim (lab) =', transpose(params%rotation_BC%rotate(F_aim,active=.true.)) 'deformation gradient aim (lab) =', transpose(params%rotation_BC%rotate(F_aim,active=.true.))
print'(/,1x,a,/,2(3(f12.7,1x)/),3(f12.7,1x))', & print'(/,1x,a,/,2(3(f12.7,1x)/),3(f12.7,1x))', &
@ -590,7 +590,7 @@ subroutine formResidual(da_local,x_local, &
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! stress BC handling ! stress BC handling
F_aim = F_aim - math_mul3333xx33(S, P_av - P_aim) ! S = 0.0 for no bc F_aim = F_aim - math_mul3333xx33(S, P_av - P_aim) ! S = 0.0 for no bc
err_BC = maxval(abs(merge(.0_pReal,P_av - P_aim,params%stress_mask))) err_BC = maxval(abs(merge(.0_pREAL,P_av - P_aim,params%stress_mask)))
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! constructing residual ! constructing residual
@ -599,7 +599,7 @@ subroutine formResidual(da_local,x_local, &
call DMDAVecGetArrayF90(da_local,x_local,x_scal,err_PETSc) call DMDAVecGetArrayF90(da_local,x_local,x_scal,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
ele = 0 ele = 0
r = 0.0_pReal r = 0.0_pREAL
do k = cells3Offset+1, cells3Offset+cells3; do j = 1, cells(2); do i = 1, cells(1) do k = cells3Offset+1, cells3Offset+cells3; do j = 1, cells(2); do i = 1, cells(1)
ctr = 0 ctr = 0
do kk = -1, 0; do jj = -1, 0; do ii = -1, 0 do kk = -1, 0; do jj = -1, 0; do ii = -1, 0
@ -610,7 +610,7 @@ subroutine formResidual(da_local,x_local, &
f_elem = matmul(transpose(BMat),transpose(P_current(1:3,1:3,i,j,k-cells3Offset)))*detJ + & f_elem = matmul(transpose(BMat),transpose(P_current(1:3,1:3,i,j,k-cells3Offset)))*detJ + &
matmul(HGMat,x_elem)*(homogenization_dPdF(1,1,1,1,ele) + & matmul(HGMat,x_elem)*(homogenization_dPdF(1,1,1,1,ele) + &
homogenization_dPdF(2,2,2,2,ele) + & homogenization_dPdF(2,2,2,2,ele) + &
homogenization_dPdF(3,3,3,3,ele))/3.0_pReal homogenization_dPdF(3,3,3,3,ele))/3.0_pREAL
ctr = 0 ctr = 0
do kk = -1, 0; do jj = -1, 0; do ii = -1, 0 do kk = -1, 0; do jj = -1, 0; do ii = -1, 0
ctr = ctr + 1 ctr = ctr + 1
@ -623,16 +623,16 @@ subroutine formResidual(da_local,x_local, &
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! applying boundary conditions ! applying boundary conditions
if (cells3Offset == 0) then if (cells3Offset == 0) then
r(0:2,0, 0, 0) = 0.0_pReal r(0:2,0, 0, 0) = 0.0_pREAL
r(0:2,cells(1),0, 0) = 0.0_pReal r(0:2,cells(1),0, 0) = 0.0_pREAL
r(0:2,0, cells(2),0) = 0.0_pReal r(0:2,0, cells(2),0) = 0.0_pREAL
r(0:2,cells(1),cells(2),0) = 0.0_pReal r(0:2,cells(1),cells(2),0) = 0.0_pREAL
end if end if
if (cells3+cells3Offset == cells(3)) then if (cells3+cells3Offset == cells(3)) then
r(0:2,0, 0, cells(3)) = 0.0_pReal r(0:2,0, 0, cells(3)) = 0.0_pREAL
r(0:2,cells(1),0, cells(3)) = 0.0_pReal r(0:2,cells(1),0, cells(3)) = 0.0_pREAL
r(0:2,0, cells(2),cells(3)) = 0.0_pReal r(0:2,0, cells(2),cells(3)) = 0.0_pREAL
r(0:2,cells(1),cells(2),cells(3)) = 0.0_pReal r(0:2,cells(1),cells(2),cells(3)) = 0.0_pREAL
end if end if
call DMDAVecRestoreArrayF90(da_local,f_local,r,err_PETSc) call DMDAVecRestoreArrayF90(da_local,f_local,r,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
@ -652,17 +652,17 @@ subroutine formJacobian(da_local,x_local,Jac_pre,Jac,dummy,err_PETSc)
PetscErrorCode :: err_PETSc PetscErrorCode :: err_PETSc
MatStencil,dimension(4,24) :: row, col MatStencil,dimension(4,24) :: row, col
real(pReal),pointer,dimension(:,:,:,:) :: x_scal real(pREAL),pointer,dimension(:,:,:,:) :: x_scal
real(pReal),dimension(24,24) :: K_ele real(pREAL),dimension(24,24) :: K_ele
real(pReal),dimension(9,24) :: BMatFull real(pREAL),dimension(9,24) :: BMatFull
PetscInt :: i, ii, j, jj, k, kk, ctr, ce PetscInt :: i, ii, j, jj, k, kk, ctr, ce
PetscInt,dimension(3),parameter :: rows = [0, 1, 2] PetscInt,dimension(3),parameter :: rows = [0, 1, 2]
real(pReal) :: diag real(pREAL) :: diag
MatNullSpace :: matnull MatNullSpace :: matnull
Vec :: coordinates Vec :: coordinates
BMatFull = 0.0_pReal BMatFull = 0.0_pREAL
BMatFull(1:3,1 :8 ) = BMat BMatFull(1:3,1 :8 ) = BMat
BMatFull(4:6,9 :16) = BMat BMatFull(4:6,9 :16) = BMat
BMatFull(7:9,17:24) = BMat BMatFull(7:9,17:24) = BMat
@ -692,16 +692,16 @@ subroutine formJacobian(da_local,x_local,Jac_pre,Jac,dummy,err_PETSc)
end do; end do; end do end do; end do; end do
row = col row = col
ce = ce + 1 ce = ce + 1
K_ele = 0.0_pReal K_ele = 0.0_pREAL
K_ele(1 :8 ,1 :8 ) = HGMat*(homogenization_dPdF(1,1,1,1,ce) + & K_ele(1 :8 ,1 :8 ) = HGMat*(homogenization_dPdF(1,1,1,1,ce) + &
homogenization_dPdF(2,2,2,2,ce) + & homogenization_dPdF(2,2,2,2,ce) + &
homogenization_dPdF(3,3,3,3,ce))/3.0_pReal homogenization_dPdF(3,3,3,3,ce))/3.0_pREAL
K_ele(9 :16,9 :16) = HGMat*(homogenization_dPdF(1,1,1,1,ce) + & K_ele(9 :16,9 :16) = HGMat*(homogenization_dPdF(1,1,1,1,ce) + &
homogenization_dPdF(2,2,2,2,ce) + & homogenization_dPdF(2,2,2,2,ce) + &
homogenization_dPdF(3,3,3,3,ce))/3.0_pReal homogenization_dPdF(3,3,3,3,ce))/3.0_pREAL
K_ele(17:24,17:24) = HGMat*(homogenization_dPdF(1,1,1,1,ce) + & K_ele(17:24,17:24) = HGMat*(homogenization_dPdF(1,1,1,1,ce) + &
homogenization_dPdF(2,2,2,2,ce) + & homogenization_dPdF(2,2,2,2,ce) + &
homogenization_dPdF(3,3,3,3,ce))/3.0_pReal homogenization_dPdF(3,3,3,3,ce))/3.0_pREAL
K_ele = K_ele + & K_ele = K_ele + &
matmul(transpose(BMatFull), & matmul(transpose(BMatFull), &
matmul(reshape(reshape(homogenization_dPdF(1:3,1:3,1:3,1:3,ce), & matmul(reshape(reshape(homogenization_dPdF(1:3,1:3,1:3,1:3,ce), &

90
src/grid/grid_mech_spectral_basic.f90
View File

@ -40,7 +40,7 @@ module grid_mechanical_spectral_basic
integer :: & integer :: &
itmin, & !< minimum number of iterations itmin, & !< minimum number of iterations
itmax !< maximum number of iterations itmax !< maximum number of iterations
real(pReal) :: & real(pREAL) :: &
eps_div_atol, & !< absolute tolerance for equilibrium eps_div_atol, & !< absolute tolerance for equilibrium
eps_div_rtol, & !< relative tolerance for equilibrium eps_div_rtol, & !< relative tolerance for equilibrium
eps_stress_atol, & !< absolute tolerance for fullfillment of stress BC eps_stress_atol, & !< absolute tolerance for fullfillment of stress BC
@ -57,28 +57,28 @@ module grid_mechanical_spectral_basic
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! common pointwise data ! common pointwise data
real(pReal), dimension(:,:,:,:,:), allocatable :: & real(pREAL), dimension(:,:,:,:,:), allocatable :: &
F_lastInc, & !< field of previous compatible deformation gradients F_lastInc, & !< field of previous compatible deformation gradients
Fdot !< field of assumed rate of compatible deformation gradient Fdot !< field of assumed rate of compatible deformation gradient
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! stress, stiffness and compliance average etc. ! stress, stiffness and compliance average etc.
real(pReal), dimension(3,3) :: & real(pREAL), dimension(3,3) :: &
F_aimDot = 0.0_pReal, & !< assumed rate of average deformation gradient F_aimDot = 0.0_pREAL, & !< assumed rate of average deformation gradient
F_aim = math_I3, & !< current prescribed deformation gradient F_aim = math_I3, & !< current prescribed deformation gradient
F_aim_lastInc = math_I3, & !< previous average deformation gradient F_aim_lastInc = math_I3, & !< previous average deformation gradient
P_av = 0.0_pReal, & !< average 1st Piola--Kirchhoff stress P_av = 0.0_pREAL, & !< average 1st Piola--Kirchhoff stress
P_aim = 0.0_pReal P_aim = 0.0_pREAL
character(len=:), allocatable :: incInfo !< time and increment information character(len=:), allocatable :: incInfo !< time and increment information
real(pReal), dimension(3,3,3,3) :: & real(pREAL), dimension(3,3,3,3) :: &
C_volAvg = 0.0_pReal, & !< current volume average stiffness C_volAvg = 0.0_pREAL, & !< current volume average stiffness
C_volAvgLastInc = 0.0_pReal, & !< previous volume average stiffness C_volAvgLastInc = 0.0_pREAL, & !< previous volume average stiffness
C_minMaxAvg = 0.0_pReal, & !< current (min+max)/2 stiffness C_minMaxAvg = 0.0_pREAL, & !< current (min+max)/2 stiffness
C_minMaxAvgLastInc = 0.0_pReal, & !< previous (min+max)/2 stiffness C_minMaxAvgLastInc = 0.0_pREAL, & !< previous (min+max)/2 stiffness
C_minMaxAvgRestart = 0.0_pReal, & !< (min+max)/2 stiffnes (restart) C_minMaxAvgRestart = 0.0_pREAL, & !< (min+max)/2 stiffnes (restart)
S = 0.0_pReal !< current compliance (filled up with zeros) S = 0.0_pREAL !< current compliance (filled up with zeros)
real(pReal) :: & real(pREAL) :: &
err_BC, & !< deviation from stress BC err_BC, & !< deviation from stress BC
err_div !< RMS of div of P err_div !< RMS of div of P
@ -105,13 +105,13 @@ contains
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine grid_mechanical_spectral_basic_init() subroutine grid_mechanical_spectral_basic_init()
real(pReal), dimension(3,3,cells(1),cells(2),cells3) :: P real(pREAL), dimension(3,3,cells(1),cells(2),cells3) :: P
PetscErrorCode :: err_PETSc PetscErrorCode :: err_PETSc
integer(MPI_INTEGER_KIND) :: err_MPI integer(MPI_INTEGER_KIND) :: err_MPI
real(pReal), pointer, dimension(:,:,:,:) :: & real(pREAL), pointer, dimension(:,:,:,:) :: &
F ! pointer to solution data F ! pointer to solution data
PetscInt, dimension(0:worldsize-1) :: localK PetscInt, dimension(0:worldsize-1) :: localK
real(pReal), dimension(3,3,product(cells(1:2))*cells3) :: temp33n real(pREAL), dimension(3,3,product(cells(1:2))*cells3) :: temp33n
integer(HID_T) :: fileHandle, groupHandle integer(HID_T) :: fileHandle, groupHandle
type(tDict), pointer :: & type(tDict), pointer :: &
num_grid num_grid
@ -132,17 +132,17 @@ subroutine grid_mechanical_spectral_basic_init()
num_grid => config_numerics%get_dict('grid',defaultVal=emptyDict) num_grid => config_numerics%get_dict('grid',defaultVal=emptyDict)
num%update_gamma = num_grid%get_asBool('update_gamma', defaultVal=.false.) num%update_gamma = num_grid%get_asBool('update_gamma', defaultVal=.false.)
num%eps_div_atol = num_grid%get_asReal('eps_div_atol', defaultVal=1.0e-4_pReal) num%eps_div_atol = num_grid%get_asReal('eps_div_atol', defaultVal=1.0e-4_pREAL)
num%eps_div_rtol = num_grid%get_asReal('eps_div_rtol', defaultVal=5.0e-4_pReal) num%eps_div_rtol = num_grid%get_asReal('eps_div_rtol', defaultVal=5.0e-4_pREAL)
num%eps_stress_atol = num_grid%get_asReal('eps_stress_atol',defaultVal=1.0e3_pReal) num%eps_stress_atol = num_grid%get_asReal('eps_stress_atol',defaultVal=1.0e3_pREAL)
num%eps_stress_rtol = num_grid%get_asReal('eps_stress_rtol',defaultVal=1.0e-3_pReal) num%eps_stress_rtol = num_grid%get_asReal('eps_stress_rtol',defaultVal=1.0e-3_pREAL)
num%itmin = num_grid%get_asInt ('itmin',defaultVal=1) num%itmin = num_grid%get_asInt ('itmin',defaultVal=1)
num%itmax = num_grid%get_asInt ('itmax',defaultVal=250) num%itmax = num_grid%get_asInt ('itmax',defaultVal=250)
if (num%eps_div_atol <= 0.0_pReal) extmsg = trim(extmsg)//' eps_div_atol' if (num%eps_div_atol <= 0.0_pREAL) extmsg = trim(extmsg)//' eps_div_atol'
if (num%eps_div_rtol < 0.0_pReal) extmsg = trim(extmsg)//' eps_div_rtol' if (num%eps_div_rtol < 0.0_pREAL) extmsg = trim(extmsg)//' eps_div_rtol'
if (num%eps_stress_atol <= 0.0_pReal) extmsg = trim(extmsg)//' eps_stress_atol' if (num%eps_stress_atol <= 0.0_pREAL) extmsg = trim(extmsg)//' eps_stress_atol'
if (num%eps_stress_rtol < 0.0_pReal) extmsg = trim(extmsg)//' eps_stress_rtol' if (num%eps_stress_rtol < 0.0_pREAL) extmsg = trim(extmsg)//' eps_stress_rtol'
if (num%itmax <= 1) extmsg = trim(extmsg)//' itmax' if (num%itmax <= 1) extmsg = trim(extmsg)//' itmax'
if (num%itmin > num%itmax .or. num%itmin < 1) extmsg = trim(extmsg)//' itmin' if (num%itmin > num%itmax .or. num%itmin < 1) extmsg = trim(extmsg)//' itmin'
@ -157,8 +157,8 @@ subroutine grid_mechanical_spectral_basic_init()
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! allocate global fields ! allocate global fields
allocate(F_lastInc(3,3,cells(1),cells(2),cells3),source = 0.0_pReal) allocate(F_lastInc(3,3,cells(1),cells(2),cells3),source = 0.0_pREAL)
allocate(Fdot (3,3,cells(1),cells(2),cells3),source = 0.0_pReal) allocate(Fdot (3,3,cells(1),cells(2),cells3),source = 0.0_pREAL)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! initialize solver specific parts of PETSc ! initialize solver specific parts of PETSc
@ -231,7 +231,7 @@ subroutine grid_mechanical_spectral_basic_init()
call utilities_updateCoords(reshape(F,shape(F_lastInc))) call utilities_updateCoords(reshape(F,shape(F_lastInc)))
call utilities_constitutiveResponse(P,P_av,C_volAvg,C_minMaxAvg, & ! stress field, stress avg, global average of stiffness and (min+max)/2 call utilities_constitutiveResponse(P,P_av,C_volAvg,C_minMaxAvg, & ! stress field, stress avg, global average of stiffness and (min+max)/2
reshape(F,shape(F_lastInc)), & ! target F reshape(F,shape(F_lastInc)), & ! target F
0.0_pReal) ! time increment 0.0_pREAL) ! time increment
call DMDAVecRestoreArrayF90(da,solution_vec,F,err_PETSc) ! deassociate pointer call DMDAVecRestoreArrayF90(da,solution_vec,F,err_PETSc) ! deassociate pointer
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
@ -305,7 +305,7 @@ subroutine grid_mechanical_spectral_basic_forward(cutBack,guess,Delta_t,Delta_t_
logical, intent(in) :: & logical, intent(in) :: &
cutBack, & cutBack, &
guess guess
real(pReal), intent(in) :: & real(pREAL), intent(in) :: &
Delta_t_old, & Delta_t_old, &
Delta_t, & Delta_t, &
t_remaining !< remaining time of current load case t_remaining !< remaining time of current load case
@ -315,7 +315,7 @@ subroutine grid_mechanical_spectral_basic_forward(cutBack,guess,Delta_t,Delta_t_
type(tRotation), intent(in) :: & type(tRotation), intent(in) :: &
rotation_BC rotation_BC
PetscErrorCode :: err_PETSc PetscErrorCode :: err_PETSc
real(pReal), pointer, dimension(:,:,:,:) :: F real(pREAL), pointer, dimension(:,:,:,:) :: F
call DMDAVecGetArrayF90(da,solution_vec,F,err_PETSc) call DMDAVecGetArrayF90(da,solution_vec,F,err_PETSc)
@ -328,20 +328,20 @@ subroutine grid_mechanical_spectral_basic_forward(cutBack,guess,Delta_t,Delta_t_
C_volAvgLastInc = C_volAvg C_volAvgLastInc = C_volAvg
C_minMaxAvgLastInc = C_minMaxAvg C_minMaxAvgLastInc = C_minMaxAvg
F_aimDot = merge(merge(.0_pReal,(F_aim-F_aim_lastInc)/Delta_t_old,stress_BC%mask),.0_pReal,guess) ! estimate deformation rate for prescribed stress components F_aimDot = merge(merge(.0_pREAL,(F_aim-F_aim_lastInc)/Delta_t_old,stress_BC%mask),.0_pREAL,guess) ! estimate deformation rate for prescribed stress components
F_aim_lastInc = F_aim F_aim_lastInc = F_aim
!----------------------------------------------------------------------------------------------- !-----------------------------------------------------------------------------------------------
! calculate rate for aim ! calculate rate for aim
if (deformation_BC%myType=='L') then ! calculate F_aimDot from given L and current F if (deformation_BC%myType=='L') then ! calculate F_aimDot from given L and current F
F_aimDot = F_aimDot & F_aimDot = F_aimDot &
+ matmul(merge(.0_pReal,deformation_BC%values,deformation_BC%mask),F_aim_lastInc) + matmul(merge(.0_pREAL,deformation_BC%values,deformation_BC%mask),F_aim_lastInc)
elseif (deformation_BC%myType=='dot_F') then ! F_aimDot is prescribed elseif (deformation_BC%myType=='dot_F') then ! F_aimDot is prescribed
F_aimDot = F_aimDot & F_aimDot = F_aimDot &
+ merge(.0_pReal,deformation_BC%values,deformation_BC%mask) + merge(.0_pREAL,deformation_BC%values,deformation_BC%mask)
elseif (deformation_BC%myType=='F') then ! aim at end of load case is prescribed elseif (deformation_BC%myType=='F') then ! aim at end of load case is prescribed
F_aimDot = F_aimDot & F_aimDot = F_aimDot &
+ merge(.0_pReal,(deformation_BC%values - F_aim_lastInc)/t_remaining,deformation_BC%mask) + merge(.0_pREAL,(deformation_BC%values - F_aim_lastInc)/t_remaining,deformation_BC%mask)
end if end if
Fdot = utilities_calculateRate(guess, & Fdot = utilities_calculateRate(guess, &
@ -356,9 +356,9 @@ subroutine grid_mechanical_spectral_basic_forward(cutBack,guess,Delta_t,Delta_t_
! update average and local deformation gradients ! update average and local deformation gradients
F_aim = F_aim_lastInc + F_aimDot * Delta_t F_aim = F_aim_lastInc + F_aimDot * Delta_t
if (stress_BC%myType=='P') P_aim = P_aim & if (stress_BC%myType=='P') P_aim = P_aim &
+ merge(.0_pReal,(stress_BC%values - P_aim)/t_remaining,stress_BC%mask)*Delta_t + merge(.0_pREAL,(stress_BC%values - P_aim)/t_remaining,stress_BC%mask)*Delta_t
if (stress_BC%myType=='dot_P') P_aim = P_aim & if (stress_BC%myType=='dot_P') P_aim = P_aim &
+ merge(.0_pReal,stress_BC%values,stress_BC%mask)*Delta_t + merge(.0_pREAL,stress_BC%values,stress_BC%mask)*Delta_t
F = reshape(utilities_forwardField(Delta_t,F_lastInc,Fdot, & ! estimate of F at end of time+Delta_t that matches rotated F_aim on average F = reshape(utilities_forwardField(Delta_t,F_lastInc,Fdot, & ! estimate of F at end of time+Delta_t that matches rotated F_aim on average
rotation_BC%rotate(F_aim,active=.true.)),[9,cells(1),cells(2),cells3]) rotation_BC%rotate(F_aim,active=.true.)),[9,cells(1),cells(2),cells3])
@ -380,7 +380,7 @@ end subroutine grid_mechanical_spectral_basic_forward
subroutine grid_mechanical_spectral_basic_updateCoords subroutine grid_mechanical_spectral_basic_updateCoords
PetscErrorCode :: err_PETSc PetscErrorCode :: err_PETSc
real(pReal), dimension(:,:,:,:), pointer :: F real(pREAL), dimension(:,:,:,:), pointer :: F
call DMDAVecGetArrayF90(da,solution_vec,F,err_PETSc) call DMDAVecGetArrayF90(da,solution_vec,F,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
@ -398,7 +398,7 @@ subroutine grid_mechanical_spectral_basic_restartWrite
PetscErrorCode :: err_PETSc PetscErrorCode :: err_PETSc
integer(HID_T) :: fileHandle, groupHandle integer(HID_T) :: fileHandle, groupHandle
real(pReal), dimension(:,:,:,:), pointer :: F real(pREAL), dimension(:,:,:,:), pointer :: F
call DMDAVecGetArrayF90(da,solution_vec,F,err_PETSc) call DMDAVecGetArrayF90(da,solution_vec,F,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
@ -448,14 +448,14 @@ subroutine converged(snes_local,PETScIter,devNull1,devNull2,devNull3,reason,dumm
SNESConvergedReason :: reason SNESConvergedReason :: reason
PetscObject :: dummy PetscObject :: dummy
PetscErrorCode :: err_PETSc PetscErrorCode :: err_PETSc
real(pReal) :: & real(pREAL) :: &
divTol, & divTol, &
BCTol BCTol
divTol = max(maxval(abs(P_av))*num%eps_div_rtol, num%eps_div_atol) divTol = max(maxval(abs(P_av))*num%eps_div_rtol, num%eps_div_atol)
BCTol = max(maxval(abs(P_av))*num%eps_stress_rtol, num%eps_stress_atol) BCTol = max(maxval(abs(P_av))*num%eps_stress_rtol, num%eps_stress_atol)
if ((totalIter >= num%itmin .and. all([err_div/divTol, err_BC/BCTol] < 1.0_pReal)) & if ((totalIter >= num%itmin .and. all([err_div/divTol, err_BC/BCTol] < 1.0_pREAL)) &
.or. terminallyIll) then .or. terminallyIll) then
reason = 1 reason = 1
elseif (totalIter >= num%itmax) then elseif (totalIter >= num%itmax) then
@ -484,14 +484,14 @@ subroutine formResidual(residual_subdomain, F, &
DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: & DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: &
residual_subdomain !< DMDA info (needs to be named "in" for macros like XRANGE to work) residual_subdomain !< DMDA info (needs to be named "in" for macros like XRANGE to work)
real(pReal), dimension(3,3,cells(1),cells(2),cells3), intent(in) :: & real(pREAL), dimension(3,3,cells(1),cells(2),cells3), intent(in) :: &
F !< deformation gradient field F !< deformation gradient field
real(pReal), dimension(3,3,cells(1),cells(2),cells3), intent(out) :: & real(pREAL), dimension(3,3,cells(1),cells(2),cells3), intent(out) :: &
r !< residuum field r !< residuum field
PetscObject :: dummy PetscObject :: dummy
PetscErrorCode :: err_PETSc PetscErrorCode :: err_PETSc
real(pReal), dimension(3,3) :: & real(pREAL), dimension(3,3) :: &
deltaF_aim deltaF_aim
PetscInt :: & PetscInt :: &
PETScIter, & PETScIter, &
@ -509,7 +509,7 @@ subroutine formResidual(residual_subdomain, F, &
newIteration: if (totalIter <= PETScIter) then newIteration: if (totalIter <= PETScIter) then
totalIter = totalIter + 1 totalIter = totalIter + 1
print'(1x,a,3(a,i0))', trim(incInfo), ' @ Iteration ', num%itmin, '≤',totalIter, '≤', num%itmax print'(1x,a,3(a,i0))', trim(incInfo), ' @ Iteration ', num%itmin, '≤',totalIter, '≤', num%itmax
if (any(dNeq(params%rotation_BC%asQuaternion(), real([1.0, 0.0, 0.0, 0.0],pReal)))) & if (any(dNeq(params%rotation_BC%asQuaternion(), real([1.0, 0.0, 0.0, 0.0],pREAL)))) &
print'(/,1x,a,/,2(3(f12.7,1x)/),3(f12.7,1x))', & print'(/,1x,a,/,2(3(f12.7,1x)/),3(f12.7,1x))', &
'deformation gradient aim (lab) =', transpose(params%rotation_BC%rotate(F_aim,active=.true.)) 'deformation gradient aim (lab) =', transpose(params%rotation_BC%rotate(F_aim,active=.true.))
print'(/,1x,a,/,2(3(f12.7,1x)/),3(f12.7,1x))', & print'(/,1x,a,/,2(3(f12.7,1x)/),3(f12.7,1x))', &
@ -528,7 +528,7 @@ subroutine formResidual(residual_subdomain, F, &
deltaF_aim = math_mul3333xx33(S, P_av - P_aim) ! S = 0.0 for no bc deltaF_aim = math_mul3333xx33(S, P_av - P_aim) ! S = 0.0 for no bc
F_aim = F_aim - deltaF_aim F_aim = F_aim - deltaF_aim
err_BC = maxval(abs(merge(.0_pReal,P_av - P_aim,params%stress_mask))) err_BC = maxval(abs(merge(.0_pREAL,P_av - P_aim,params%stress_mask)))
r = utilities_GammaConvolution(r,params%rotation_BC%rotate(deltaF_aim,active=.true.)) r = utilities_GammaConvolution(r,params%rotation_BC%rotate(deltaF_aim,active=.true.))

124
src/grid/grid_mech_spectral_polarisation.f90
View File

@ -40,14 +40,14 @@ module grid_mechanical_spectral_polarisation
integer :: & integer :: &
itmin, & !< minimum number of iterations itmin, & !< minimum number of iterations
itmax !< maximum number of iterations itmax !< maximum number of iterations
real(pReal) :: & real(pREAL) :: &
eps_div_atol, & !< absolute tolerance for equilibrium eps_div_atol, & !< absolute tolerance for equilibrium
eps_div_rtol, & !< relative tolerance for equilibrium eps_div_rtol, & !< relative tolerance for equilibrium
eps_curl_atol, & !< absolute tolerance for compatibility eps_curl_atol, & !< absolute tolerance for compatibility
eps_curl_rtol, & !< relative tolerance for compatibility eps_curl_rtol, & !< relative tolerance for compatibility
eps_stress_atol, & !< absolute tolerance for fullfillment of stress BC eps_stress_atol, & !< absolute tolerance for fullfillment of stress BC
eps_stress_rtol !< relative tolerance for fullfillment of stress BC eps_stress_rtol !< relative tolerance for fullfillment of stress BC
real(pReal) :: & real(pREAL) :: &
alpha, & !< polarization scheme parameter 0.0 < alpha < 2.0. alpha = 1.0 ==> AL scheme, alpha = 2.0 ==> accelerated scheme alpha, & !< polarization scheme parameter 0.0 < alpha < 2.0. alpha = 1.0 ==> AL scheme, alpha = 2.0 ==> accelerated scheme
beta !< polarization scheme parameter 0.0 < beta < 2.0. beta = 1.0 ==> AL scheme, beta = 2.0 ==> accelerated scheme beta !< polarization scheme parameter 0.0 < beta < 2.0. beta = 1.0 ==> AL scheme, beta = 2.0 ==> accelerated scheme
end type tNumerics end type tNumerics
@ -62,7 +62,7 @@ module grid_mechanical_spectral_polarisation
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! common pointwise data ! common pointwise data
real(pReal), dimension(:,:,:,:,:), allocatable :: & real(pREAL), dimension(:,:,:,:,:), allocatable :: &
F_lastInc, & !< field of previous compatible deformation gradients F_lastInc, & !< field of previous compatible deformation gradients
F_tau_lastInc, & !< field of previous incompatible deformation gradient F_tau_lastInc, & !< field of previous incompatible deformation gradient
Fdot, & !< field of assumed rate of compatible deformation gradient Fdot, & !< field of assumed rate of compatible deformation gradient
@ -70,25 +70,25 @@ module grid_mechanical_spectral_polarisation
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! stress, stiffness and compliance average etc. ! stress, stiffness and compliance average etc.
real(pReal), dimension(3,3) :: & real(pREAL), dimension(3,3) :: &
F_aimDot = 0.0_pReal, & !< assumed rate of average deformation gradient F_aimDot = 0.0_pREAL, & !< assumed rate of average deformation gradient
F_aim = math_I3, & !< current prescribed deformation gradient F_aim = math_I3, & !< current prescribed deformation gradient
F_aim_lastInc = math_I3, & !< previous average deformation gradient F_aim_lastInc = math_I3, & !< previous average deformation gradient
F_av = 0.0_pReal, & !< average incompatible def grad field F_av = 0.0_pREAL, & !< average incompatible def grad field
P_av = 0.0_pReal, & !< average 1st Piola--Kirchhoff stress P_av = 0.0_pREAL, & !< average 1st Piola--Kirchhoff stress
P_aim = 0.0_pReal P_aim = 0.0_pREAL
character(len=:), allocatable :: incInfo !< time and increment information character(len=:), allocatable :: incInfo !< time and increment information
real(pReal), dimension(3,3,3,3) :: & real(pREAL), dimension(3,3,3,3) :: &
C_volAvg = 0.0_pReal, & !< current volume average stiffness C_volAvg = 0.0_pREAL, & !< current volume average stiffness
C_volAvgLastInc = 0.0_pReal, & !< previous volume average stiffness C_volAvgLastInc = 0.0_pREAL, & !< previous volume average stiffness
C_minMaxAvg = 0.0_pReal, & !< current (min+max)/2 stiffness C_minMaxAvg = 0.0_pREAL, & !< current (min+max)/2 stiffness
C_minMaxAvgLastInc = 0.0_pReal, & !< previous (min+max)/2 stiffness C_minMaxAvgLastInc = 0.0_pREAL, & !< previous (min+max)/2 stiffness
C_minMaxAvgRestart = 0.0_pReal, & !< (min+max)/2 stiffnes (restart) C_minMaxAvgRestart = 0.0_pREAL, & !< (min+max)/2 stiffnes (restart)
S = 0.0_pReal, & !< current compliance (filled up with zeros) S = 0.0_pREAL, & !< current compliance (filled up with zeros)
C_scale = 0.0_pReal, & C_scale = 0.0_pREAL, &
S_scale = 0.0_pReal S_scale = 0.0_pREAL
real(pReal) :: & real(pREAL) :: &
err_BC, & !< deviation from stress BC err_BC, & !< deviation from stress BC
err_curl, & !< RMS of curl of F err_curl, & !< RMS of curl of F
err_div !< RMS of div of P err_div !< RMS of div of P
@ -116,15 +116,15 @@ contains
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine grid_mechanical_spectral_polarisation_init() subroutine grid_mechanical_spectral_polarisation_init()
real(pReal), dimension(3,3,cells(1),cells(2),cells3) :: P real(pREAL), dimension(3,3,cells(1),cells(2),cells3) :: P
PetscErrorCode :: err_PETSc PetscErrorCode :: err_PETSc
integer(MPI_INTEGER_KIND) :: err_MPI integer(MPI_INTEGER_KIND) :: err_MPI
real(pReal), pointer, dimension(:,:,:,:) :: & real(pREAL), pointer, dimension(:,:,:,:) :: &
FandF_tau, & ! overall pointer to solution data FandF_tau, & ! overall pointer to solution data
F, & ! specific (sub)pointer F, & ! specific (sub)pointer
F_tau ! specific (sub)pointer F_tau ! specific (sub)pointer
PetscInt, dimension(0:worldsize-1) :: localK PetscInt, dimension(0:worldsize-1) :: localK
real(pReal), dimension(3,3,product(cells(1:2))*cells3) :: temp33n real(pREAL), dimension(3,3,product(cells(1:2))*cells3) :: temp33n
integer(HID_T) :: fileHandle, groupHandle integer(HID_T) :: fileHandle, groupHandle
type(tDict), pointer :: & type(tDict), pointer :: &
num_grid num_grid
@ -143,27 +143,27 @@ subroutine grid_mechanical_spectral_polarisation_init()
num_grid => config_numerics%get_dict('grid',defaultVal=emptyDict) num_grid => config_numerics%get_dict('grid',defaultVal=emptyDict)
num%update_gamma = num_grid%get_asBool('update_gamma', defaultVal=.false.) num%update_gamma = num_grid%get_asBool('update_gamma', defaultVal=.false.)
num%eps_div_atol = num_grid%get_asReal('eps_div_atol', defaultVal=1.0e-4_pReal) num%eps_div_atol = num_grid%get_asReal('eps_div_atol', defaultVal=1.0e-4_pREAL)
num%eps_div_rtol = num_grid%get_asReal('eps_div_rtol', defaultVal=5.0e-4_pReal) num%eps_div_rtol = num_grid%get_asReal('eps_div_rtol', defaultVal=5.0e-4_pREAL)
num%eps_curl_atol = num_grid%get_asReal('eps_curl_atol', defaultVal=1.0e-10_pReal) num%eps_curl_atol = num_grid%get_asReal('eps_curl_atol', defaultVal=1.0e-10_pREAL)
num%eps_curl_rtol = num_grid%get_asReal('eps_curl_rtol', defaultVal=5.0e-4_pReal) num%eps_curl_rtol = num_grid%get_asReal('eps_curl_rtol', defaultVal=5.0e-4_pREAL)
num%eps_stress_atol = num_grid%get_asReal('eps_stress_atol',defaultVal=1.0e3_pReal) num%eps_stress_atol = num_grid%get_asReal('eps_stress_atol',defaultVal=1.0e3_pREAL)
num%eps_stress_rtol = num_grid%get_asReal('eps_stress_rtol',defaultVal=1.0e-3_pReal) num%eps_stress_rtol = num_grid%get_asReal('eps_stress_rtol',defaultVal=1.0e-3_pREAL)
num%itmin = num_grid%get_asInt ('itmin', defaultVal=1) num%itmin = num_grid%get_asInt ('itmin', defaultVal=1)
num%itmax = num_grid%get_asInt ('itmax', defaultVal=250) num%itmax = num_grid%get_asInt ('itmax', defaultVal=250)
num%alpha = num_grid%get_asReal('alpha', defaultVal=1.0_pReal) num%alpha = num_grid%get_asReal('alpha', defaultVal=1.0_pREAL)
num%beta = num_grid%get_asReal('beta', defaultVal=1.0_pReal) num%beta = num_grid%get_asReal('beta', defaultVal=1.0_pREAL)
if (num%eps_div_atol <= 0.0_pReal) extmsg = trim(extmsg)//' eps_div_atol' if (num%eps_div_atol <= 0.0_pREAL) extmsg = trim(extmsg)//' eps_div_atol'
if (num%eps_div_rtol < 0.0_pReal) extmsg = trim(extmsg)//' eps_div_rtol' if (num%eps_div_rtol < 0.0_pREAL) extmsg = trim(extmsg)//' eps_div_rtol'
if (num%eps_curl_atol <= 0.0_pReal) extmsg = trim(extmsg)//' eps_curl_atol' if (num%eps_curl_atol <= 0.0_pREAL) extmsg = trim(extmsg)//' eps_curl_atol'
if (num%eps_curl_rtol < 0.0_pReal) extmsg = trim(extmsg)//' eps_curl_rtol' if (num%eps_curl_rtol < 0.0_pREAL) extmsg = trim(extmsg)//' eps_curl_rtol'
if (num%eps_stress_atol <= 0.0_pReal) extmsg = trim(extmsg)//' eps_stress_atol' if (num%eps_stress_atol <= 0.0_pREAL) extmsg = trim(extmsg)//' eps_stress_atol'
if (num%eps_stress_rtol < 0.0_pReal) extmsg = trim(extmsg)//' eps_stress_rtol' if (num%eps_stress_rtol < 0.0_pREAL) extmsg = trim(extmsg)//' eps_stress_rtol'
if (num%itmax <= 1) extmsg = trim(extmsg)//' itmax' if (num%itmax <= 1) extmsg = trim(extmsg)//' itmax'
if (num%itmin > num%itmax .or. num%itmin < 1) extmsg = trim(extmsg)//' itmin' if (num%itmin > num%itmax .or. num%itmin < 1) extmsg = trim(extmsg)//' itmin'
if (num%alpha <= 0.0_pReal .or. num%alpha > 2.0_pReal) extmsg = trim(extmsg)//' alpha' if (num%alpha <= 0.0_pREAL .or. num%alpha > 2.0_pREAL) extmsg = trim(extmsg)//' alpha'
if (num%beta < 0.0_pReal .or. num%beta > 2.0_pReal) extmsg = trim(extmsg)//' beta' if (num%beta < 0.0_pREAL .or. num%beta > 2.0_pREAL) extmsg = trim(extmsg)//' beta'
if (extmsg /= '') call IO_error(301,ext_msg=trim(extmsg)) if (extmsg /= '') call IO_error(301,ext_msg=trim(extmsg))
@ -176,10 +176,10 @@ subroutine grid_mechanical_spectral_polarisation_init()
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! allocate global fields ! allocate global fields
allocate(F_lastInc (3,3,cells(1),cells(2),cells3),source = 0.0_pReal) allocate(F_lastInc (3,3,cells(1),cells(2),cells3),source = 0.0_pREAL)
allocate(Fdot (3,3,cells(1),cells(2),cells3),source = 0.0_pReal) allocate(Fdot (3,3,cells(1),cells(2),cells3),source = 0.0_pREAL)
allocate(F_tau_lastInc(3,3,cells(1),cells(2),cells3),source = 0.0_pReal) allocate(F_tau_lastInc(3,3,cells(1),cells(2),cells3),source = 0.0_pREAL)
allocate(F_tauDot (3,3,cells(1),cells(2),cells3),source = 0.0_pReal) allocate(F_tauDot (3,3,cells(1),cells(2),cells3),source = 0.0_pREAL)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! initialize solver specific parts of PETSc ! initialize solver specific parts of PETSc
@ -252,15 +252,15 @@ subroutine grid_mechanical_spectral_polarisation_init()
elseif (CLI_restartInc == 0) then restartRead elseif (CLI_restartInc == 0) then restartRead
F_lastInc = spread(spread(spread(math_I3,3,cells(1)),4,cells(2)),5,cells3) ! initialize to identity F_lastInc = spread(spread(spread(math_I3,3,cells(1)),4,cells(2)),5,cells3) ! initialize to identity
F = reshape(F_lastInc,[9,cells(1),cells(2),cells3]) F = reshape(F_lastInc,[9,cells(1),cells(2),cells3])
F_tau = 2.0_pReal*F F_tau = 2.0_pREAL*F
F_tau_lastInc = 2.0_pReal*F_lastInc F_tau_lastInc = 2.0_pREAL*F_lastInc
end if restartRead end if restartRead
homogenization_F0 = reshape(F_lastInc, [3,3,product(cells(1:2))*cells3]) ! set starting condition for homogenization_mechanical_response homogenization_F0 = reshape(F_lastInc, [3,3,product(cells(1:2))*cells3]) ! set starting condition for homogenization_mechanical_response
call utilities_updateCoords(reshape(F,shape(F_lastInc))) call utilities_updateCoords(reshape(F,shape(F_lastInc)))
call utilities_constitutiveResponse(P,P_av,C_volAvg,C_minMaxAvg, & ! stress field, stress avg, global average of stiffness and (min+max)/2 call utilities_constitutiveResponse(P,P_av,C_volAvg,C_minMaxAvg, & ! stress field, stress avg, global average of stiffness and (min+max)/2
reshape(F,shape(F_lastInc)), & ! target F reshape(F,shape(F_lastInc)), & ! target F
0.0_pReal) ! time increment 0.0_pREAL) ! time increment
call DMDAVecRestoreArrayF90(da,solution_vec,FandF_tau,err_PETSc) ! deassociate pointer call DMDAVecRestoreArrayF90(da,solution_vec,FandF_tau,err_PETSc) ! deassociate pointer
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
@ -340,7 +340,7 @@ subroutine grid_mechanical_spectral_polarisation_forward(cutBack,guess,Delta_t,D
logical, intent(in) :: & logical, intent(in) :: &
cutBack, & cutBack, &
guess guess
real(pReal), intent(in) :: & real(pREAL), intent(in) :: &
Delta_t_old, & Delta_t_old, &
Delta_t, & Delta_t, &
t_remaining !< remaining time of current load case t_remaining !< remaining time of current load case
@ -350,9 +350,9 @@ subroutine grid_mechanical_spectral_polarisation_forward(cutBack,guess,Delta_t,D
type(tRotation), intent(in) :: & type(tRotation), intent(in) :: &
rotation_BC rotation_BC
PetscErrorCode :: err_PETSc PetscErrorCode :: err_PETSc
real(pReal), pointer, dimension(:,:,:,:) :: FandF_tau, F, F_tau real(pREAL), pointer, dimension(:,:,:,:) :: FandF_tau, F, F_tau
integer :: i, j, k integer :: i, j, k
real(pReal), dimension(3,3) :: F_lambda33 real(pREAL), dimension(3,3) :: F_lambda33
call DMDAVecGetArrayF90(da,solution_vec,FandF_tau,err_PETSc) call DMDAVecGetArrayF90(da,solution_vec,FandF_tau,err_PETSc)
@ -367,20 +367,20 @@ subroutine grid_mechanical_spectral_polarisation_forward(cutBack,guess,Delta_t,D
C_volAvgLastInc = C_volAvg C_volAvgLastInc = C_volAvg
C_minMaxAvgLastInc = C_minMaxAvg C_minMaxAvgLastInc = C_minMaxAvg
F_aimDot = merge(merge(.0_pReal,(F_aim-F_aim_lastInc)/Delta_t_old,stress_BC%mask),.0_pReal,guess) ! estimate deformation rate for prescribed stress components F_aimDot = merge(merge(.0_pREAL,(F_aim-F_aim_lastInc)/Delta_t_old,stress_BC%mask),.0_pREAL,guess) ! estimate deformation rate for prescribed stress components
F_aim_lastInc = F_aim F_aim_lastInc = F_aim
!----------------------------------------------------------------------------------------------- !-----------------------------------------------------------------------------------------------
! calculate rate for aim ! calculate rate for aim
if (deformation_BC%myType=='L') then ! calculate F_aimDot from given L and current F if (deformation_BC%myType=='L') then ! calculate F_aimDot from given L and current F
F_aimDot = F_aimDot & F_aimDot = F_aimDot &
+ matmul(merge(.0_pReal,deformation_BC%values,deformation_BC%mask),F_aim_lastInc) + matmul(merge(.0_pREAL,deformation_BC%values,deformation_BC%mask),F_aim_lastInc)
elseif (deformation_BC%myType=='dot_F') then ! F_aimDot is prescribed elseif (deformation_BC%myType=='dot_F') then ! F_aimDot is prescribed
F_aimDot = F_aimDot & F_aimDot = F_aimDot &
+ merge(.0_pReal,deformation_BC%values,deformation_BC%mask) + merge(.0_pREAL,deformation_BC%values,deformation_BC%mask)
elseif (deformation_BC%myType=='F') then ! aim at end of load case is prescribed elseif (deformation_BC%myType=='F') then ! aim at end of load case is prescribed
F_aimDot = F_aimDot & F_aimDot = F_aimDot &
+ merge(.0_pReal,(deformation_BC%values - F_aim_lastInc)/t_remaining,deformation_BC%mask) + merge(.0_pREAL,(deformation_BC%values - F_aim_lastInc)/t_remaining,deformation_BC%mask)
end if end if
Fdot = utilities_calculateRate(guess, & Fdot = utilities_calculateRate(guess, &
@ -399,9 +399,9 @@ subroutine grid_mechanical_spectral_polarisation_forward(cutBack,guess,Delta_t,D
! update average and local deformation gradients ! update average and local deformation gradients
F_aim = F_aim_lastInc + F_aimDot * Delta_t F_aim = F_aim_lastInc + F_aimDot * Delta_t
if (stress_BC%myType=='P') P_aim = P_aim & if (stress_BC%myType=='P') P_aim = P_aim &
+ merge(.0_pReal,(stress_BC%values - P_aim)/t_remaining,stress_BC%mask)*Delta_t + merge(.0_pREAL,(stress_BC%values - P_aim)/t_remaining,stress_BC%mask)*Delta_t
if (stress_BC%myType=='dot_P') P_aim = P_aim & if (stress_BC%myType=='dot_P') P_aim = P_aim &
+ merge(.0_pReal,stress_BC%values,stress_BC%mask)*Delta_t + merge(.0_pREAL,stress_BC%values,stress_BC%mask)*Delta_t
F = reshape(utilities_forwardField(Delta_t,F_lastInc,Fdot, & ! estimate of F at end of time+Delta_t that matches rotated F_aim on average F = reshape(utilities_forwardField(Delta_t,F_lastInc,Fdot, & ! estimate of F at end of time+Delta_t that matches rotated F_aim on average
rotation_BC%rotate(F_aim,active=.true.)),& rotation_BC%rotate(F_aim,active=.true.)),&
@ -413,7 +413,7 @@ subroutine grid_mechanical_spectral_polarisation_forward(cutBack,guess,Delta_t,D
do k = 1, cells3; do j = 1, cells(2); do i = 1, cells(1) do k = 1, cells3; do j = 1, cells(2); do i = 1, cells(1)
F_lambda33 = reshape(F_tau(1:9,i,j,k)-F(1:9,i,j,k),[3,3]) F_lambda33 = reshape(F_tau(1:9,i,j,k)-F(1:9,i,j,k),[3,3])
F_lambda33 = math_I3 & F_lambda33 = math_I3 &
+ math_mul3333xx33(S_scale,0.5_pReal*matmul(F_lambda33, & + math_mul3333xx33(S_scale,0.5_pREAL*matmul(F_lambda33, &
math_mul3333xx33(C_scale,matmul(transpose(F_lambda33),F_lambda33)-math_I3))) math_mul3333xx33(C_scale,matmul(transpose(F_lambda33),F_lambda33)-math_I3)))
F_tau(1:9,i,j,k) = reshape(F_lambda33,[9])+F(1:9,i,j,k) F_tau(1:9,i,j,k) = reshape(F_lambda33,[9])+F(1:9,i,j,k)
end do; end do; end do end do; end do; end do
@ -437,7 +437,7 @@ end subroutine grid_mechanical_spectral_polarisation_forward
subroutine grid_mechanical_spectral_polarisation_updateCoords subroutine grid_mechanical_spectral_polarisation_updateCoords
PetscErrorCode :: err_PETSc PetscErrorCode :: err_PETSc
real(pReal), dimension(:,:,:,:), pointer :: FandF_tau real(pREAL), dimension(:,:,:,:), pointer :: FandF_tau
call DMDAVecGetArrayF90(da,solution_vec,FandF_tau,err_PETSc) call DMDAVecGetArrayF90(da,solution_vec,FandF_tau,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
@ -455,7 +455,7 @@ subroutine grid_mechanical_spectral_polarisation_restartWrite
PetscErrorCode :: err_PETSc PetscErrorCode :: err_PETSc
integer(HID_T) :: fileHandle, groupHandle integer(HID_T) :: fileHandle, groupHandle
real(pReal), dimension(:,:,:,:), pointer :: FandF_tau, F, F_tau real(pREAL), dimension(:,:,:,:), pointer :: FandF_tau, F, F_tau
call DMDAVecGetArrayF90(da,solution_vec,FandF_tau,err_PETSc) call DMDAVecGetArrayF90(da,solution_vec,FandF_tau,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
@ -509,7 +509,7 @@ subroutine converged(snes_local,PETScIter,devNull1,devNull2,devNull3,reason,dumm
SNESConvergedReason :: reason SNESConvergedReason :: reason
PetscObject :: dummy PetscObject :: dummy
PetscErrorCode :: err_PETSc PetscErrorCode :: err_PETSc
real(pReal) :: & real(pREAL) :: &
curlTol, & curlTol, &
divTol, & divTol, &
BCTol BCTol
@ -518,7 +518,7 @@ subroutine converged(snes_local,PETScIter,devNull1,devNull2,devNull3,reason,dumm
divTol = max(maxval(abs(P_av))*num%eps_div_rtol, num%eps_div_atol) divTol = max(maxval(abs(P_av))*num%eps_div_rtol, num%eps_div_atol)
BCTol = max(maxval(abs(P_av))*num%eps_stress_rtol, num%eps_stress_atol) BCTol = max(maxval(abs(P_av))*num%eps_stress_rtol, num%eps_stress_atol)
if ((totalIter >= num%itmin .and. all([err_div/divTol, err_curl/curlTol, err_BC/BCTol] < 1.0_pReal)) & if ((totalIter >= num%itmin .and. all([err_div/divTol, err_curl/curlTol, err_BC/BCTol] < 1.0_pREAL)) &
.or. terminallyIll) then .or. terminallyIll) then
reason = 1 reason = 1
elseif (totalIter >= num%itmax) then elseif (totalIter >= num%itmax) then
@ -548,14 +548,14 @@ subroutine formResidual(residual_subdomain, FandF_tau, &
r, dummy,err_PETSc) r, dummy,err_PETSc)
DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: residual_subdomain !< DMDA info (needs to be named "in" for macros like XRANGE to work) DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: residual_subdomain !< DMDA info (needs to be named "in" for macros like XRANGE to work)
real(pReal), dimension(3,3,2,cells(1),cells(2),cells3), target, intent(in) :: & real(pREAL), dimension(3,3,2,cells(1),cells(2),cells3), target, intent(in) :: &
FandF_tau !< deformation gradient field FandF_tau !< deformation gradient field
real(pReal), dimension(3,3,2,cells(1),cells(2),cells3), target, intent(out) :: & real(pREAL), dimension(3,3,2,cells(1),cells(2),cells3), target, intent(out) :: &
r !< residuum field r !< residuum field
PetscObject :: dummy PetscObject :: dummy
PetscErrorCode :: err_PETSc PetscErrorCode :: err_PETSc
real(pReal), pointer, dimension(:,:,:,:,:) :: & real(pREAL), pointer, dimension(:,:,:,:,:) :: &
F, & F, &
F_tau, & F_tau, &
r_F, & r_F, &
@ -587,7 +587,7 @@ subroutine formResidual(residual_subdomain, FandF_tau, &
newIteration: if (totalIter <= PETScIter) then newIteration: if (totalIter <= PETScIter) then
totalIter = totalIter + 1 totalIter = totalIter + 1
print'(1x,a,3(a,i0))', trim(incInfo), ' @ Iteration ', num%itmin, '≤',totalIter, '≤', num%itmax print'(1x,a,3(a,i0))', trim(incInfo), ' @ Iteration ', num%itmin, '≤',totalIter, '≤', num%itmax
if (any(dNeq(params%rotation_BC%asQuaternion(), real([1.0, 0.0, 0.0, 0.0],pReal)))) & if (any(dNeq(params%rotation_BC%asQuaternion(), real([1.0, 0.0, 0.0, 0.0],pREAL)))) &
print'(/,1x,a,/,2(3(f12.7,1x)/),3(f12.7,1x))', & print'(/,1x,a,/,2(3(f12.7,1x)/),3(f12.7,1x))', &
'deformation gradient aim (lab) =', transpose(params%rotation_BC%rotate(F_aim,active=.true.)) 'deformation gradient aim (lab) =', transpose(params%rotation_BC%rotate(F_aim,active=.true.))
print'(/,1x,a,/,2(3(f12.7,1x)/),3(f12.7,1x))', & print'(/,1x,a,/,2(3(f12.7,1x)/),3(f12.7,1x))', &

40
src/grid/grid_thermal_spectral.f90
View File

@ -35,7 +35,7 @@ module grid_thermal_spectral
type :: tNumerics type :: tNumerics
integer :: & integer :: &
itmax !< maximum number of iterations itmax !< maximum number of iterations
real(pReal) :: & real(pREAL) :: &
eps_thermal_atol, & !< absolute tolerance for thermal equilibrium eps_thermal_atol, & !< absolute tolerance for thermal equilibrium
eps_thermal_rtol !< relative tolerance for thermal equilibrium eps_thermal_rtol !< relative tolerance for thermal equilibrium
end type tNumerics end type tNumerics
@ -47,7 +47,7 @@ module grid_thermal_spectral
! PETSc data ! PETSc data
SNES :: SNES_thermal SNES :: SNES_thermal
Vec :: solution_vec Vec :: solution_vec
real(pReal), dimension(:,:,:), allocatable :: & real(pREAL), dimension(:,:,:), allocatable :: &
T, & !< field of current temperature T, & !< field of current temperature
T_lastInc, & !< field of previous temperature T_lastInc, & !< field of previous temperature
T_stagInc, & !< field of staggered temperature T_stagInc, & !< field of staggered temperature
@ -55,8 +55,8 @@ module grid_thermal_spectral
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! reference diffusion tensor, mobility etc. ! reference diffusion tensor, mobility etc.
integer :: totalIter = 0 !< total iteration in current increment integer :: totalIter = 0 !< total iteration in current increment
real(pReal), dimension(3,3) :: K_ref real(pREAL), dimension(3,3) :: K_ref
real(pReal) :: mu_ref real(pREAL) :: mu_ref
public :: & public :: &
grid_thermal_spectral_init, & grid_thermal_spectral_init, &
@ -74,11 +74,11 @@ subroutine grid_thermal_spectral_init()
PetscInt, dimension(0:worldsize-1) :: localK PetscInt, dimension(0:worldsize-1) :: localK
integer :: i, j, k, ce integer :: i, j, k, ce
DM :: thermal_grid DM :: thermal_grid
real(pReal), dimension(:,:,:), pointer :: T_PETSc real(pREAL), dimension(:,:,:), pointer :: T_PETSc
integer(MPI_INTEGER_KIND) :: err_MPI integer(MPI_INTEGER_KIND) :: err_MPI
PetscErrorCode :: err_PETSc PetscErrorCode :: err_PETSc
integer(HID_T) :: fileHandle, groupHandle integer(HID_T) :: fileHandle, groupHandle
real(pReal), dimension(1,product(cells(1:2))*cells3) :: tempN real(pREAL), dimension(1,product(cells(1:2))*cells3) :: tempN
type(tDict), pointer :: & type(tDict), pointer :: &
num_grid num_grid
@ -93,12 +93,12 @@ subroutine grid_thermal_spectral_init()
! read numerical parameters and do sanity checks ! read numerical parameters and do sanity checks
num_grid => config_numerics%get_dict('grid',defaultVal=emptyDict) num_grid => config_numerics%get_dict('grid',defaultVal=emptyDict)
num%itmax = num_grid%get_asInt ('itmax', defaultVal=250) num%itmax = num_grid%get_asInt ('itmax', defaultVal=250)
num%eps_thermal_atol = num_grid%get_asReal('eps_thermal_atol',defaultVal=1.0e-2_pReal) num%eps_thermal_atol = num_grid%get_asReal('eps_thermal_atol',defaultVal=1.0e-2_pREAL)
num%eps_thermal_rtol = num_grid%get_asReal('eps_thermal_rtol',defaultVal=1.0e-6_pReal) num%eps_thermal_rtol = num_grid%get_asReal('eps_thermal_rtol',defaultVal=1.0e-6_pREAL)
if (num%itmax <= 1) call IO_error(301,ext_msg='itmax') if (num%itmax <= 1) call IO_error(301,ext_msg='itmax')
if (num%eps_thermal_atol <= 0.0_pReal) call IO_error(301,ext_msg='eps_thermal_atol') if (num%eps_thermal_atol <= 0.0_pREAL) call IO_error(301,ext_msg='eps_thermal_atol')
if (num%eps_thermal_rtol <= 0.0_pReal) call IO_error(301,ext_msg='eps_thermal_rtol') if (num%eps_thermal_rtol <= 0.0_pREAL) call IO_error(301,ext_msg='eps_thermal_rtol')
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! set default and user defined options for PETSc ! set default and user defined options for PETSc
@ -113,7 +113,7 @@ subroutine grid_thermal_spectral_init()
T = discretization_grid_getInitialCondition('T') T = discretization_grid_getInitialCondition('T')
T_lastInc = T T_lastInc = T
T_stagInc = T T_stagInc = T
dotT_lastInc = 0.0_pReal * T dotT_lastInc = 0.0_pREAL * T
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! initialize solver specific parts of PETSc ! initialize solver specific parts of PETSc
@ -165,7 +165,7 @@ subroutine grid_thermal_spectral_init()
ce = 0 ce = 0
do k = 1, cells3; do j = 1, cells(2); do i = 1, cells(1) do k = 1, cells3; do j = 1, cells(2); do i = 1, cells(1)
ce = ce + 1 ce = ce + 1
call homogenization_thermal_setField(T(i,j,k),0.0_pReal,ce) call homogenization_thermal_setField(T(i,j,k),0.0_pREAL,ce)
end do; end do; end do end do; end do; end do
call DMDAVecGetArrayF90(thermal_grid,solution_vec,T_PETSc,err_PETSc) call DMDAVecGetArrayF90(thermal_grid,solution_vec,T_PETSc,err_PETSc)
@ -184,7 +184,7 @@ end subroutine grid_thermal_spectral_init
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
function grid_thermal_spectral_solution(Delta_t) result(solution) function grid_thermal_spectral_solution(Delta_t) result(solution)
real(pReal), intent(in) :: & real(pREAL), intent(in) :: &
Delta_t !< increment in time for current solution Delta_t !< increment in time for current solution
integer :: i, j, k, ce integer :: i, j, k, ce
type(tSolutionState) :: solution type(tSolutionState) :: solution
@ -251,7 +251,7 @@ subroutine grid_thermal_spectral_forward(cutBack)
integer :: i, j, k, ce integer :: i, j, k, ce
DM :: dm_local DM :: dm_local
real(pReal), dimension(:,:,:), pointer :: T_PETSc real(pREAL), dimension(:,:,:), pointer :: T_PETSc
PetscErrorCode :: err_PETSc PetscErrorCode :: err_PETSc
@ -290,7 +290,7 @@ subroutine grid_thermal_spectral_restartWrite
PetscErrorCode :: err_PETSc PetscErrorCode :: err_PETSc
DM :: dm_local DM :: dm_local
integer(HID_T) :: fileHandle, groupHandle integer(HID_T) :: fileHandle, groupHandle
real(pReal), dimension(:,:,:), pointer :: T real(pREAL), dimension(:,:,:), pointer :: T
call SNESGetDM(SNES_thermal,dm_local,err_PETSc); call SNESGetDM(SNES_thermal,dm_local,err_PETSc);
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
@ -321,15 +321,15 @@ subroutine formResidual(residual_subdomain,x_scal,r,dummy,err_PETSc)
DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: & DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: &
residual_subdomain residual_subdomain
real(pReal), dimension(cells(1),cells(2),cells3), intent(in) :: & real(pREAL), dimension(cells(1),cells(2),cells3), intent(in) :: &
x_scal x_scal
real(pReal), dimension(cells(1),cells(2),cells3), intent(out) :: & real(pREAL), dimension(cells(1),cells(2),cells3), intent(out) :: &
r !< residual r !< residual
PetscObject :: dummy PetscObject :: dummy
PetscErrorCode, intent(out) :: err_PETSc PetscErrorCode, intent(out) :: err_PETSc
integer :: i, j, k, ce integer :: i, j, k, ce
real(pReal), dimension(3,cells(1),cells(2),cells3) :: vectorField real(pREAL), dimension(3,cells(1),cells(2),cells3) :: vectorField
T = x_scal T = x_scal
@ -364,8 +364,8 @@ subroutine updateReference()
integer(MPI_INTEGER_KIND) :: err_MPI integer(MPI_INTEGER_KIND) :: err_MPI
K_ref = 0.0_pReal K_ref = 0.0_pREAL
mu_ref = 0.0_pReal mu_ref = 0.0_pREAL
do ce = 1, product(cells(1:2))*cells3 do ce = 1, product(cells(1:2))*cells3
K_ref = K_ref + homogenization_K_T(ce) K_ref = K_ref + homogenization_K_T(ce)
mu_ref = mu_ref + homogenization_mu_T(ce) mu_ref = mu_ref + homogenization_mu_T(ce)

354
src/grid/spectral_utilities.f90
View File

@ -32,8 +32,8 @@ module spectral_utilities
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! grid related information ! grid related information
real(pReal), protected, public :: wgt !< weighting factor 1/Nelems real(pREAL), protected, public :: wgt !< weighting factor 1/Nelems
real(pReal), protected, public, dimension(3) :: scaledGeomSize !< scaled geometry size for calculation of divergence real(pREAL), protected, public, dimension(3) :: scaledGeomSize !< scaled geometry size for calculation of divergence
integer :: & integer :: &
cells1Red, & !< cells(1)/2+1 cells1Red, & !< cells(1)/2+1
cells2, & !< (local) cells in 2nd direction cells2, & !< (local) cells in 2nd direction
@ -48,10 +48,10 @@ module spectral_utilities
complex(C_DOUBLE_COMPLEX), dimension(:,:,:,:,:), pointer :: tensorField_fourier !< tensor field in Fourier space complex(C_DOUBLE_COMPLEX), dimension(:,:,:,:,:), pointer :: tensorField_fourier !< tensor field in Fourier space
complex(C_DOUBLE_COMPLEX), dimension(:,:,:,:), pointer :: vectorField_fourier !< vector field in Fourier space complex(C_DOUBLE_COMPLEX), dimension(:,:,:,:), pointer :: vectorField_fourier !< vector field in Fourier space
complex(C_DOUBLE_COMPLEX), dimension(:,:,:), pointer :: scalarField_fourier !< scalar field in Fourier space complex(C_DOUBLE_COMPLEX), dimension(:,:,:), pointer :: scalarField_fourier !< scalar field in Fourier space
complex(pReal), dimension(:,:,:,:,:,:,:), allocatable :: gamma_hat !< gamma operator (field) for spectral method complex(pREAL), dimension(:,:,:,:,:,:,:), allocatable :: gamma_hat !< gamma operator (field) for spectral method
complex(pReal), dimension(:,:,:,:), allocatable :: xi1st !< wave vector field for first derivatives complex(pREAL), dimension(:,:,:,:), allocatable :: xi1st !< wave vector field for first derivatives
complex(pReal), dimension(:,:,:,:), allocatable :: xi2nd !< wave vector field for second derivatives complex(pREAL), dimension(:,:,:,:), allocatable :: xi2nd !< wave vector field for second derivatives
real(pReal), dimension(3,3,3,3) :: C_ref !< mechanic reference stiffness real(pREAL), dimension(3,3,3,3) :: C_ref !< mechanic reference stiffness
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
@ -76,16 +76,16 @@ module spectral_utilities
end type tSolutionState end type tSolutionState
type, public :: tBoundaryCondition !< set of parameters defining a boundary condition type, public :: tBoundaryCondition !< set of parameters defining a boundary condition
real(pReal), dimension(3,3) :: values = 0.0_pReal real(pREAL), dimension(3,3) :: values = 0.0_pREAL
logical, dimension(3,3) :: mask = .true. logical, dimension(3,3) :: mask = .true.
character(len=:), allocatable :: myType character(len=:), allocatable :: myType
end type tBoundaryCondition end type tBoundaryCondition
type, public :: tSolutionParams type, public :: tSolutionParams
real(pReal), dimension(3,3) :: stress_BC real(pREAL), dimension(3,3) :: stress_BC
logical, dimension(3,3) :: stress_mask logical, dimension(3,3) :: stress_mask
type(tRotation) :: rotation_BC type(tRotation) :: rotation_BC
real(pReal) :: Delta_t real(pREAL) :: Delta_t
end type tSolutionParams end type tSolutionParams
type :: tNumerics type :: tNumerics
@ -172,7 +172,7 @@ subroutine spectral_utilities_init()
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
cells1Red = cells(1)/2 + 1 cells1Red = cells(1)/2 + 1
wgt = real(product(cells),pReal)**(-1) wgt = real(product(cells),pREAL)**(-1)
num%memory_efficient = num_grid%get_asInt('memory_efficient', defaultVal=1) > 0 ! ToDo: should be logical in YAML file num%memory_efficient = num_grid%get_asInt('memory_efficient', defaultVal=1) > 0 ! ToDo: should be logical in YAML file
num%divergence_correction = num_grid%get_asInt('divergence_correction', defaultVal=2) num%divergence_correction = num_grid%get_asInt('divergence_correction', defaultVal=2)
@ -201,9 +201,9 @@ subroutine spectral_utilities_init()
end do end do
elseif (num%divergence_correction == 2) then elseif (num%divergence_correction == 2) then
do j = 1, 3 do j = 1, 3
if ( j /= int(minloc(geomSize/real(cells,pReal),1)) & if ( j /= int(minloc(geomSize/real(cells,pREAL),1)) &
.and. j /= int(maxloc(geomSize/real(cells,pReal),1))) & .and. j /= int(maxloc(geomSize/real(cells,pREAL),1))) &
scaledGeomSize = geomSize/geomSize(j)*real(cells(j),pReal) scaledGeomSize = geomSize/geomSize(j)*real(cells(j),pREAL)
end do end do
else else
scaledGeomSize = geomSize scaledGeomSize = geomSize
@ -225,8 +225,8 @@ subroutine spectral_utilities_init()
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! general initialization of FFTW (see manual on fftw.org for more details) ! general initialization of FFTW (see manual on fftw.org for more details)
if (pReal /= C_DOUBLE .or. kind(1) /= C_INT) error stop 'C and Fortran datatypes do not match' if (pREAL /= C_DOUBLE .or. kind(1) /= C_INT) error stop 'C and Fortran datatypes do not match'
call fftw_set_timelimit(num_grid%get_asReal('fftw_timelimit',defaultVal=300.0_pReal)) call fftw_set_timelimit(num_grid%get_asReal('fftw_timelimit',defaultVal=300.0_pREAL))
print'(/,1x,a)', 'FFTW initialized'; flush(IO_STDOUT) print'(/,1x,a)', 'FFTW initialized'; flush(IO_STDOUT)
@ -268,8 +268,8 @@ subroutine spectral_utilities_init()
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! allocation ! allocation
allocate (xi1st (3,cells1Red,cells(3),cells2),source = cmplx(0.0_pReal,0.0_pReal,pReal)) ! frequencies for first derivatives, only half the size for first dimension allocate (xi1st (3,cells1Red,cells(3),cells2),source = cmplx(0.0_pREAL,0.0_pREAL,pREAL)) ! frequencies for first derivatives, only half the size for first dimension
allocate (xi2nd (3,cells1Red,cells(3),cells2),source = cmplx(0.0_pReal,0.0_pReal,pReal)) ! frequencies for second derivatives, only half the size for first dimension allocate (xi2nd (3,cells1Red,cells(3),cells2),source = cmplx(0.0_pREAL,0.0_pREAL,pREAL)) ! frequencies for second derivatives, only half the size for first dimension
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! tensor MPI fftw plans ! tensor MPI fftw plans
@ -321,16 +321,16 @@ subroutine spectral_utilities_init()
xi2nd(1:3,i,k,j-cells2Offset) = utilities_getFreqDerivative(k_s) xi2nd(1:3,i,k,j-cells2Offset) = utilities_getFreqDerivative(k_s)
where(mod(cells,2)==0 .and. [i,j,k] == cells/2+1 .and. & where(mod(cells,2)==0 .and. [i,j,k] == cells/2+1 .and. &
spectral_derivative_ID == DERIVATIVE_CONTINUOUS_ID) ! for even grids, set the Nyquist Freq component to 0.0 spectral_derivative_ID == DERIVATIVE_CONTINUOUS_ID) ! for even grids, set the Nyquist Freq component to 0.0
xi1st(1:3,i,k,j-cells2Offset) = cmplx(0.0_pReal,0.0_pReal,pReal) xi1st(1:3,i,k,j-cells2Offset) = cmplx(0.0_pREAL,0.0_pREAL,pREAL)
elsewhere elsewhere
xi1st(1:3,i,k,j-cells2Offset) = xi2nd(1:3,i,k,j-cells2Offset) xi1st(1:3,i,k,j-cells2Offset) = xi2nd(1:3,i,k,j-cells2Offset)
endwhere endwhere
end do; end do; end do end do; end do; end do
if (num%memory_efficient) then ! allocate just single fourth order tensor if (num%memory_efficient) then ! allocate just single fourth order tensor
allocate (gamma_hat(3,3,3,3,1,1,1), source = cmplx(0.0_pReal,0.0_pReal,pReal)) allocate (gamma_hat(3,3,3,3,1,1,1), source = cmplx(0.0_pREAL,0.0_pREAL,pREAL))
else ! precalculation of gamma_hat field else ! precalculation of gamma_hat field
allocate (gamma_hat(3,3,3,3,cells1Red,cells(3),cells2), source = cmplx(0.0_pReal,0.0_pReal,pReal)) allocate (gamma_hat(3,3,3,3,cells1Red,cells(3),cells2), source = cmplx(0.0_pREAL,0.0_pREAL,pREAL))
end if end if
call selfTest() call selfTest()
@ -346,10 +346,10 @@ end subroutine spectral_utilities_init
!--------------------------------------------------------------------------------------------------- !---------------------------------------------------------------------------------------------------
subroutine utilities_updateGamma(C) subroutine utilities_updateGamma(C)
real(pReal), intent(in), dimension(3,3,3,3) :: C !< input stiffness to store as reference stiffness real(pREAL), intent(in), dimension(3,3,3,3) :: C !< input stiffness to store as reference stiffness
complex(pReal), dimension(3,3) :: temp33_cmplx, xiDyad_cmplx complex(pREAL), dimension(3,3) :: temp33_cmplx, xiDyad_cmplx
real(pReal), dimension(6,6) :: A, A_inv real(pREAL), dimension(6,6) :: A, A_inv
integer :: & integer :: &
i, j, k, & i, j, k, &
l, m, n, o l, m, n, o
@ -359,7 +359,7 @@ subroutine utilities_updateGamma(C)
C_ref = C/wgt C_ref = C/wgt
if (.not. num%memory_efficient) then if (.not. num%memory_efficient) then
gamma_hat = cmplx(0.0_pReal,0.0_pReal,pReal) ! for the singular point and any non invertible A gamma_hat = cmplx(0.0_pREAL,0.0_pREAL,pREAL) ! for the singular point and any non invertible A
!$OMP PARALLEL DO PRIVATE(l,m,n,o,temp33_cmplx,xiDyad_cmplx,A,A_inv,err) !$OMP PARALLEL DO PRIVATE(l,m,n,o,temp33_cmplx,xiDyad_cmplx,A,A_inv,err)
do j = cells2Offset+1, cells2Offset+cells2; do k = 1, cells(3); do i = 1, cells1Red do j = cells2Offset+1, cells2Offset+cells2; do k = 1, cells(3); do i = 1, cells1Red
if (any([i,j,k] /= 1)) then ! singular point at xi=(0.0,0.0,0.0) i.e. i=j=k=1 if (any([i,j,k] /= 1)) then ! singular point at xi=(0.0,0.0,0.0) i.e. i=j=k=1
@ -368,19 +368,19 @@ subroutine utilities_updateGamma(C)
xiDyad_cmplx(l,m) = conjg(-xi1st(l,i,k,j-cells2Offset))*xi1st(m,i,k,j-cells2Offset) xiDyad_cmplx(l,m) = conjg(-xi1st(l,i,k,j-cells2Offset))*xi1st(m,i,k,j-cells2Offset)
end do end do
do concurrent(l = 1:3, m = 1:3) do concurrent(l = 1:3, m = 1:3)
temp33_cmplx(l,m) = sum(cmplx(C_ref(l,1:3,m,1:3),0.0_pReal,pReal)*xiDyad_cmplx) temp33_cmplx(l,m) = sum(cmplx(C_ref(l,1:3,m,1:3),0.0_pREAL,pREAL)*xiDyad_cmplx)
end do end do
#else #else
forall(l = 1:3, m = 1:3) & forall(l = 1:3, m = 1:3) &
xiDyad_cmplx(l,m) = conjg(-xi1st(l,i,k,j-cells2Offset))*xi1st(m,i,k,j-cells2Offset) xiDyad_cmplx(l,m) = conjg(-xi1st(l,i,k,j-cells2Offset))*xi1st(m,i,k,j-cells2Offset)
forall(l = 1:3, m = 1:3) & forall(l = 1:3, m = 1:3) &
temp33_cmplx(l,m) = sum(cmplx(C_ref(l,1:3,m,1:3),0.0_pReal,pReal)*xiDyad_cmplx) temp33_cmplx(l,m) = sum(cmplx(C_ref(l,1:3,m,1:3),0.0_pREAL,pREAL)*xiDyad_cmplx)
#endif #endif
A(1:3,1:3) = temp33_cmplx%re; A(4:6,4:6) = temp33_cmplx%re A(1:3,1:3) = temp33_cmplx%re; A(4:6,4:6) = temp33_cmplx%re
A(1:3,4:6) = temp33_cmplx%im; A(4:6,1:3) = -temp33_cmplx%im A(1:3,4:6) = temp33_cmplx%im; A(4:6,1:3) = -temp33_cmplx%im
if (abs(math_det33(A(1:3,1:3))) > 1.e-16_pReal) then if (abs(math_det33(A(1:3,1:3))) > 1.e-16_pREAL) then
call math_invert(A_inv, err, A) call math_invert(A_inv, err, A)
temp33_cmplx = cmplx(A_inv(1:3,1:3),A_inv(1:3,4:6),pReal) temp33_cmplx = cmplx(A_inv(1:3,1:3),A_inv(1:3,4:6),pREAL)
#ifndef __INTEL_COMPILER #ifndef __INTEL_COMPILER
do concurrent(l=1:3, m=1:3, n=1:3, o=1:3) do concurrent(l=1:3, m=1:3, n=1:3, o=1:3)
gamma_hat(l,m,n,o,i,k,j-cells2Offset) = temp33_cmplx(l,n) * xiDyad_cmplx(o,m) gamma_hat(l,m,n,o,i,k,j-cells2Offset) = temp33_cmplx(l,n) * xiDyad_cmplx(o,m)
@ -404,12 +404,12 @@ end subroutine utilities_updateGamma
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
function utilities_GammaConvolution(field, fieldAim) result(gammaField) function utilities_GammaConvolution(field, fieldAim) result(gammaField)
real(pReal), intent(in), dimension(3,3,cells(1),cells(2),cells3) :: field real(pREAL), intent(in), dimension(3,3,cells(1),cells(2),cells3) :: field
real(pReal), intent(in), dimension(3,3) :: fieldAim !< desired average value of the field after convolution real(pREAL), intent(in), dimension(3,3) :: fieldAim !< desired average value of the field after convolution
real(pReal), dimension(3,3,cells(1),cells(2),cells3) :: gammaField real(pREAL), dimension(3,3,cells(1),cells(2),cells3) :: gammaField
complex(pReal), dimension(3,3) :: temp33_cmplx, xiDyad_cmplx complex(pREAL), dimension(3,3) :: temp33_cmplx, xiDyad_cmplx
real(pReal), dimension(6,6) :: A, A_inv real(pREAL), dimension(6,6) :: A, A_inv
integer :: & integer :: &
i, j, k, & i, j, k, &
l, m, n, o l, m, n, o
@ -419,7 +419,7 @@ function utilities_GammaConvolution(field, fieldAim) result(gammaField)
print'(/,1x,a)', '... doing gamma convolution ...............................................' print'(/,1x,a)', '... doing gamma convolution ...............................................'
flush(IO_STDOUT) flush(IO_STDOUT)
tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pReal tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pREAL
tensorField_real(1:3,1:3,1:cells(1), 1:cells(2),1:cells3) = field tensorField_real(1:3,1:3,1:cells(1), 1:cells(2),1:cells3) = field
call fftw_mpi_execute_dft_r2c(planTensorForth,tensorField_real,tensorField_fourier) call fftw_mpi_execute_dft_r2c(planTensorForth,tensorField_real,tensorField_fourier)
@ -432,19 +432,19 @@ function utilities_GammaConvolution(field, fieldAim) result(gammaField)
xiDyad_cmplx(l,m) = conjg(-xi1st(l,i,k,j))*xi1st(m,i,k,j) xiDyad_cmplx(l,m) = conjg(-xi1st(l,i,k,j))*xi1st(m,i,k,j)
end do end do
do concurrent(l = 1:3, m = 1:3) do concurrent(l = 1:3, m = 1:3)
temp33_cmplx(l,m) = sum(cmplx(C_ref(l,1:3,m,1:3),0.0_pReal,pReal)*xiDyad_cmplx) temp33_cmplx(l,m) = sum(cmplx(C_ref(l,1:3,m,1:3),0.0_pREAL,pREAL)*xiDyad_cmplx)
end do end do
#else #else
forall(l = 1:3, m = 1:3) & forall(l = 1:3, m = 1:3) &
xiDyad_cmplx(l,m) = conjg(-xi1st(l,i,k,j))*xi1st(m,i,k,j) xiDyad_cmplx(l,m) = conjg(-xi1st(l,i,k,j))*xi1st(m,i,k,j)
forall(l = 1:3, m = 1:3) & forall(l = 1:3, m = 1:3) &
temp33_cmplx(l,m) = sum(cmplx(C_ref(l,1:3,m,1:3),0.0_pReal,pReal)*xiDyad_cmplx) temp33_cmplx(l,m) = sum(cmplx(C_ref(l,1:3,m,1:3),0.0_pREAL,pREAL)*xiDyad_cmplx)
#endif #endif
A(1:3,1:3) = temp33_cmplx%re; A(4:6,4:6) = temp33_cmplx%re A(1:3,1:3) = temp33_cmplx%re; A(4:6,4:6) = temp33_cmplx%re
A(1:3,4:6) = temp33_cmplx%im; A(4:6,1:3) = -temp33_cmplx%im A(1:3,4:6) = temp33_cmplx%im; A(4:6,1:3) = -temp33_cmplx%im
if (abs(math_det33(A(1:3,1:3))) > 1.e-16_pReal) then if (abs(math_det33(A(1:3,1:3))) > 1.e-16_pREAL) then
call math_invert(A_inv, err, A) call math_invert(A_inv, err, A)
temp33_cmplx = cmplx(A_inv(1:3,1:3),A_inv(1:3,4:6),pReal) temp33_cmplx = cmplx(A_inv(1:3,1:3),A_inv(1:3,4:6),pREAL)
#ifndef __INTEL_COMPILER #ifndef __INTEL_COMPILER
do concurrent(l=1:3, m=1:3, n=1:3, o=1:3) do concurrent(l=1:3, m=1:3, n=1:3, o=1:3)
gamma_hat(l,m,n,o,1,1,1) = temp33_cmplx(l,n)*xiDyad_cmplx(o,m) gamma_hat(l,m,n,o,1,1,1) = temp33_cmplx(l,n)*xiDyad_cmplx(o,m)
@ -460,7 +460,7 @@ function utilities_GammaConvolution(field, fieldAim) result(gammaField)
#endif #endif
tensorField_fourier(1:3,1:3,i,k,j) = temp33_cmplx tensorField_fourier(1:3,1:3,i,k,j) = temp33_cmplx
else else
tensorField_fourier(1:3,1:3,i,k,j) = cmplx(0.0_pReal,0.0_pReal,pReal) tensorField_fourier(1:3,1:3,i,k,j) = cmplx(0.0_pREAL,0.0_pREAL,pREAL)
end if end if
end if end if
end do; end do; end do end do; end do; end do
@ -481,7 +481,7 @@ function utilities_GammaConvolution(field, fieldAim) result(gammaField)
!$OMP END PARALLEL DO !$OMP END PARALLEL DO
end if memoryEfficient end if memoryEfficient
if (cells3Offset == 0) tensorField_fourier(1:3,1:3,1,1,1) = cmplx(fieldAim,0.0_pReal,pReal) if (cells3Offset == 0) tensorField_fourier(1:3,1:3,1,1,1) = cmplx(fieldAim,0.0_pREAL,pREAL)
call fftw_mpi_execute_dft_c2r(planTensorBack,tensorField_fourier,tensorField_real) call fftw_mpi_execute_dft_c2r(planTensorBack,tensorField_fourier,tensorField_real)
gammaField = tensorField_real(1:3,1:3,1:cells(1),1:cells(2),1:cells3) gammaField = tensorField_real(1:3,1:3,1:cells(1),1:cells(2),1:cells3)
@ -494,24 +494,24 @@ end function utilities_GammaConvolution
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
function utilities_GreenConvolution(field, D_ref, mu_ref, Delta_t) result(greenField) function utilities_GreenConvolution(field, D_ref, mu_ref, Delta_t) result(greenField)
real(pReal), intent(in), dimension(cells(1),cells(2),cells3) :: field real(pREAL), intent(in), dimension(cells(1),cells(2),cells3) :: field
real(pReal), dimension(3,3), intent(in) :: D_ref real(pREAL), dimension(3,3), intent(in) :: D_ref
real(pReal), intent(in) :: mu_ref, Delta_t real(pREAL), intent(in) :: mu_ref, Delta_t
real(pReal), dimension(cells(1),cells(2),cells3) :: greenField real(pREAL), dimension(cells(1),cells(2),cells3) :: greenField
complex(pReal) :: GreenOp_hat complex(pREAL) :: GreenOp_hat
integer :: i, j, k integer :: i, j, k
scalarField_real(cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pReal scalarField_real(cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pREAL
scalarField_real(1:cells(1), 1:cells(2),1:cells3) = field scalarField_real(1:cells(1), 1:cells(2),1:cells3) = field
call fftw_mpi_execute_dft_r2c(planScalarForth,scalarField_real,scalarField_fourier) call fftw_mpi_execute_dft_r2c(planScalarForth,scalarField_real,scalarField_fourier)
!$OMP PARALLEL DO PRIVATE(GreenOp_hat) !$OMP PARALLEL DO PRIVATE(GreenOp_hat)
do j = 1, cells2; do k = 1, cells(3); do i = 1, cells1Red do j = 1, cells2; do k = 1, cells(3); do i = 1, cells1Red
GreenOp_hat = cmplx(wgt,0.0_pReal,pReal) & GreenOp_hat = cmplx(wgt,0.0_pREAL,pREAL) &
/ (cmplx(mu_ref,0.0_pReal,pReal) + cmplx(Delta_t,0.0_pReal,pReal) & / (cmplx(mu_ref,0.0_pREAL,pREAL) + cmplx(Delta_t,0.0_pREAL,pREAL) &
* sum(conjg(xi1st(1:3,i,k,j))* matmul(cmplx(D_ref,0.0_pReal,pReal),xi1st(1:3,i,k,j)))) * sum(conjg(xi1st(1:3,i,k,j))* matmul(cmplx(D_ref,0.0_pREAL,pREAL),xi1st(1:3,i,k,j))))
scalarField_fourier(i,k,j) = scalarField_fourier(i,k,j)*GreenOp_hat scalarField_fourier(i,k,j) = scalarField_fourier(i,k,j)*GreenOp_hat
end do; end do; end do end do; end do; end do
!$OMP END PARALLEL DO !$OMP END PARALLEL DO
@ -525,28 +525,28 @@ end function utilities_GreenConvolution
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Calculate root mean square of divergence. !> @brief Calculate root mean square of divergence.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
real(pReal) function utilities_divergenceRMS(tensorField) real(pREAL) function utilities_divergenceRMS(tensorField)
real(pReal), dimension(3,3,cells(1),cells(2),cells3), intent(in) :: tensorField real(pREAL), dimension(3,3,cells(1),cells(2),cells3), intent(in) :: tensorField
integer :: i, j, k integer :: i, j, k
integer(MPI_INTEGER_KIND) :: err_MPI integer(MPI_INTEGER_KIND) :: err_MPI
complex(pReal), dimension(3) :: rescaledGeom complex(pREAL), dimension(3) :: rescaledGeom
tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pReal tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pREAL
tensorField_real(1:3,1:3,1:cells(1), 1:cells(2),1:cells3) = tensorField tensorField_real(1:3,1:3,1:cells(1), 1:cells(2),1:cells3) = tensorField
call fftw_mpi_execute_dft_r2c(planTensorForth,tensorField_real,tensorField_fourier) call fftw_mpi_execute_dft_r2c(planTensorForth,tensorField_real,tensorField_fourier)
rescaledGeom = cmplx(geomSize/scaledGeomSize,0.0_pReal,pReal) rescaledGeom = cmplx(geomSize/scaledGeomSize,0.0_pREAL,pREAL)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! calculating RMS divergence criterion in Fourier space ! calculating RMS divergence criterion in Fourier space
utilities_divergenceRMS = 0.0_pReal utilities_divergenceRMS = 0.0_pREAL
do j = 1, cells2; do k = 1, cells(3) do j = 1, cells2; do k = 1, cells(3)
do i = 2, cells1Red -1 ! Has somewhere a conj. complex counterpart. Therefore count it twice. do i = 2, cells1Red -1 ! Has somewhere a conj. complex counterpart. Therefore count it twice.
utilities_divergenceRMS = utilities_divergenceRMS & utilities_divergenceRMS = utilities_divergenceRMS &
+ 2.0_pReal*(sum (real(matmul(tensorField_fourier(1:3,1:3,i,k,j), & ! (sqrt(real(a)**2 + aimag(a)**2))**2 = real(a)**2 + aimag(a)**2, i.e. do not take square root and square again + 2.0_pREAL*(sum (real(matmul(tensorField_fourier(1:3,1:3,i,k,j), & ! (sqrt(real(a)**2 + aimag(a)**2))**2 = real(a)**2 + aimag(a)**2, i.e. do not take square root and square again
conjg(-xi1st(1:3,i,k,j))*rescaledGeom))**2) & ! --> sum squared L_2 norm of vector conjg(-xi1st(1:3,i,k,j))*rescaledGeom))**2) & ! --> sum squared L_2 norm of vector
+sum(aimag(matmul(tensorField_fourier(1:3,1:3,i,k,j),& +sum(aimag(matmul(tensorField_fourier(1:3,1:3,i,k,j),&
conjg(-xi1st(1:3,i,k,j))*rescaledGeom))**2)) conjg(-xi1st(1:3,i,k,j))*rescaledGeom))**2))
@ -564,7 +564,7 @@ real(pReal) function utilities_divergenceRMS(tensorField)
call MPI_Allreduce(MPI_IN_PLACE,utilities_divergenceRMS,1_MPI_INTEGER_KIND,MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI) call MPI_Allreduce(MPI_IN_PLACE,utilities_divergenceRMS,1_MPI_INTEGER_KIND,MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI)
if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
utilities_divergenceRMS = sqrt(utilities_divergenceRMS) * wgt ! RMS in real space calculated with Parsevals theorem from Fourier space utilities_divergenceRMS = sqrt(utilities_divergenceRMS) * wgt ! RMS in real space calculated with Parsevals theorem from Fourier space
if (cells(1) == 1) utilities_divergenceRMS = utilities_divergenceRMS * 0.5_pReal ! counted twice in case of cells(1) == 1 if (cells(1) == 1) utilities_divergenceRMS = utilities_divergenceRMS * 0.5_pREAL ! counted twice in case of cells(1) == 1
end function utilities_divergenceRMS end function utilities_divergenceRMS
@ -572,25 +572,25 @@ end function utilities_divergenceRMS
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Calculate root mean square of curl. !> @brief Calculate root mean square of curl.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
real(pReal) function utilities_curlRMS(tensorField) real(pREAL) function utilities_curlRMS(tensorField)
real(pReal), dimension(3,3,cells(1),cells(2),cells3), intent(in) :: tensorField real(pREAL), dimension(3,3,cells(1),cells(2),cells3), intent(in) :: tensorField
integer :: i, j, k, l integer :: i, j, k, l
integer(MPI_INTEGER_KIND) :: err_MPI integer(MPI_INTEGER_KIND) :: err_MPI
complex(pReal), dimension(3,3) :: curl_fourier complex(pREAL), dimension(3,3) :: curl_fourier
complex(pReal), dimension(3) :: rescaledGeom complex(pREAL), dimension(3) :: rescaledGeom
tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pReal tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pREAL
tensorField_real(1:3,1:3,1:cells(1), 1:cells(2),1:cells3) = tensorField tensorField_real(1:3,1:3,1:cells(1), 1:cells(2),1:cells3) = tensorField
call fftw_mpi_execute_dft_r2c(planTensorForth,tensorField_real,tensorField_fourier) call fftw_mpi_execute_dft_r2c(planTensorForth,tensorField_real,tensorField_fourier)
rescaledGeom = cmplx(geomSize/scaledGeomSize,0.0_pReal,pReal) rescaledGeom = cmplx(geomSize/scaledGeomSize,0.0_pREAL,pREAL)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! calculating max curl criterion in Fourier space ! calculating max curl criterion in Fourier space
utilities_curlRMS = 0.0_pReal utilities_curlRMS = 0.0_pREAL
do j = 1, cells2; do k = 1, cells(3); do j = 1, cells2; do k = 1, cells(3);
do i = 2, cells1Red - 1 do i = 2, cells1Red - 1
@ -603,7 +603,7 @@ real(pReal) function utilities_curlRMS(tensorField)
-tensorField_fourier(l,1,i,k,j)*xi1st(2,i,k,j)*rescaledGeom(2)) -tensorField_fourier(l,1,i,k,j)*xi1st(2,i,k,j)*rescaledGeom(2))
end do end do
utilities_curlRMS = utilities_curlRMS & utilities_curlRMS = utilities_curlRMS &
+2.0_pReal*sum(curl_fourier%re**2+curl_fourier%im**2) ! Has somewhere a conj. complex counterpart. Therefore count it twice. +2.0_pREAL*sum(curl_fourier%re**2+curl_fourier%im**2) ! Has somewhere a conj. complex counterpart. Therefore count it twice.
end do end do
do l = 1, 3 do l = 1, 3
curl_fourier = (+tensorField_fourier(l,3,1,k,j)*xi1st(2,1,k,j)*rescaledGeom(2) & curl_fourier = (+tensorField_fourier(l,3,1,k,j)*xi1st(2,1,k,j)*rescaledGeom(2) &
@ -630,7 +630,7 @@ real(pReal) function utilities_curlRMS(tensorField)
call MPI_Allreduce(MPI_IN_PLACE,utilities_curlRMS,1_MPI_INTEGER_KIND,MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI) call MPI_Allreduce(MPI_IN_PLACE,utilities_curlRMS,1_MPI_INTEGER_KIND,MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI)
if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
utilities_curlRMS = sqrt(utilities_curlRMS) * wgt ! RMS in real space calculated with Parsevals theorem from Fourier space utilities_curlRMS = sqrt(utilities_curlRMS) * wgt ! RMS in real space calculated with Parsevals theorem from Fourier space
if (cells(1) == 1) utilities_curlRMS = utilities_curlRMS * 0.5_pReal ! counted twice in case of cells(1) == 1 if (cells(1) == 1) utilities_curlRMS = utilities_curlRMS * 0.5_pREAL ! counted twice in case of cells(1) == 1
end function utilities_curlRMS end function utilities_curlRMS
@ -640,17 +640,17 @@ end function utilities_curlRMS
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
function utilities_maskedCompliance(rot_BC,mask_stress,C) function utilities_maskedCompliance(rot_BC,mask_stress,C)
real(pReal), dimension(3,3,3,3) :: utilities_maskedCompliance !< masked compliance real(pREAL), dimension(3,3,3,3) :: utilities_maskedCompliance !< masked compliance
real(pReal), intent(in), dimension(3,3,3,3) :: C !< current average stiffness real(pREAL), intent(in), dimension(3,3,3,3) :: C !< current average stiffness
type(tRotation), intent(in) :: rot_BC !< rotation of load frame type(tRotation), intent(in) :: rot_BC !< rotation of load frame
logical, intent(in), dimension(3,3) :: mask_stress !< mask of stress BC logical, intent(in), dimension(3,3) :: mask_stress !< mask of stress BC
integer :: i, j integer :: i, j
logical, dimension(9) :: mask_stressVector logical, dimension(9) :: mask_stressVector
logical, dimension(9,9) :: mask logical, dimension(9,9) :: mask
real(pReal), dimension(9,9) :: temp99_real real(pREAL), dimension(9,9) :: temp99_real
integer :: size_reduced = 0 integer :: size_reduced = 0
real(pReal), dimension(:,:), allocatable :: & real(pREAL), dimension(:,:), allocatable :: &
s_reduced, & !< reduced compliance matrix (depending on number of stress BC) s_reduced, & !< reduced compliance matrix (depending on number of stress BC)
c_reduced, & !< reduced stiffness (depending on number of stress BC) c_reduced, & !< reduced stiffness (depending on number of stress BC)
sTimesC !< temp variable to check inversion sTimesC !< temp variable to check inversion
@ -674,7 +674,7 @@ function utilities_maskedCompliance(rot_BC,mask_stress,C)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! check if inversion was successful ! check if inversion was successful
sTimesC = matmul(c_reduced,s_reduced) sTimesC = matmul(c_reduced,s_reduced)
errmatinv = errmatinv .or. any(dNeq(sTimesC,math_eye(size_reduced),1.0e-12_pReal)) errmatinv = errmatinv .or. any(dNeq(sTimesC,math_eye(size_reduced),1.0e-12_pREAL))
if (errmatinv) then if (errmatinv) then
write(formatString, '(i2)') size_reduced write(formatString, '(i2)') size_reduced
formatString = '(/,1x,a,/,'//trim(formatString)//'('//trim(formatString)//'(2x,es9.2,1x)/))' formatString = '(/,1x,a,/,'//trim(formatString)//'('//trim(formatString)//'(2x,es9.2,1x)/))'
@ -682,9 +682,9 @@ function utilities_maskedCompliance(rot_BC,mask_stress,C)
print trim(formatString), 'S (load) ', transpose(s_reduced) print trim(formatString), 'S (load) ', transpose(s_reduced)
if (errmatinv) error stop 'matrix inversion error' if (errmatinv) error stop 'matrix inversion error'
end if end if
temp99_real = reshape(unpack(reshape(s_reduced,[size_reduced**2]),reshape(mask,[81]),0.0_pReal),[9,9]) temp99_real = reshape(unpack(reshape(s_reduced,[size_reduced**2]),reshape(mask,[81]),0.0_pREAL),[9,9])
else else
temp99_real = 0.0_pReal temp99_real = 0.0_pREAL
end if end if
utilities_maskedCompliance = math_99to3333(temp99_Real) utilities_maskedCompliance = math_99to3333(temp99_Real)
@ -697,13 +697,13 @@ end function utilities_maskedCompliance
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
function utilities_scalarGradient(field) result(grad) function utilities_scalarGradient(field) result(grad)
real(pReal), intent(in), dimension( cells(1),cells(2),cells3) :: field real(pREAL), intent(in), dimension( cells(1),cells(2),cells3) :: field
real(pReal), dimension(3,cells(1),cells(2),cells3) :: grad real(pREAL), dimension(3,cells(1),cells(2),cells3) :: grad
integer :: i, j, k integer :: i, j, k
scalarField_real(cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pReal scalarField_real(cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pREAL
scalarField_real(1:cells(1), 1:cells(2),1:cells3) = field scalarField_real(1:cells(1), 1:cells(2),1:cells3) = field
call fftw_mpi_execute_dft_r2c(planScalarForth,scalarField_real,scalarField_fourier) call fftw_mpi_execute_dft_r2c(planScalarForth,scalarField_real,scalarField_fourier)
do j = 1, cells2; do k = 1, cells(3); do i = 1,cells1Red do j = 1, cells2; do k = 1, cells(3); do i = 1,cells1Red
@ -720,11 +720,11 @@ end function utilities_scalarGradient
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
function utilities_vectorDivergence(field) result(div) function utilities_vectorDivergence(field) result(div)
real(pReal), intent(in), dimension(3,cells(1),cells(2),cells3) :: field real(pREAL), intent(in), dimension(3,cells(1),cells(2),cells3) :: field
real(pReal), dimension( cells(1),cells(2),cells3) :: div real(pREAL), dimension( cells(1),cells(2),cells3) :: div
vectorField_real(1:3,cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pReal vectorField_real(1:3,cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pREAL
vectorField_real(1:3,1:cells(1), 1:cells(2),1:cells3) = field vectorField_real(1:3,1:cells(1), 1:cells(2),1:cells3) = field
call fftw_mpi_execute_dft_r2c(planVectorForth,vectorField_real,vectorField_fourier) call fftw_mpi_execute_dft_r2c(planVectorForth,vectorField_real,vectorField_fourier)
scalarField_fourier(1:cells1Red,1:cells(3),1:cells2) = sum(vectorField_fourier(1:3,1:cells1Red,1:cells(3),1:cells2) & scalarField_fourier(1:cells1Red,1:cells(3),1:cells2) = sum(vectorField_fourier(1:3,1:cells1Red,1:cells(3),1:cells2) &
@ -741,19 +741,19 @@ end function utilities_vectorDivergence
subroutine utilities_constitutiveResponse(P,P_av,C_volAvg,C_minmaxAvg,& subroutine utilities_constitutiveResponse(P,P_av,C_volAvg,C_minmaxAvg,&
F,Delta_t,rotation_BC) F,Delta_t,rotation_BC)
real(pReal), intent(out), dimension(3,3,3,3) :: C_volAvg, C_minmaxAvg !< average stiffness real(pREAL), intent(out), dimension(3,3,3,3) :: C_volAvg, C_minmaxAvg !< average stiffness
real(pReal), intent(out), dimension(3,3) :: P_av !< average PK stress real(pREAL), intent(out), dimension(3,3) :: P_av !< average PK stress
real(pReal), intent(out), dimension(3,3,cells(1),cells(2),cells3) :: P !< PK stress real(pREAL), intent(out), dimension(3,3,cells(1),cells(2),cells3) :: P !< PK stress
real(pReal), intent(in), dimension(3,3,cells(1),cells(2),cells3) :: F !< deformation gradient target real(pREAL), intent(in), dimension(3,3,cells(1),cells(2),cells3) :: F !< deformation gradient target
real(pReal), intent(in) :: Delta_t !< loading time real(pREAL), intent(in) :: Delta_t !< loading time
type(tRotation), intent(in), optional :: rotation_BC !< rotation of load frame type(tRotation), intent(in), optional :: rotation_BC !< rotation of load frame
integer :: i integer :: i
integer(MPI_INTEGER_KIND) :: err_MPI integer(MPI_INTEGER_KIND) :: err_MPI
real(pReal), dimension(3,3,3,3) :: dPdF_max, dPdF_min real(pREAL), dimension(3,3,3,3) :: dPdF_max, dPdF_min
real(pReal) :: dPdF_norm_max, dPdF_norm_min real(pREAL) :: dPdF_norm_max, dPdF_norm_min
real(pReal), dimension(2) :: valueAndRank !< pair of min/max norm of dPdF to synchronize min/max of dPdF real(pREAL), dimension(2) :: valueAndRank !< pair of min/max norm of dPdF to synchronize min/max of dPdF
print'(/,1x,a)', '... evaluating constitutive response ......................................' print'(/,1x,a)', '... evaluating constitutive response ......................................'
flush(IO_STDOUT) flush(IO_STDOUT)
@ -771,19 +771,19 @@ subroutine utilities_constitutiveResponse(P,P_av,C_volAvg,C_minmaxAvg,&
call MPI_Allreduce(MPI_IN_PLACE,P_av,9_MPI_INTEGER_KIND,MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI) call MPI_Allreduce(MPI_IN_PLACE,P_av,9_MPI_INTEGER_KIND,MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI)
if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
if (present(rotation_BC)) then if (present(rotation_BC)) then
if (any(dNeq(rotation_BC%asQuaternion(), real([1.0, 0.0, 0.0, 0.0],pReal)))) & if (any(dNeq(rotation_BC%asQuaternion(), real([1.0, 0.0, 0.0, 0.0],pREAL)))) &
print'(/,1x,a,/,2(3(2x,f12.4,1x)/),3(2x,f12.4,1x))', & print'(/,1x,a,/,2(3(2x,f12.4,1x)/),3(2x,f12.4,1x))', &
'Piola--Kirchhoff stress (lab) / MPa =', transpose(P_av)*1.e-6_pReal 'Piola--Kirchhoff stress (lab) / MPa =', transpose(P_av)*1.e-6_pREAL
P_av = rotation_BC%rotate(P_av) P_av = rotation_BC%rotate(P_av)
end if end if
print'(/,1x,a,/,2(3(2x,f12.4,1x)/),3(2x,f12.4,1x))', & print'(/,1x,a,/,2(3(2x,f12.4,1x)/),3(2x,f12.4,1x))', &
'Piola--Kirchhoff stress / MPa =', transpose(P_av)*1.e-6_pReal 'Piola--Kirchhoff stress / MPa =', transpose(P_av)*1.e-6_pREAL
flush(IO_STDOUT) flush(IO_STDOUT)
dPdF_max = 0.0_pReal dPdF_max = 0.0_pREAL
dPdF_norm_max = 0.0_pReal dPdF_norm_max = 0.0_pREAL
dPdF_min = huge(1.0_pReal) dPdF_min = huge(1.0_pREAL)
dPdF_norm_min = huge(1.0_pReal) dPdF_norm_min = huge(1.0_pREAL)
do i = 1, product(cells(1:2))*cells3 do i = 1, product(cells(1:2))*cells3
if (dPdF_norm_max < sum(homogenization_dPdF(1:3,1:3,1:3,1:3,i)**2)) then if (dPdF_norm_max < sum(homogenization_dPdF(1:3,1:3,1:3,1:3,i)**2)) then
dPdF_max = homogenization_dPdF(1:3,1:3,1:3,1:3,i) dPdF_max = homogenization_dPdF(1:3,1:3,1:3,1:3,i)
@ -795,19 +795,19 @@ subroutine utilities_constitutiveResponse(P,P_av,C_volAvg,C_minmaxAvg,&
end if end if
end do end do
valueAndRank = [dPdF_norm_max,real(worldrank,pReal)] valueAndRank = [dPdF_norm_max,real(worldrank,pREAL)]
call MPI_Allreduce(MPI_IN_PLACE,valueAndRank,1_MPI_INTEGER_KIND,MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_WORLD,err_MPI) call MPI_Allreduce(MPI_IN_PLACE,valueAndRank,1_MPI_INTEGER_KIND,MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_WORLD,err_MPI)
if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
call MPI_Bcast(dPdF_max,81_MPI_INTEGER_KIND,MPI_DOUBLE,int(valueAndRank(2),MPI_INTEGER_KIND),MPI_COMM_WORLD,err_MPI) call MPI_Bcast(dPdF_max,81_MPI_INTEGER_KIND,MPI_DOUBLE,int(valueAndRank(2),MPI_INTEGER_KIND),MPI_COMM_WORLD,err_MPI)
if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
valueAndRank = [dPdF_norm_min,real(worldrank,pReal)] valueAndRank = [dPdF_norm_min,real(worldrank,pREAL)]
call MPI_Allreduce(MPI_IN_PLACE,valueAndRank,1_MPI_INTEGER_KIND,MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_WORLD,err_MPI) call MPI_Allreduce(MPI_IN_PLACE,valueAndRank,1_MPI_INTEGER_KIND,MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_WORLD,err_MPI)
if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
call MPI_Bcast(dPdF_min,81_MPI_INTEGER_KIND,MPI_DOUBLE,int(valueAndRank(2),MPI_INTEGER_KIND),MPI_COMM_WORLD,err_MPI) call MPI_Bcast(dPdF_min,81_MPI_INTEGER_KIND,MPI_DOUBLE,int(valueAndRank(2),MPI_INTEGER_KIND),MPI_COMM_WORLD,err_MPI)
if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
C_minmaxAvg = 0.5_pReal*(dPdF_max + dPdF_min) C_minmaxAvg = 0.5_pREAL*(dPdF_max + dPdF_min)
C_volAvg = sum(homogenization_dPdF,dim=5) C_volAvg = sum(homogenization_dPdF,dim=5)
call MPI_Allreduce(MPI_IN_PLACE,C_volAvg,81_MPI_INTEGER_KIND,MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI) call MPI_Allreduce(MPI_IN_PLACE,C_volAvg,81_MPI_INTEGER_KIND,MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI)
@ -823,16 +823,16 @@ end subroutine utilities_constitutiveResponse
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function utilities_calculateRate(heterogeneous,field0,field,dt,avRate) pure function utilities_calculateRate(heterogeneous,field0,field,dt,avRate)
real(pReal), intent(in), dimension(3,3) :: & real(pREAL), intent(in), dimension(3,3) :: &
avRate !< homogeneous addon avRate !< homogeneous addon
real(pReal), intent(in) :: & real(pREAL), intent(in) :: &
dt !< Delta_t between field0 and field dt !< Delta_t between field0 and field
logical, intent(in) :: & logical, intent(in) :: &
heterogeneous !< calculate field of rates heterogeneous !< calculate field of rates
real(pReal), intent(in), dimension(3,3,cells(1),cells(2),cells3) :: & real(pREAL), intent(in), dimension(3,3,cells(1),cells(2),cells3) :: &
field0, & !< data of previous step field0, & !< data of previous step
field !< data of current step field !< data of current step
real(pReal), dimension(3,3,cells(1),cells(2),cells3) :: & real(pREAL), dimension(3,3,cells(1),cells(2),cells3) :: &
utilities_calculateRate utilities_calculateRate
@ -849,17 +849,17 @@ end function utilities_calculateRate
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
function utilities_forwardField(Delta_t,field_lastInc,rate,aim) function utilities_forwardField(Delta_t,field_lastInc,rate,aim)
real(pReal), intent(in) :: & real(pREAL), intent(in) :: &
Delta_t !< Delta_t of current step Delta_t !< Delta_t of current step
real(pReal), intent(in), dimension(3,3,cells(1),cells(2),cells3) :: & real(pREAL), intent(in), dimension(3,3,cells(1),cells(2),cells3) :: &
field_lastInc, & !< initial field field_lastInc, & !< initial field
rate !< rate by which to forward rate !< rate by which to forward
real(pReal), intent(in), optional, dimension(3,3) :: & real(pREAL), intent(in), optional, dimension(3,3) :: &
aim !< average field value aim aim !< average field value aim
real(pReal), dimension(3,3,cells(1),cells(2),cells3) :: & real(pREAL), dimension(3,3,cells(1),cells(2),cells3) :: &
utilities_forwardField utilities_forwardField
real(pReal), dimension(3,3) :: fieldDiff !< <a + adot*t> - aim real(pREAL), dimension(3,3) :: fieldDiff !< <a + adot*t> - aim
integer(MPI_INTEGER_KIND) :: err_MPI integer(MPI_INTEGER_KIND) :: err_MPI
@ -885,42 +885,42 @@ pure function utilities_getFreqDerivative(k_s)
integer, intent(in), dimension(3) :: k_s !< indices of frequency integer, intent(in), dimension(3) :: k_s !< indices of frequency
complex(pReal), dimension(3) :: utilities_getFreqDerivative complex(pREAL), dimension(3) :: utilities_getFreqDerivative
select case (spectral_derivative_ID) select case (spectral_derivative_ID)
case (DERIVATIVE_CONTINUOUS_ID) case (DERIVATIVE_CONTINUOUS_ID)
utilities_getFreqDerivative = cmplx(0.0_pReal, TAU*real(k_s,pReal)/geomSize,pReal) utilities_getFreqDerivative = cmplx(0.0_pREAL, TAU*real(k_s,pREAL)/geomSize,pREAL)
case (DERIVATIVE_CENTRAL_DIFF_ID) case (DERIVATIVE_CENTRAL_DIFF_ID)
utilities_getFreqDerivative = cmplx(0.0_pReal, sin(TAU*real(k_s,pReal)/real(cells,pReal)), pReal)/ & utilities_getFreqDerivative = cmplx(0.0_pREAL, sin(TAU*real(k_s,pREAL)/real(cells,pREAL)), pREAL)/ &
cmplx(2.0_pReal*geomSize/real(cells,pReal), 0.0_pReal, pReal) cmplx(2.0_pREAL*geomSize/real(cells,pREAL), 0.0_pREAL, pREAL)
case (DERIVATIVE_FWBW_DIFF_ID) case (DERIVATIVE_FWBW_DIFF_ID)
utilities_getFreqDerivative(1) = & utilities_getFreqDerivative(1) = &
cmplx(cos(TAU*real(k_s(1),pReal)/real(cells(1),pReal)) - 1.0_pReal, & cmplx(cos(TAU*real(k_s(1),pREAL)/real(cells(1),pREAL)) - 1.0_pREAL, &
sin(TAU*real(k_s(1),pReal)/real(cells(1),pReal)), pReal)* & sin(TAU*real(k_s(1),pREAL)/real(cells(1),pREAL)), pREAL)* &
cmplx(cos(TAU*real(k_s(2),pReal)/real(cells(2),pReal)) + 1.0_pReal, & cmplx(cos(TAU*real(k_s(2),pREAL)/real(cells(2),pREAL)) + 1.0_pREAL, &
sin(TAU*real(k_s(2),pReal)/real(cells(2),pReal)), pReal)* & sin(TAU*real(k_s(2),pREAL)/real(cells(2),pREAL)), pREAL)* &
cmplx(cos(TAU*real(k_s(3),pReal)/real(cells(3),pReal)) + 1.0_pReal, & cmplx(cos(TAU*real(k_s(3),pREAL)/real(cells(3),pREAL)) + 1.0_pREAL, &
sin(TAU*real(k_s(3),pReal)/real(cells(3),pReal)), pReal)/ & sin(TAU*real(k_s(3),pREAL)/real(cells(3),pREAL)), pREAL)/ &
cmplx(4.0_pReal*geomSize(1)/real(cells(1),pReal), 0.0_pReal, pReal) cmplx(4.0_pREAL*geomSize(1)/real(cells(1),pREAL), 0.0_pREAL, pREAL)
utilities_getFreqDerivative(2) = & utilities_getFreqDerivative(2) = &
cmplx(cos(TAU*real(k_s(1),pReal)/real(cells(1),pReal)) + 1.0_pReal, & cmplx(cos(TAU*real(k_s(1),pREAL)/real(cells(1),pREAL)) + 1.0_pREAL, &
sin(TAU*real(k_s(1),pReal)/real(cells(1),pReal)), pReal)* & sin(TAU*real(k_s(1),pREAL)/real(cells(1),pREAL)), pREAL)* &
cmplx(cos(TAU*real(k_s(2),pReal)/real(cells(2),pReal)) - 1.0_pReal, & cmplx(cos(TAU*real(k_s(2),pREAL)/real(cells(2),pREAL)) - 1.0_pREAL, &
sin(TAU*real(k_s(2),pReal)/real(cells(2),pReal)), pReal)* & sin(TAU*real(k_s(2),pREAL)/real(cells(2),pREAL)), pREAL)* &
cmplx(cos(TAU*real(k_s(3),pReal)/real(cells(3),pReal)) + 1.0_pReal, & cmplx(cos(TAU*real(k_s(3),pREAL)/real(cells(3),pREAL)) + 1.0_pREAL, &
sin(TAU*real(k_s(3),pReal)/real(cells(3),pReal)), pReal)/ & sin(TAU*real(k_s(3),pREAL)/real(cells(3),pREAL)), pREAL)/ &
cmplx(4.0_pReal*geomSize(2)/real(cells(2),pReal), 0.0_pReal, pReal) cmplx(4.0_pREAL*geomSize(2)/real(cells(2),pREAL), 0.0_pREAL, pREAL)
utilities_getFreqDerivative(3) = & utilities_getFreqDerivative(3) = &
cmplx(cos(TAU*real(k_s(1),pReal)/real(cells(1),pReal)) + 1.0_pReal, & cmplx(cos(TAU*real(k_s(1),pREAL)/real(cells(1),pREAL)) + 1.0_pREAL, &
sin(TAU*real(k_s(1),pReal)/real(cells(1),pReal)), pReal)* & sin(TAU*real(k_s(1),pREAL)/real(cells(1),pREAL)), pREAL)* &
cmplx(cos(TAU*real(k_s(2),pReal)/real(cells(2),pReal)) + 1.0_pReal, & cmplx(cos(TAU*real(k_s(2),pREAL)/real(cells(2),pREAL)) + 1.0_pREAL, &
sin(TAU*real(k_s(2),pReal)/real(cells(2),pReal)), pReal)* & sin(TAU*real(k_s(2),pREAL)/real(cells(2),pREAL)), pREAL)* &
cmplx(cos(TAU*real(k_s(3),pReal)/real(cells(3),pReal)) - 1.0_pReal, & cmplx(cos(TAU*real(k_s(3),pREAL)/real(cells(3),pREAL)) - 1.0_pREAL, &
sin(TAU*real(k_s(3),pReal)/real(cells(3),pReal)), pReal)/ & sin(TAU*real(k_s(3),pREAL)/real(cells(3),pREAL)), pREAL)/ &
cmplx(4.0_pReal*geomSize(3)/real(cells(3),pReal), 0.0_pReal, pReal) cmplx(4.0_pREAL*geomSize(3)/real(cells(3),pREAL), 0.0_pREAL, pREAL)
end select end select
end function utilities_getFreqDerivative end function utilities_getFreqDerivative
@ -932,11 +932,11 @@ end function utilities_getFreqDerivative
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine utilities_updateCoords(F) subroutine utilities_updateCoords(F)
real(pReal), dimension(3,3,cells(1),cells(2),cells3), intent(in) :: F real(pREAL), dimension(3,3,cells(1),cells(2),cells3), intent(in) :: F
real(pReal), dimension(3, cells(1),cells(2),cells3) :: x_p !< Point/cell center coordinates real(pREAL), dimension(3, cells(1),cells(2),cells3) :: x_p !< Point/cell center coordinates
real(pReal), dimension(3, cells(1),cells(2),0:cells3+1) :: u_tilde_p_padded !< Fluctuation of cell center displacement (padded along z for MPI) real(pREAL), dimension(3, cells(1),cells(2),0:cells3+1) :: u_tilde_p_padded !< Fluctuation of cell center displacement (padded along z for MPI)
real(pReal), dimension(3, cells(1)+1,cells(2)+1,cells3+1) :: x_n !< Node coordinates real(pREAL), dimension(3, cells(1)+1,cells(2)+1,cells3+1) :: x_n !< Node coordinates
integer :: & integer :: &
i,j,k,n, & i,j,k,n, &
c c
@ -950,8 +950,8 @@ subroutine utilities_updateCoords(F)
integer, dimension(4) :: request integer, dimension(4) :: request
integer, dimension(MPI_STATUS_SIZE,4) :: status integer, dimension(MPI_STATUS_SIZE,4) :: status
#endif #endif
real(pReal), dimension(3) :: step real(pREAL), dimension(3) :: step
real(pReal), dimension(3,3) :: Favg real(pREAL), dimension(3,3) :: Favg
integer, dimension(3) :: me integer, dimension(3) :: me
integer, dimension(3,8) :: & integer, dimension(3,8) :: &
neighbor = reshape([ & neighbor = reshape([ &
@ -965,10 +965,10 @@ subroutine utilities_updateCoords(F)
0, 1, 1 ], [3,8]) 0, 1, 1 ], [3,8])
step = geomSize/real(cells, pReal) step = geomSize/real(cells, pREAL)
tensorField_real(1:3,1:3,1:cells(1), 1:cells(2),1:cells3) = F tensorField_real(1:3,1:3,1:cells(1), 1:cells(2),1:cells3) = F
tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pReal tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pREAL
call fftw_mpi_execute_dft_r2c(planTensorForth,tensorField_real,tensorField_fourier) call fftw_mpi_execute_dft_r2c(planTensorForth,tensorField_real,tensorField_fourier)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
@ -985,7 +985,7 @@ subroutine utilities_updateCoords(F)
vectorField_fourier(1:3,i,k,j) = matmul(tensorField_fourier(1:3,1:3,i,k,j),xi2nd(1:3,i,k,j)) & vectorField_fourier(1:3,i,k,j) = matmul(tensorField_fourier(1:3,1:3,i,k,j),xi2nd(1:3,i,k,j)) &
/ sum(conjg(-xi2nd(1:3,i,k,j))*xi2nd(1:3,i,k,j)) / sum(conjg(-xi2nd(1:3,i,k,j))*xi2nd(1:3,i,k,j))
else else
vectorField_fourier(1:3,i,k,j) = cmplx(0.0,0.0,pReal) vectorField_fourier(1:3,i,k,j) = cmplx(0.0,0.0,pREAL)
end if end if
end do; end do; end do end do; end do; end do
!$OMP END PARALLEL DO !$OMP END PARALLEL DO
@ -1021,13 +1021,13 @@ subroutine utilities_updateCoords(F)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! calculate nodal positions ! calculate nodal positions
x_n = 0.0_pReal x_n = 0.0_pREAL
do j = 0,cells(2); do k = 0,cells3; do i = 0,cells(1) do j = 0,cells(2); do k = 0,cells3; do i = 0,cells(1)
x_n(1:3,i+1,j+1,k+1) = matmul(Favg,step*(real([i,j,k+cells3Offset],pReal))) x_n(1:3,i+1,j+1,k+1) = matmul(Favg,step*(real([i,j,k+cells3Offset],pREAL)))
averageFluct: do n = 1,8 averageFluct: do n = 1,8
me = [i+neighbor(1,n),j+neighbor(2,n),k+neighbor(3,n)] me = [i+neighbor(1,n),j+neighbor(2,n),k+neighbor(3,n)]
x_n(1:3,i+1,j+1,k+1) = x_n(1:3,i+1,j+1,k+1) & x_n(1:3,i+1,j+1,k+1) = x_n(1:3,i+1,j+1,k+1) &
+ u_tilde_p_padded(1:3,modulo(me(1)-1,cells(1))+1,modulo(me(2)-1,cells(2))+1,me(3))*0.125_pReal + u_tilde_p_padded(1:3,modulo(me(1)-1,cells(1))+1,modulo(me(2)-1,cells(2))+1,me(3))*0.125_pREAL
end do averageFluct end do averageFluct
end do; end do; end do end do; end do; end do
@ -1035,7 +1035,7 @@ subroutine utilities_updateCoords(F)
! calculate cell center/point positions ! calculate cell center/point positions
do k = 1,cells3; do j = 1,cells(2); do i = 1,cells(1) do k = 1,cells3; do j = 1,cells(2); do i = 1,cells(1)
x_p(1:3,i,j,k) = u_tilde_p_padded(1:3,i,j,k) & x_p(1:3,i,j,k) = u_tilde_p_padded(1:3,i,j,k) &
+ matmul(Favg,step*(real([i,j,k+cells3Offset],pReal)-0.5_pReal)) + matmul(Favg,step*(real([i,j,k+cells3Offset],pREAL)-0.5_pREAL))
end do; end do; end do end do; end do; end do
call discretization_setNodeCoords(reshape(x_n,[3,(cells(1)+1)*(cells(2)+1)*(cells3+1)])) call discretization_setNodeCoords(reshape(x_n,[3,(cells(1)+1)*(cells(2)+1)*(cells3+1)]))
@ -1049,62 +1049,62 @@ end subroutine utilities_updateCoords
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine selfTest() subroutine selfTest()
real(pReal), allocatable, dimension(:,:,:,:,:) :: tensorField_real_ real(pREAL), allocatable, dimension(:,:,:,:,:) :: tensorField_real_
real(pReal), allocatable, dimension(:,:,:,:) :: vectorField_real_ real(pREAL), allocatable, dimension(:,:,:,:) :: vectorField_real_
real(pReal), allocatable, dimension(:,:,:) :: scalarField_real_ real(pREAL), allocatable, dimension(:,:,:) :: scalarField_real_
real(pReal), dimension(3,3) :: tensorSum real(pREAL), dimension(3,3) :: tensorSum
real(pReal), dimension(3) :: vectorSum real(pREAL), dimension(3) :: vectorSum
real(pReal) :: scalarSum real(pREAL) :: scalarSum
real(pReal), dimension(3,3) :: r real(pREAL), dimension(3,3) :: r
integer(MPI_INTEGER_KIND) :: err_MPI integer(MPI_INTEGER_KIND) :: err_MPI
call random_number(tensorField_real) call random_number(tensorField_real)
tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pReal tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pREAL
tensorField_real_ = tensorField_real tensorField_real_ = tensorField_real
call fftw_mpi_execute_dft_r2c(planTensorForth,tensorField_real,tensorField_fourier) call fftw_mpi_execute_dft_r2c(planTensorForth,tensorField_real,tensorField_fourier)
call MPI_Allreduce(sum(sum(sum(tensorField_real_,dim=5),dim=4),dim=3),tensorSum,9_MPI_INTEGER_KIND, & call MPI_Allreduce(sum(sum(sum(tensorField_real_,dim=5),dim=4),dim=3),tensorSum,9_MPI_INTEGER_KIND, &
MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI) MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI)
if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
if (worldrank==0) then if (worldrank==0) then
if (any(dNeq(tensorSum/tensorField_fourier(:,:,1,1,1)%re,1.0_pReal,1.0e-12_pReal))) & if (any(dNeq(tensorSum/tensorField_fourier(:,:,1,1,1)%re,1.0_pREAL,1.0e-12_pREAL))) &
error stop 'mismatch avg tensorField FFT <-> real' error stop 'mismatch avg tensorField FFT <-> real'
end if end if
call fftw_mpi_execute_dft_c2r(planTensorBack,tensorField_fourier,tensorField_real) call fftw_mpi_execute_dft_c2r(planTensorBack,tensorField_fourier,tensorField_real)
tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pReal tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pREAL
if (maxval(abs(tensorField_real_ - tensorField_real*wgt))>5.0e-15_pReal) & if (maxval(abs(tensorField_real_ - tensorField_real*wgt))>5.0e-15_pREAL) &
error stop 'mismatch tensorField FFT/invFFT <-> real' error stop 'mismatch tensorField FFT/invFFT <-> real'
call random_number(vectorField_real) call random_number(vectorField_real)
vectorField_real(1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pReal vectorField_real(1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pREAL
vectorField_real_ = vectorField_real vectorField_real_ = vectorField_real
call fftw_mpi_execute_dft_r2c(planVectorForth,vectorField_real,vectorField_fourier) call fftw_mpi_execute_dft_r2c(planVectorForth,vectorField_real,vectorField_fourier)
call MPI_Allreduce(sum(sum(sum(vectorField_real_,dim=4),dim=3),dim=2),vectorSum,3_MPI_INTEGER_KIND, & call MPI_Allreduce(sum(sum(sum(vectorField_real_,dim=4),dim=3),dim=2),vectorSum,3_MPI_INTEGER_KIND, &
MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI) MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI)
if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
if (worldrank==0) then if (worldrank==0) then
if (any(dNeq(vectorSum/vectorField_fourier(:,1,1,1)%re,1.0_pReal,1.0e-12_pReal))) & if (any(dNeq(vectorSum/vectorField_fourier(:,1,1,1)%re,1.0_pREAL,1.0e-12_pREAL))) &
error stop 'mismatch avg vectorField FFT <-> real' error stop 'mismatch avg vectorField FFT <-> real'
end if end if
call fftw_mpi_execute_dft_c2r(planVectorBack,vectorField_fourier,vectorField_real) call fftw_mpi_execute_dft_c2r(planVectorBack,vectorField_fourier,vectorField_real)
vectorField_real(1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pReal vectorField_real(1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pREAL
if (maxval(abs(vectorField_real_ - vectorField_real*wgt))>5.0e-15_pReal) & if (maxval(abs(vectorField_real_ - vectorField_real*wgt))>5.0e-15_pREAL) &
error stop 'mismatch vectorField FFT/invFFT <-> real' error stop 'mismatch vectorField FFT/invFFT <-> real'
call random_number(scalarField_real) call random_number(scalarField_real)
scalarField_real(cells(1)+1:cells1Red*2,:,:) = 0.0_pReal scalarField_real(cells(1)+1:cells1Red*2,:,:) = 0.0_pREAL
scalarField_real_ = scalarField_real scalarField_real_ = scalarField_real
call fftw_mpi_execute_dft_r2c(planScalarForth,scalarField_real,scalarField_fourier) call fftw_mpi_execute_dft_r2c(planScalarForth,scalarField_real,scalarField_fourier)
call MPI_Allreduce(sum(sum(sum(scalarField_real_,dim=3),dim=2),dim=1),scalarSum,1_MPI_INTEGER_KIND, & call MPI_Allreduce(sum(sum(sum(scalarField_real_,dim=3),dim=2),dim=1),scalarSum,1_MPI_INTEGER_KIND, &
MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI) MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI)
if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
if (worldrank==0) then if (worldrank==0) then
if (dNeq(scalarSum/scalarField_fourier(1,1,1)%re,1.0_pReal,1.0e-12_pReal)) & if (dNeq(scalarSum/scalarField_fourier(1,1,1)%re,1.0_pREAL,1.0e-12_pREAL)) &
error stop 'mismatch avg scalarField FFT <-> real' error stop 'mismatch avg scalarField FFT <-> real'
end if end if
call fftw_mpi_execute_dft_c2r(planScalarBack,scalarField_fourier,scalarField_real) call fftw_mpi_execute_dft_c2r(planScalarBack,scalarField_fourier,scalarField_real)
scalarField_real(cells(1)+1:cells1Red*2,:,:) = 0.0_pReal scalarField_real(cells(1)+1:cells1Red*2,:,:) = 0.0_pREAL
if (maxval(abs(scalarField_real_ - scalarField_real*wgt))>5.0e-15_pReal) & if (maxval(abs(scalarField_real_ - scalarField_real*wgt))>5.0e-15_pREAL) &
error stop 'mismatch scalarField FFT/invFFT <-> real' error stop 'mismatch scalarField FFT/invFFT <-> real'
call random_number(r) call random_number(r)
@ -1112,54 +1112,54 @@ subroutine selfTest()
if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
scalarField_real_ = r(1,1) scalarField_real_ = r(1,1)
if (maxval(abs(utilities_scalarGradient(scalarField_real_)))>5.0e-9_pReal) error stop 'non-zero grad(const)' if (maxval(abs(utilities_scalarGradient(scalarField_real_)))>5.0e-9_pREAL) error stop 'non-zero grad(const)'
vectorField_real_ = spread(spread(spread(r(1,:),2,cells(1)),3,cells(2)),4,cells3) vectorField_real_ = spread(spread(spread(r(1,:),2,cells(1)),3,cells(2)),4,cells3)
if (maxval(abs(utilities_vectorDivergence(vectorField_real_)))>5.0e-9_pReal) error stop 'non-zero div(const)' if (maxval(abs(utilities_vectorDivergence(vectorField_real_)))>5.0e-9_pREAL) error stop 'non-zero div(const)'
tensorField_real_ = spread(spread(spread(r,3,cells(1)),4,cells(2)),5,cells3) tensorField_real_ = spread(spread(spread(r,3,cells(1)),4,cells(2)),5,cells3)
if (utilities_divergenceRMS(tensorField_real_)>5.0e-14_pReal) error stop 'non-zero RMS div(const)' if (utilities_divergenceRMS(tensorField_real_)>5.0e-14_pREAL) error stop 'non-zero RMS div(const)'
if (utilities_curlRMS(tensorField_real_)>5.0e-14_pReal) error stop 'non-zero RMS curl(const)' if (utilities_curlRMS(tensorField_real_)>5.0e-14_pREAL) error stop 'non-zero RMS curl(const)'
if (cells(1) > 2 .and. spectral_derivative_ID == DERIVATIVE_CONTINUOUS_ID) then if (cells(1) > 2 .and. spectral_derivative_ID == DERIVATIVE_CONTINUOUS_ID) then
scalarField_real_ = spread(spread(planeCosine(cells(1)),2,cells(2)),3,cells3) scalarField_real_ = spread(spread(planeCosine(cells(1)),2,cells(2)),3,cells3)
vectorField_real_ = utilities_scalarGradient(scalarField_real_)/TAU*geomSize(1) vectorField_real_ = utilities_scalarGradient(scalarField_real_)/TAU*geomSize(1)
scalarField_real_ = -spread(spread(planeSine (cells(1)),2,cells(2)),3,cells3) scalarField_real_ = -spread(spread(planeSine (cells(1)),2,cells(2)),3,cells3)
if (maxval(abs(vectorField_real_(1,:,:,:) - scalarField_real_))>5.0e-12_pReal) error stop 'grad cosine' if (maxval(abs(vectorField_real_(1,:,:,:) - scalarField_real_))>5.0e-12_pREAL) error stop 'grad cosine'
scalarField_real_ = spread(spread(planeSine (cells(1)),2,cells(2)),3,cells3) scalarField_real_ = spread(spread(planeSine (cells(1)),2,cells(2)),3,cells3)
vectorField_real_ = utilities_scalarGradient(scalarField_real_)/TAU*geomSize(1) vectorField_real_ = utilities_scalarGradient(scalarField_real_)/TAU*geomSize(1)
scalarField_real_ = spread(spread(planeCosine(cells(1)),2,cells(2)),3,cells3) scalarField_real_ = spread(spread(planeCosine(cells(1)),2,cells(2)),3,cells3)
if (maxval(abs(vectorField_real_(1,:,:,:) - scalarField_real_))>5.0e-12_pReal) error stop 'grad sine' if (maxval(abs(vectorField_real_(1,:,:,:) - scalarField_real_))>5.0e-12_pREAL) error stop 'grad sine'
vectorField_real_(2:3,:,:,:) = 0.0_pReal vectorField_real_(2:3,:,:,:) = 0.0_pREAL
vectorField_real_(1,:,:,:) = spread(spread(planeCosine(cells(1)),2,cells(2)),3,cells3) vectorField_real_(1,:,:,:) = spread(spread(planeCosine(cells(1)),2,cells(2)),3,cells3)
scalarField_real_ = utilities_vectorDivergence(vectorField_real_)/TAU*geomSize(1) scalarField_real_ = utilities_vectorDivergence(vectorField_real_)/TAU*geomSize(1)
vectorField_real_(1,:,:,:) =-spread(spread(planeSine( cells(1)),2,cells(2)),3,cells3) vectorField_real_(1,:,:,:) =-spread(spread(planeSine( cells(1)),2,cells(2)),3,cells3)
if (maxval(abs(vectorField_real_(1,:,:,:) - scalarField_real_))>5.0e-12_pReal) error stop 'div cosine' if (maxval(abs(vectorField_real_(1,:,:,:) - scalarField_real_))>5.0e-12_pREAL) error stop 'div cosine'
vectorField_real_(2:3,:,:,:) = 0.0_pReal vectorField_real_(2:3,:,:,:) = 0.0_pREAL
vectorField_real_(1,:,:,:) = spread(spread(planeSine( cells(1)),2,cells(2)),3,cells3) vectorField_real_(1,:,:,:) = spread(spread(planeSine( cells(1)),2,cells(2)),3,cells3)
scalarField_real_ = utilities_vectorDivergence(vectorField_real_)/TAU*geomSize(1) scalarField_real_ = utilities_vectorDivergence(vectorField_real_)/TAU*geomSize(1)
vectorField_real_(1,:,:,:) = spread(spread(planeCosine(cells(1)),2,cells(2)),3,cells3) vectorField_real_(1,:,:,:) = spread(spread(planeCosine(cells(1)),2,cells(2)),3,cells3)
if (maxval(abs(vectorField_real_(1,:,:,:) - scalarField_real_))>5.0e-12_pReal) error stop 'div sine' if (maxval(abs(vectorField_real_(1,:,:,:) - scalarField_real_))>5.0e-12_pREAL) error stop 'div sine'
end if end if
contains contains
function planeCosine(n) function planeCosine(n)
integer, intent(in) :: n integer, intent(in) :: n
real(pReal), dimension(n) :: planeCosine real(pREAL), dimension(n) :: planeCosine
planeCosine = cos(real(math_range(n),pReal)/real(n,pReal)*TAU-TAU/real(n*2,pReal)) planeCosine = cos(real(math_range(n),pREAL)/real(n,pREAL)*TAU-TAU/real(n*2,pREAL))
end function planeCosine end function planeCosine
function planeSine(n) function planeSine(n)
integer, intent(in) :: n integer, intent(in) :: n
real(pReal), dimension(n) :: planeSine real(pREAL), dimension(n) :: planeSine
planeSine = sin(real(math_range(n),pReal)/real(n,pReal)*TAU-TAU/real(n*2,pReal)) planeSine = sin(real(math_range(n),pREAL)/real(n,pREAL)*TAU-TAU/real(n*2,pREAL))
end function planeSine end function planeSine

40
src/homogenization.f90
View File

@ -25,7 +25,7 @@ module homogenization
integer :: & integer :: &
sizeState = 0 !< size of state sizeState = 0 !< size of state
! http://stackoverflow.com/questions/3948210 ! http://stackoverflow.com/questions/3948210
real(pReal), pointer, dimension(:,:), contiguous :: & !< is basically an allocatable+target, but in a type needs to be pointer real(pREAL), pointer, dimension(:,:), contiguous :: & !< is basically an allocatable+target, but in a type needs to be pointer
state0, & state0, &
state state
end type end type
@ -51,12 +51,12 @@ module homogenization
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! General variables for the homogenization at a material point ! General variables for the homogenization at a material point
real(pReal), dimension(:,:,:), allocatable, public :: & real(pREAL), dimension(:,:,:), allocatable, public :: &
homogenization_F0, & !< def grad of IP at start of FE increment homogenization_F0, & !< def grad of IP at start of FE increment
homogenization_F !< def grad of IP to be reached at end of FE increment homogenization_F !< def grad of IP to be reached at end of FE increment
real(pReal), dimension(:,:,:), allocatable, public :: & !, protected :: & Issue with ifort real(pREAL), dimension(:,:,:), allocatable, public :: & !, protected :: & Issue with ifort
homogenization_P !< first P--K stress of IP homogenization_P !< first P--K stress of IP
real(pReal), dimension(:,:,:,:,:), allocatable, public :: & !, protected :: & real(pREAL), dimension(:,:,:,:,:), allocatable, public :: & !, protected :: &
homogenization_dPdF !< tangent of first P--K stress at IP homogenization_dPdF !< tangent of first P--K stress at IP
@ -81,7 +81,7 @@ module homogenization
end subroutine damage_init end subroutine damage_init
module subroutine mechanical_partition(subF,ce) module subroutine mechanical_partition(subF,ce)
real(pReal), intent(in), dimension(3,3) :: & real(pREAL), intent(in), dimension(3,3) :: &
subF subF
integer, intent(in) :: & integer, intent(in) :: &
ce ce
@ -96,7 +96,7 @@ module homogenization
end subroutine damage_partition end subroutine damage_partition
module subroutine mechanical_homogenize(Delta_t,ce) module subroutine mechanical_homogenize(Delta_t,ce)
real(pReal), intent(in) :: Delta_t real(pREAL), intent(in) :: Delta_t
integer, intent(in) :: & integer, intent(in) :: &
ce !< cell ce !< cell
end subroutine mechanical_homogenize end subroutine mechanical_homogenize
@ -117,9 +117,9 @@ module homogenization
end subroutine thermal_result end subroutine thermal_result
module function mechanical_updateState(subdt,subF,ce) result(doneAndHappy) module function mechanical_updateState(subdt,subF,ce) result(doneAndHappy)
real(pReal), intent(in) :: & real(pREAL), intent(in) :: &
subdt !< current time step subdt !< current time step
real(pReal), intent(in), dimension(3,3) :: & real(pREAL), intent(in), dimension(3,3) :: &
subF subF
integer, intent(in) :: & integer, intent(in) :: &
ce !< cell ce !< cell
@ -132,22 +132,22 @@ module homogenization
module function homogenization_mu_T(ce) result(mu) module function homogenization_mu_T(ce) result(mu)
integer, intent(in) :: ce integer, intent(in) :: ce
real(pReal) :: mu real(pREAL) :: mu
end function homogenization_mu_T end function homogenization_mu_T
module function homogenization_K_T(ce) result(K) module function homogenization_K_T(ce) result(K)
integer, intent(in) :: ce integer, intent(in) :: ce
real(pReal), dimension(3,3) :: K real(pREAL), dimension(3,3) :: K
end function homogenization_K_T end function homogenization_K_T
module function homogenization_f_T(ce) result(f) module function homogenization_f_T(ce) result(f)
integer, intent(in) :: ce integer, intent(in) :: ce
real(pReal) :: f real(pREAL) :: f
end function homogenization_f_T end function homogenization_f_T
module subroutine homogenization_thermal_setField(T,dot_T, ce) module subroutine homogenization_thermal_setField(T,dot_T, ce)
integer, intent(in) :: ce integer, intent(in) :: ce
real(pReal), intent(in) :: T, dot_T real(pREAL), intent(in) :: T, dot_T
end subroutine homogenization_thermal_setField end subroutine homogenization_thermal_setField
module function homogenization_damage_active() result(active) module function homogenization_damage_active() result(active)
@ -156,23 +156,23 @@ module homogenization
module function homogenization_mu_phi(ce) result(mu) module function homogenization_mu_phi(ce) result(mu)
integer, intent(in) :: ce integer, intent(in) :: ce
real(pReal) :: mu real(pREAL) :: mu
end function homogenization_mu_phi end function homogenization_mu_phi
module function homogenization_K_phi(ce) result(K) module function homogenization_K_phi(ce) result(K)
integer, intent(in) :: ce integer, intent(in) :: ce
real(pReal), dimension(3,3) :: K real(pREAL), dimension(3,3) :: K
end function homogenization_K_phi end function homogenization_K_phi
module function homogenization_f_phi(phi,ce) result(f) module function homogenization_f_phi(phi,ce) result(f)
integer, intent(in) :: ce integer, intent(in) :: ce
real(pReal), intent(in) :: phi real(pREAL), intent(in) :: phi
real(pReal) :: f real(pREAL) :: f
end function homogenization_f_phi end function homogenization_f_phi
module subroutine homogenization_set_phi(phi,ce) module subroutine homogenization_set_phi(phi,ce)
integer, intent(in) :: ce integer, intent(in) :: ce
real(pReal), intent(in) :: & real(pREAL), intent(in) :: &
phi phi
end subroutine homogenization_set_phi end subroutine homogenization_set_phi
@ -235,7 +235,7 @@ end subroutine homogenization_init
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine homogenization_mechanical_response(Delta_t,cell_start,cell_end) subroutine homogenization_mechanical_response(Delta_t,cell_start,cell_end)
real(pReal), intent(in) :: Delta_t !< time increment real(pREAL), intent(in) :: Delta_t !< time increment
integer, intent(in) :: & integer, intent(in) :: &
cell_start, cell_end cell_start, cell_end
integer :: & integer :: &
@ -293,7 +293,7 @@ end subroutine homogenization_mechanical_response
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine homogenization_thermal_response(Delta_t,cell_start,cell_end) subroutine homogenization_thermal_response(Delta_t,cell_start,cell_end)
real(pReal), intent(in) :: Delta_t !< time increment real(pREAL), intent(in) :: Delta_t !< time increment
integer, intent(in) :: & integer, intent(in) :: &
cell_start, cell_end cell_start, cell_end
integer :: & integer :: &
@ -321,7 +321,7 @@ end subroutine homogenization_thermal_response
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine homogenization_mechanical_response2(Delta_t,FEsolving_execIP,FEsolving_execElem) subroutine homogenization_mechanical_response2(Delta_t,FEsolving_execIP,FEsolving_execElem)
real(pReal), intent(in) :: Delta_t !< time increment real(pREAL), intent(in) :: Delta_t !< time increment
integer, dimension(2), intent(in) :: FEsolving_execElem, FEsolving_execIP integer, dimension(2), intent(in) :: FEsolving_execElem, FEsolving_execIP
integer :: & integer :: &
ip, & !< integration point number ip, & !< integration point number

20
src/homogenization_damage.f90
View File

@ -11,7 +11,7 @@ submodule(homogenization) damage
end interface end interface
type :: tDataContainer type :: tDataContainer
real(pReal), dimension(:), allocatable :: phi real(pREAL), dimension(:), allocatable :: phi
end type tDataContainer end type tDataContainer
type(tDataContainer), dimension(:), allocatable :: current type(tDataContainer), dimension(:), allocatable :: current
@ -48,7 +48,7 @@ module subroutine damage_init()
do ho = 1, configHomogenizations%length do ho = 1, configHomogenizations%length
Nmembers = count(material_ID_homogenization == ho) Nmembers = count(material_ID_homogenization == ho)
allocate(current(ho)%phi(Nmembers), source=1.0_pReal) allocate(current(ho)%phi(Nmembers), source=1.0_pREAL)
configHomogenization => configHomogenizations%get_dict(ho) configHomogenization => configHomogenizations%get_dict(ho)
associate(prm => param(ho)) associate(prm => param(ho))
if (configHomogenization%contains('damage')) then if (configHomogenization%contains('damage')) then
@ -59,8 +59,8 @@ module subroutine damage_init()
prm%output = configHomogenizationDamage%get_as1dStr('output',defaultVal=emptyStrArray) prm%output = configHomogenizationDamage%get_as1dStr('output',defaultVal=emptyStrArray)
#endif #endif
damageState_h(ho)%sizeState = 1 damageState_h(ho)%sizeState = 1
allocate(damageState_h(ho)%state0(1,Nmembers), source=1.0_pReal) allocate(damageState_h(ho)%state0(1,Nmembers), source=1.0_pREAL)
allocate(damageState_h(ho)%state (1,Nmembers), source=1.0_pReal) allocate(damageState_h(ho)%state (1,Nmembers), source=1.0_pREAL)
else else
prm%output = emptyStrArray prm%output = emptyStrArray
end if end if
@ -91,7 +91,7 @@ module subroutine damage_partition(ce)
integer, intent(in) :: ce integer, intent(in) :: ce
real(pReal) :: phi real(pREAL) :: phi
integer :: co integer :: co
@ -111,7 +111,7 @@ end subroutine damage_partition
module function homogenization_mu_phi(ce) result(mu) module function homogenization_mu_phi(ce) result(mu)
integer, intent(in) :: ce integer, intent(in) :: ce
real(pReal) :: mu real(pREAL) :: mu
mu = phase_mu_phi(1,ce) mu = phase_mu_phi(1,ce)
@ -125,7 +125,7 @@ end function homogenization_mu_phi
module function homogenization_K_phi(ce) result(K) module function homogenization_K_phi(ce) result(K)
integer, intent(in) :: ce integer, intent(in) :: ce
real(pReal), dimension(3,3) :: K real(pREAL), dimension(3,3) :: K
K = phase_K_phi(1,ce) K = phase_K_phi(1,ce)
@ -139,8 +139,8 @@ end function homogenization_K_phi
module function homogenization_f_phi(phi,ce) result(f) module function homogenization_f_phi(phi,ce) result(f)
integer, intent(in) :: ce integer, intent(in) :: ce
real(pReal), intent(in) :: phi real(pREAL), intent(in) :: phi
real(pReal) :: f real(pREAL) :: f
f = phase_f_phi(phi, 1, ce) f = phase_f_phi(phi, 1, ce)
@ -154,7 +154,7 @@ end function homogenization_f_phi
module subroutine homogenization_set_phi(phi,ce) module subroutine homogenization_set_phi(phi,ce)
integer, intent(in) :: ce integer, intent(in) :: ce
real(pReal), intent(in) :: phi real(pREAL), intent(in) :: phi
integer :: & integer :: &
ho, & ho, &

36
src/homogenization_mechanical.f90
View File

@ -18,13 +18,13 @@ submodule(homogenization) mechanical
module subroutine isostrain_partitionDeformation(F,avgF) module subroutine isostrain_partitionDeformation(F,avgF)
real(pReal), dimension (:,:,:), intent(out) :: F !< partitioned deformation gradient real(pREAL), dimension (:,:,:), intent(out) :: F !< partitioned deformation gradient
real(pReal), dimension (3,3), intent(in) :: avgF !< average deformation gradient at material point real(pREAL), dimension (3,3), intent(in) :: avgF !< average deformation gradient at material point
end subroutine isostrain_partitionDeformation end subroutine isostrain_partitionDeformation
module subroutine RGC_partitionDeformation(F,avgF,ce) module subroutine RGC_partitionDeformation(F,avgF,ce)
real(pReal), dimension (:,:,:), intent(out) :: F !< partitioned deformation gradient real(pREAL), dimension (:,:,:), intent(out) :: F !< partitioned deformation gradient
real(pReal), dimension (3,3), intent(in) :: avgF !< average deformation gradient at material point real(pREAL), dimension (3,3), intent(in) :: avgF !< average deformation gradient at material point
integer, intent(in) :: & integer, intent(in) :: &
ce ce
end subroutine RGC_partitionDeformation end subroutine RGC_partitionDeformation
@ -32,12 +32,12 @@ submodule(homogenization) mechanical
module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy) module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy)
logical, dimension(2) :: doneAndHappy logical, dimension(2) :: doneAndHappy
real(pReal), dimension(:,:,:), intent(in) :: & real(pREAL), dimension(:,:,:), intent(in) :: &
P,& !< partitioned stresses P,& !< partitioned stresses
F !< partitioned deformation gradients F !< partitioned deformation gradients
real(pReal), dimension(:,:,:,:,:), intent(in) :: dPdF !< partitioned stiffnesses real(pREAL), dimension(:,:,:,:,:), intent(in) :: dPdF !< partitioned stiffnesses
real(pReal), dimension(3,3), intent(in) :: avgF !< average F real(pREAL), dimension(3,3), intent(in) :: avgF !< average F
real(pReal), intent(in) :: dt !< time increment real(pREAL), intent(in) :: dt !< time increment
integer, intent(in) :: & integer, intent(in) :: &
ce !< cell ce !< cell
end function RGC_updateState end function RGC_updateState
@ -76,10 +76,10 @@ module subroutine mechanical_init()
call parseMechanical() call parseMechanical()
allocate(homogenization_dPdF(3,3,3,3,discretization_Ncells), source=0.0_pReal) allocate(homogenization_dPdF(3,3,3,3,discretization_Ncells), source=0.0_pREAL)
homogenization_F0 = spread(math_I3,3,discretization_Ncells) homogenization_F0 = spread(math_I3,3,discretization_Ncells)
homogenization_F = homogenization_F0 homogenization_F = homogenization_F0
allocate(homogenization_P(3,3,discretization_Ncells),source=0.0_pReal) allocate(homogenization_P(3,3,discretization_Ncells),source=0.0_pREAL)
if (any(mechanical_type == MECHANICAL_PASS_ID)) call pass_init() if (any(mechanical_type == MECHANICAL_PASS_ID)) call pass_init()
if (any(mechanical_type == MECHANICAL_ISOSTRAIN_ID)) call isostrain_init() if (any(mechanical_type == MECHANICAL_ISOSTRAIN_ID)) call isostrain_init()
@ -93,13 +93,13 @@ end subroutine mechanical_init
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
module subroutine mechanical_partition(subF,ce) module subroutine mechanical_partition(subF,ce)
real(pReal), intent(in), dimension(3,3) :: & real(pREAL), intent(in), dimension(3,3) :: &
subF subF
integer, intent(in) :: & integer, intent(in) :: &
ce ce
integer :: co integer :: co
real(pReal), dimension (3,3,homogenization_Nconstituents(material_ID_homogenization(ce))) :: Fs real(pREAL), dimension (3,3,homogenization_Nconstituents(material_ID_homogenization(ce))) :: Fs
chosenHomogenization: select case(mechanical_type(material_ID_homogenization(ce))) chosenHomogenization: select case(mechanical_type(material_ID_homogenization(ce)))
@ -128,7 +128,7 @@ end subroutine mechanical_partition
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
module subroutine mechanical_homogenize(Delta_t,ce) module subroutine mechanical_homogenize(Delta_t,ce)
real(pReal), intent(in) :: Delta_t real(pREAL), intent(in) :: Delta_t
integer, intent(in) :: ce integer, intent(in) :: ce
integer :: co integer :: co
@ -152,18 +152,18 @@ end subroutine mechanical_homogenize
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
module function mechanical_updateState(subdt,subF,ce) result(doneAndHappy) module function mechanical_updateState(subdt,subF,ce) result(doneAndHappy)
real(pReal), intent(in) :: & real(pREAL), intent(in) :: &
subdt !< current time step subdt !< current time step
real(pReal), intent(in), dimension(3,3) :: & real(pREAL), intent(in), dimension(3,3) :: &
subF subF
integer, intent(in) :: & integer, intent(in) :: &
ce ce
logical, dimension(2) :: doneAndHappy logical, dimension(2) :: doneAndHappy
integer :: co integer :: co
real(pReal) :: dPdFs(3,3,3,3,homogenization_Nconstituents(material_ID_homogenization(ce))) real(pREAL) :: dPdFs(3,3,3,3,homogenization_Nconstituents(material_ID_homogenization(ce)))
real(pReal) :: Fs(3,3,homogenization_Nconstituents(material_ID_homogenization(ce))) real(pREAL) :: Fs(3,3,homogenization_Nconstituents(material_ID_homogenization(ce)))
real(pReal) :: Ps(3,3,homogenization_Nconstituents(material_ID_homogenization(ce))) real(pREAL) :: Ps(3,3,homogenization_Nconstituents(material_ID_homogenization(ce)))
if (mechanical_type(material_ID_homogenization(ce)) == MECHANICAL_RGC_ID) then if (mechanical_type(material_ID_homogenization(ce)) == MECHANICAL_RGC_ID) then

234
src/homogenization_mechanical_RGC.f90
View File

@ -13,10 +13,10 @@ submodule(homogenization:mechanical) RGC
type :: tParameters type :: tParameters
integer, dimension(:), allocatable :: & integer, dimension(:), allocatable :: &
N_constituents N_constituents
real(pReal) :: & real(pREAL) :: &
xi_alpha, & xi_alpha, &
c_Alpha c_Alpha
real(pReal), dimension(:), allocatable :: & real(pREAL), dimension(:), allocatable :: &
D_alpha, & D_alpha, &
a_g a_g
character(len=pSTRLEN), allocatable, dimension(:) :: & character(len=pSTRLEN), allocatable, dimension(:) :: &
@ -24,23 +24,23 @@ submodule(homogenization:mechanical) RGC
end type tParameters end type tParameters
type :: tRGCstate type :: tRGCstate
real(pReal), pointer, dimension(:,:) :: & real(pREAL), pointer, dimension(:,:) :: &
relaxationVector relaxationVector
end type tRGCstate end type tRGCstate
type :: tRGCdependentState type :: tRGCdependentState
real(pReal), allocatable, dimension(:) :: & real(pREAL), allocatable, dimension(:) :: &
volumeDiscrepancy, & volumeDiscrepancy, &
relaxationRate_avg, & relaxationRate_avg, &
relaxationRate_max relaxationRate_max
real(pReal), allocatable, dimension(:,:) :: & real(pREAL), allocatable, dimension(:,:) :: &
mismatch mismatch
real(pReal), allocatable, dimension(:,:,:) :: & real(pREAL), allocatable, dimension(:,:,:) :: &
orientation orientation
end type tRGCdependentState end type tRGCdependentState
type :: tNumerics_RGC type :: tNumerics_RGC
real(pReal) :: & real(pREAL) :: &
atol, & !< absolute tolerance of RGC residuum atol, & !< absolute tolerance of RGC residuum
rtol, & !< relative tolerance of RGC residuum rtol, & !< relative tolerance of RGC residuum
absMax, & !< absolute maximum of RGC residuum absMax, & !< absolute maximum of RGC residuum
@ -108,33 +108,33 @@ module subroutine RGC_init()
num_mechanical => num_homogenization%get_dict('mechanical',defaultVal=emptyDict) num_mechanical => num_homogenization%get_dict('mechanical',defaultVal=emptyDict)
num_RGC => num_mechanical%get_dict('RGC',defaultVal=emptyDict) num_RGC => num_mechanical%get_dict('RGC',defaultVal=emptyDict)
num%atol = num_RGC%get_asReal('atol', defaultVal=1.0e+4_pReal) num%atol = num_RGC%get_asReal('atol', defaultVal=1.0e+4_pREAL)
num%rtol = num_RGC%get_asReal('rtol', defaultVal=1.0e-3_pReal) num%rtol = num_RGC%get_asReal('rtol', defaultVal=1.0e-3_pREAL)
num%absMax = num_RGC%get_asReal('amax', defaultVal=1.0e+10_pReal) num%absMax = num_RGC%get_asReal('amax', defaultVal=1.0e+10_pREAL)
num%relMax = num_RGC%get_asReal('rmax', defaultVal=1.0e+2_pReal) num%relMax = num_RGC%get_asReal('rmax', defaultVal=1.0e+2_pREAL)
num%pPert = num_RGC%get_asReal('perturbpenalty', defaultVal=1.0e-7_pReal) num%pPert = num_RGC%get_asReal('perturbpenalty', defaultVal=1.0e-7_pREAL)
num%xSmoo = num_RGC%get_asReal('relvantmismatch', defaultVal=1.0e-5_pReal) num%xSmoo = num_RGC%get_asReal('relvantmismatch', defaultVal=1.0e-5_pREAL)
num%viscPower = num_RGC%get_asReal('viscositypower', defaultVal=1.0e+0_pReal) num%viscPower = num_RGC%get_asReal('viscositypower', defaultVal=1.0e+0_pREAL)
num%viscModus = num_RGC%get_asReal('viscositymodulus', defaultVal=0.0e+0_pReal) num%viscModus = num_RGC%get_asReal('viscositymodulus', defaultVal=0.0e+0_pREAL)
num%refRelaxRate = num_RGC%get_asReal('refrelaxationrate', defaultVal=1.0e-3_pReal) num%refRelaxRate = num_RGC%get_asReal('refrelaxationrate', defaultVal=1.0e-3_pREAL)
num%maxdRelax = num_RGC%get_asReal('maxrelaxationrate', defaultVal=1.0e+0_pReal) num%maxdRelax = num_RGC%get_asReal('maxrelaxationrate', defaultVal=1.0e+0_pREAL)
num%maxVolDiscr = num_RGC%get_asReal('maxvoldiscrepancy', defaultVal=1.0e-5_pReal) num%maxVolDiscr = num_RGC%get_asReal('maxvoldiscrepancy', defaultVal=1.0e-5_pREAL)
num%volDiscrMod = num_RGC%get_asReal('voldiscrepancymod', defaultVal=1.0e+12_pReal) num%volDiscrMod = num_RGC%get_asReal('voldiscrepancymod', defaultVal=1.0e+12_pREAL)
num%volDiscrPow = num_RGC%get_asReal('dicrepancypower', defaultVal=5.0_pReal) num%volDiscrPow = num_RGC%get_asReal('dicrepancypower', defaultVal=5.0_pREAL)
if (num%atol <= 0.0_pReal) call IO_error(301,ext_msg='absTol_RGC') if (num%atol <= 0.0_pREAL) call IO_error(301,ext_msg='absTol_RGC')
if (num%rtol <= 0.0_pReal) call IO_error(301,ext_msg='relTol_RGC') if (num%rtol <= 0.0_pREAL) call IO_error(301,ext_msg='relTol_RGC')
if (num%absMax <= 0.0_pReal) call IO_error(301,ext_msg='absMax_RGC') if (num%absMax <= 0.0_pREAL) call IO_error(301,ext_msg='absMax_RGC')
if (num%relMax <= 0.0_pReal) call IO_error(301,ext_msg='relMax_RGC') if (num%relMax <= 0.0_pREAL) call IO_error(301,ext_msg='relMax_RGC')
if (num%pPert <= 0.0_pReal) call IO_error(301,ext_msg='pPert_RGC') if (num%pPert <= 0.0_pREAL) call IO_error(301,ext_msg='pPert_RGC')
if (num%xSmoo <= 0.0_pReal) call IO_error(301,ext_msg='xSmoo_RGC') if (num%xSmoo <= 0.0_pREAL) call IO_error(301,ext_msg='xSmoo_RGC')
if (num%viscPower < 0.0_pReal) call IO_error(301,ext_msg='viscPower_RGC') if (num%viscPower < 0.0_pREAL) call IO_error(301,ext_msg='viscPower_RGC')
if (num%viscModus < 0.0_pReal) call IO_error(301,ext_msg='viscModus_RGC') if (num%viscModus < 0.0_pREAL) call IO_error(301,ext_msg='viscModus_RGC')
if (num%refRelaxRate <= 0.0_pReal) call IO_error(301,ext_msg='refRelaxRate_RGC') if (num%refRelaxRate <= 0.0_pREAL) call IO_error(301,ext_msg='refRelaxRate_RGC')
if (num%maxdRelax <= 0.0_pReal) call IO_error(301,ext_msg='maxdRelax_RGC') if (num%maxdRelax <= 0.0_pREAL) call IO_error(301,ext_msg='maxdRelax_RGC')
if (num%maxVolDiscr <= 0.0_pReal) call IO_error(301,ext_msg='maxVolDiscr_RGC') if (num%maxVolDiscr <= 0.0_pREAL) call IO_error(301,ext_msg='maxVolDiscr_RGC')
if (num%volDiscrMod < 0.0_pReal) call IO_error(301,ext_msg='volDiscrMod_RGC') if (num%volDiscrMod < 0.0_pREAL) call IO_error(301,ext_msg='volDiscrMod_RGC')
if (num%volDiscrPow <= 0.0_pReal) call IO_error(301,ext_msg='volDiscrPw_RGC') if (num%volDiscrPow <= 0.0_pREAL) call IO_error(301,ext_msg='volDiscrPw_RGC')
do ho = 1, size(mechanical_type) do ho = 1, size(mechanical_type)
@ -169,16 +169,16 @@ module subroutine RGC_init()
sizeState = nIntFaceTot sizeState = nIntFaceTot
homogState(ho)%sizeState = sizeState homogState(ho)%sizeState = sizeState
allocate(homogState(ho)%state0 (sizeState,Nmembers), source=0.0_pReal) allocate(homogState(ho)%state0 (sizeState,Nmembers), source=0.0_pREAL)
allocate(homogState(ho)%state (sizeState,Nmembers), source=0.0_pReal) allocate(homogState(ho)%state (sizeState,Nmembers), source=0.0_pREAL)
stt%relaxationVector => homogState(ho)%state(1:nIntFaceTot,:) stt%relaxationVector => homogState(ho)%state(1:nIntFaceTot,:)
st0%relaxationVector => homogState(ho)%state0(1:nIntFaceTot,:) st0%relaxationVector => homogState(ho)%state0(1:nIntFaceTot,:)
allocate(dst%volumeDiscrepancy( Nmembers), source=0.0_pReal) allocate(dst%volumeDiscrepancy( Nmembers), source=0.0_pREAL)
allocate(dst%relaxationRate_avg( Nmembers), source=0.0_pReal) allocate(dst%relaxationRate_avg( Nmembers), source=0.0_pREAL)
allocate(dst%relaxationRate_max( Nmembers), source=0.0_pReal) allocate(dst%relaxationRate_max( Nmembers), source=0.0_pREAL)
allocate(dst%mismatch( 3,Nmembers), source=0.0_pReal) allocate(dst%mismatch( 3,Nmembers), source=0.0_pREAL)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! assigning cluster orientations ! assigning cluster orientations
@ -197,13 +197,13 @@ end subroutine RGC_init
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
module subroutine RGC_partitionDeformation(F,avgF,ce) module subroutine RGC_partitionDeformation(F,avgF,ce)
real(pReal), dimension (:,:,:), intent(out) :: F !< partitioned F per grain real(pREAL), dimension (:,:,:), intent(out) :: F !< partitioned F per grain
real(pReal), dimension (3,3), intent(in) :: avgF !< averaged F real(pREAL), dimension (3,3), intent(in) :: avgF !< averaged F
integer, intent(in) :: & integer, intent(in) :: &
ce ce
real(pReal), dimension(3) :: aVect,nVect real(pREAL), dimension(3) :: aVect,nVect
integer, dimension(4) :: intFace integer, dimension(4) :: intFace
integer, dimension(3) :: iGrain3 integer, dimension(3) :: iGrain3
integer :: iGrain,iFace,i,j,ho,en integer :: iGrain,iFace,i,j,ho,en
@ -214,7 +214,7 @@ module subroutine RGC_partitionDeformation(F,avgF,ce)
en = material_entry_homogenization(ce) en = material_entry_homogenization(ce)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! compute the deformation gradient of individual grains due to relaxations ! compute the deformation gradient of individual grains due to relaxations
F = 0.0_pReal F = 0.0_pREAL
do iGrain = 1,product(prm%N_constituents) do iGrain = 1,product(prm%N_constituents)
iGrain3 = grain1to3(iGrain,prm%N_constituents) iGrain3 = grain1to3(iGrain,prm%N_constituents)
do iFace = 1,6 do iFace = 1,6
@ -238,25 +238,25 @@ end subroutine RGC_partitionDeformation
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy) module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy)
logical, dimension(2) :: doneAndHappy logical, dimension(2) :: doneAndHappy
real(pReal), dimension(:,:,:), intent(in) :: & real(pREAL), dimension(:,:,:), intent(in) :: &
P,& !< partitioned stresses P,& !< partitioned stresses
F !< partitioned deformation gradients F !< partitioned deformation gradients
real(pReal), dimension(:,:,:,:,:), intent(in) :: dPdF !< partitioned stiffnesses real(pREAL), dimension(:,:,:,:,:), intent(in) :: dPdF !< partitioned stiffnesses
real(pReal), dimension(3,3), intent(in) :: avgF !< average F real(pREAL), dimension(3,3), intent(in) :: avgF !< average F
real(pReal), intent(in) :: dt !< time increment real(pREAL), intent(in) :: dt !< time increment
integer, intent(in) :: & integer, intent(in) :: &
ce !< cell ce !< cell
integer, dimension(4) :: intFaceN,intFaceP,faceID integer, dimension(4) :: intFaceN,intFaceP,faceID
integer, dimension(3) :: nGDim,iGr3N,iGr3P integer, dimension(3) :: nGDim,iGr3N,iGr3P
integer :: ho,iNum,i,j,nIntFaceTot,iGrN,iGrP,iMun,iFace,k,l,ipert,nGrain, en integer :: ho,iNum,i,j,nIntFaceTot,iGrN,iGrP,iMun,iFace,k,l,ipert,nGrain, en
real(pReal), dimension(3,3,size(P,3)) :: R,pF,pR,D,pD 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,size(P,3)) :: NN,devNull
real(pReal), dimension(3) :: normP,normN,mornP,mornN real(pREAL), dimension(3) :: normP,normN,mornP,mornN
real(pReal) :: residMax,stresMax real(pREAL) :: residMax,stresMax
logical :: error logical :: error
real(pReal), dimension(:,:), allocatable :: tract,jmatrix,jnverse,smatrix,pmatrix,rmatrix real(pREAL), dimension(:,:), allocatable :: tract,jmatrix,jnverse,smatrix,pmatrix,rmatrix
real(pReal), dimension(:), allocatable :: resid,relax,p_relax,p_resid,drelax real(pREAL), dimension(:), allocatable :: resid,relax,p_relax,p_resid,drelax
zeroTimeStep: if (dEq0(dt)) then zeroTimeStep: if (dEq0(dt)) then
doneAndHappy = .true. ! pretend everything is fine and return doneAndHappy = .true. ! pretend everything is fine and return
@ -278,8 +278,8 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! allocate the size of the global relaxation arrays/jacobian matrices depending on the size of the cluster ! allocate the size of the global relaxation arrays/jacobian matrices depending on the size of the cluster
allocate(resid(3*nIntFaceTot), source=0.0_pReal) allocate(resid(3*nIntFaceTot), source=0.0_pREAL)
allocate(tract(nIntFaceTot,3), source=0.0_pReal) allocate(tract(nIntFaceTot,3), source=0.0_pREAL)
relax = stt%relaxationVector(:,en) relax = stt%relaxationVector(:,en)
drelax = stt%relaxationVector(:,en) - st0%relaxationVector(:,en) drelax = stt%relaxationVector(:,en) - st0%relaxationVector(:,en)
@ -337,8 +337,8 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy)
if (residMax < num%rtol*stresMax .or. residMax < num%atol) then if (residMax < num%rtol*stresMax .or. residMax < num%atol) then
doneAndHappy = .true. doneAndHappy = .true.
dst%mismatch(1:3,en) = sum(NN,2)/real(nGrain,pReal) dst%mismatch(1:3,en) = sum(NN,2)/real(nGrain,pREAL)
dst%relaxationRate_avg(en) = sum(abs(drelax))/dt/real(3*nIntFaceTot,pReal) dst%relaxationRate_avg(en) = sum(abs(drelax))/dt/real(3*nIntFaceTot,pREAL)
dst%relaxationRate_max(en) = maxval(abs(drelax))/dt dst%relaxationRate_max(en) = maxval(abs(drelax))/dt
return return
@ -356,7 +356,7 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! ... of the constitutive stress tangent, assembled from dPdF or material constitutive model "smatrix" ! ... of the constitutive stress tangent, assembled from dPdF or material constitutive model "smatrix"
allocate(smatrix(3*nIntFaceTot,3*nIntFaceTot), source=0.0_pReal) allocate(smatrix(3*nIntFaceTot,3*nIntFaceTot), source=0.0_pREAL)
do iNum = 1,nIntFaceTot do iNum = 1,nIntFaceTot
faceID = interface1to4(iNum,param(ho)%N_constituents) ! assembling of local dPdF into global Jacobian matrix faceID = interface1to4(iNum,param(ho)%N_constituents) ! assembling of local dPdF into global Jacobian matrix
@ -403,9 +403,9 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! ... of the stress penalty tangent (mismatch penalty and volume penalty, computed using numerical ! ... of the stress penalty tangent (mismatch penalty and volume penalty, computed using numerical
! perturbation method) "pmatrix" ! perturbation method) "pmatrix"
allocate(pmatrix(3*nIntFaceTot,3*nIntFaceTot), source=0.0_pReal) allocate(pmatrix(3*nIntFaceTot,3*nIntFaceTot), source=0.0_pREAL)
allocate(p_relax(3*nIntFaceTot), source=0.0_pReal) allocate(p_relax(3*nIntFaceTot), source=0.0_pREAL)
allocate(p_resid(3*nIntFaceTot), source=0.0_pReal) allocate(p_resid(3*nIntFaceTot), source=0.0_pREAL)
do ipert = 1,3*nIntFaceTot do ipert = 1,3*nIntFaceTot
p_relax = relax p_relax = relax
@ -417,7 +417,7 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! computing the global stress residual array from the perturbed state ! computing the global stress residual array from the perturbed state
p_resid = 0.0_pReal p_resid = 0.0_pREAL
do iNum = 1,nIntFaceTot do iNum = 1,nIntFaceTot
faceID = interface1to4(iNum,param(ho)%N_constituents) ! identifying the interface ID in local coordinate system (4-dimensional index) faceID = interface1to4(iNum,param(ho)%N_constituents) ! identifying the interface ID in local coordinate system (4-dimensional index)
@ -452,10 +452,10 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! ... of the numerical viscosity traction "rmatrix" ! ... of the numerical viscosity traction "rmatrix"
allocate(rmatrix(3*nIntFaceTot,3*nIntFaceTot),source=0.0_pReal) allocate(rmatrix(3*nIntFaceTot,3*nIntFaceTot),source=0.0_pREAL)
do i=1,3*nIntFaceTot do i=1,3*nIntFaceTot
rmatrix(i,i) = num%viscModus*num%viscPower/(num%refRelaxRate*dt)* & ! tangent due to numerical viscosity traction appears rmatrix(i,i) = num%viscModus*num%viscPower/(num%refRelaxRate*dt)* & ! tangent due to numerical viscosity traction appears
(abs(drelax(i))/(num%refRelaxRate*dt))**(num%viscPower - 1.0_pReal) ! only in the main diagonal term (abs(drelax(i))/(num%refRelaxRate*dt))**(num%viscPower - 1.0_pREAL) ! only in the main diagonal term
end do end do
@ -465,12 +465,12 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! computing the update of the state variable (relaxation vectors) using the Jacobian matrix ! computing the update of the state variable (relaxation vectors) using the Jacobian matrix
allocate(jnverse(3*nIntFaceTot,3*nIntFaceTot),source=0.0_pReal) allocate(jnverse(3*nIntFaceTot,3*nIntFaceTot),source=0.0_pREAL)
call math_invert(jnverse,error,jmatrix) call math_invert(jnverse,error,jmatrix)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! calculate the state update (global relaxation vectors) for the next Newton-Raphson iteration ! calculate the state update (global relaxation vectors) for the next Newton-Raphson iteration
drelax = 0.0_pReal drelax = 0.0_pREAL
do i = 1,3*nIntFaceTot;do j = 1,3*nIntFaceTot do i = 1,3*nIntFaceTot;do j = 1,3*nIntFaceTot
drelax(i) = drelax(i) - jnverse(i,j)*resid(j) ! Calculate the correction for the state variable drelax(i) = drelax(i) - jnverse(i,j)*resid(j) ! Calculate the correction for the state variable
end do; end do end do; end do
@ -492,26 +492,26 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy)
!------------------------------------------------------------------------------------------------ !------------------------------------------------------------------------------------------------
subroutine stressPenalty(rPen,nMis,avgF,fDef,ho,en) subroutine stressPenalty(rPen,nMis,avgF,fDef,ho,en)
real(pReal), dimension (:,:,:), intent(out) :: rPen !< stress-like penalty real(pREAL), dimension (:,:,:), intent(out) :: rPen !< stress-like penalty
real(pReal), dimension (:,:), intent(out) :: nMis !< total amount of mismatch real(pREAL), dimension (:,:), intent(out) :: nMis !< total amount of mismatch
real(pReal), dimension (:,:,:), intent(in) :: fDef !< deformation gradients real(pREAL), dimension (:,:,:), intent(in) :: fDef !< deformation gradients
real(pReal), dimension (3,3), intent(in) :: avgF !< initial effective stretch tensor real(pREAL), dimension (3,3), intent(in) :: avgF !< initial effective stretch tensor
integer, intent(in) :: ho, en integer, intent(in) :: ho, en
integer, dimension (4) :: intFace integer, dimension (4) :: intFace
integer, dimension (3) :: iGrain3,iGNghb3,nGDim integer, dimension (3) :: iGrain3,iGNghb3,nGDim
real(pReal), dimension (3,3) :: gDef,nDef real(pREAL), dimension (3,3) :: gDef,nDef
real(pReal), dimension (3) :: nVect,surfCorr real(pREAL), dimension (3) :: nVect,surfCorr
integer :: iGrain,iGNghb,iFace,i,j,k,l integer :: iGrain,iGNghb,iFace,i,j,k,l
real(pReal) :: muGrain,muGNghb,nDefNorm real(pREAL) :: muGrain,muGNghb,nDefNorm
real(pReal), parameter :: & real(pREAL), parameter :: &
nDefToler = 1.0e-10_pReal, & nDefToler = 1.0e-10_pREAL, &
b = 2.5e-10_pReal ! Length of Burgers vector b = 2.5e-10_pREAL ! Length of Burgers vector
nGDim = param(ho)%N_constituents nGDim = param(ho)%N_constituents
rPen = 0.0_pReal rPen = 0.0_pREAL
nMis = 0.0_pReal nMis = 0.0_pREAL
!---------------------------------------------------------------------------------------------- !----------------------------------------------------------------------------------------------
! get the correction factor the modulus of penalty stress representing the evolution of area of ! get the correction factor the modulus of penalty stress representing the evolution of area of
@ -532,17 +532,17 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy)
nVect = interfaceNormal(intFace,ho,en) nVect = interfaceNormal(intFace,ho,en)
iGNghb3 = iGrain3 ! identify the neighboring grain across the interface iGNghb3 = iGrain3 ! identify the neighboring grain across the interface
iGNghb3(abs(intFace(1))) = iGNghb3(abs(intFace(1))) & iGNghb3(abs(intFace(1))) = iGNghb3(abs(intFace(1))) &
+ int(real(intFace(1),pReal)/real(abs(intFace(1)),pReal)) + int(real(intFace(1),pREAL)/real(abs(intFace(1)),pREAL))
where(iGNghb3 < 1) iGNghb3 = nGDim where(iGNghb3 < 1) iGNghb3 = nGDim
where(iGNghb3 >nGDim) iGNghb3 = 1 where(iGNghb3 >nGDim) iGNghb3 = 1
iGNghb = grain3to1(iGNghb3,prm%N_constituents) ! get the ID of the neighboring grain iGNghb = grain3to1(iGNghb3,prm%N_constituents) ! get the ID of the neighboring grain
muGNghb = equivalentMu(iGNghb,ce) muGNghb = equivalentMu(iGNghb,ce)
gDef = 0.5_pReal*(fDef(1:3,1:3,iGNghb) - fDef(1:3,1:3,iGrain)) ! difference/jump in deformation gradeint across the neighbor gDef = 0.5_pREAL*(fDef(1:3,1:3,iGNghb) - fDef(1:3,1:3,iGrain)) ! difference/jump in deformation gradeint across the neighbor
!------------------------------------------------------------------------------------------- !-------------------------------------------------------------------------------------------
! compute the mismatch tensor of all interfaces ! compute the mismatch tensor of all interfaces
nDefNorm = 0.0_pReal nDefNorm = 0.0_pREAL
nDef = 0.0_pReal nDef = 0.0_pREAL
do i = 1,3; do j = 1,3 do i = 1,3; do j = 1,3
do k = 1,3; do l = 1,3 do k = 1,3; do l = 1,3
nDef(i,j) = nDef(i,j) - nVect(k)*gDef(i,l)*math_LeviCivita(j,k,l) ! compute the interface mismatch tensor from the jump of deformation gradient nDef(i,j) = nDef(i,j) - nVect(k)*gDef(i,l)*math_LeviCivita(j,k,l) ! compute the interface mismatch tensor from the jump of deformation gradient
@ -556,10 +556,10 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy)
!------------------------------------------------------------------------------------------- !-------------------------------------------------------------------------------------------
! compute the stress penalty of all interfaces ! compute the stress penalty of all interfaces
do i = 1,3; do j = 1,3; do k = 1,3; do l = 1,3 do i = 1,3; do j = 1,3; do k = 1,3; do l = 1,3
rPen(i,j,iGrain) = rPen(i,j,iGrain) + 0.5_pReal*(muGrain*b + muGNghb*b)*prm%xi_alpha & rPen(i,j,iGrain) = rPen(i,j,iGrain) + 0.5_pREAL*(muGrain*b + muGNghb*b)*prm%xi_alpha &
*surfCorr(abs(intFace(1)))/prm%D_alpha(abs(intFace(1))) & *surfCorr(abs(intFace(1)))/prm%D_alpha(abs(intFace(1))) &
*cosh(prm%c_alpha*nDefNorm) & *cosh(prm%c_alpha*nDefNorm) &
*0.5_pReal*nVect(l)*nDef(i,k)/nDefNorm*math_LeviCivita(k,l,j) & *0.5_pREAL*nVect(l)*nDef(i,k)/nDefNorm*math_LeviCivita(k,l,j) &
*tanh(nDefNorm/num%xSmoo) *tanh(nDefNorm/num%xSmoo)
end do; end do;end do; end do end do; end do;end do; end do
end do interfaceLoop end do interfaceLoop
@ -577,15 +577,15 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy)
!------------------------------------------------------------------------------------------------ !------------------------------------------------------------------------------------------------
subroutine volumePenalty(vPen,vDiscrep,fAvg,fDef,nGrain) subroutine volumePenalty(vPen,vDiscrep,fAvg,fDef,nGrain)
real(pReal), dimension (:,:,:), intent(out) :: vPen ! stress-like penalty due to volume real(pREAL), dimension (:,:,:), intent(out) :: vPen ! stress-like penalty due to volume
real(pReal), intent(out) :: vDiscrep ! total volume discrepancy real(pREAL), intent(out) :: vDiscrep ! total volume discrepancy
real(pReal), dimension (:,:,:), intent(in) :: fDef ! deformation gradients real(pREAL), dimension (:,:,:), intent(in) :: fDef ! deformation gradients
real(pReal), dimension (3,3), intent(in) :: fAvg ! overall deformation gradient real(pREAL), dimension (3,3), intent(in) :: fAvg ! overall deformation gradient
integer, intent(in) :: & integer, intent(in) :: &
Ngrain Ngrain
real(pReal), dimension(size(vPen,3)) :: gVol real(pREAL), dimension(size(vPen,3)) :: gVol
integer :: i integer :: i
!---------------------------------------------------------------------------------------------- !----------------------------------------------------------------------------------------------
@ -593,16 +593,16 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy)
vDiscrep = math_det33(fAvg) ! compute the volume of the cluster vDiscrep = math_det33(fAvg) ! compute the volume of the cluster
do i = 1,nGrain do i = 1,nGrain
gVol(i) = math_det33(fDef(1:3,1:3,i)) ! compute the volume of individual grains 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 vDiscrep = vDiscrep - gVol(i)/real(nGrain,pREAL) ! calculate the difference/dicrepancy between
! the volume of the cluster and the the total volume of grains ! the volume of the cluster and the the total volume of grains
end do end do
!---------------------------------------------------------------------------------------------- !----------------------------------------------------------------------------------------------
! calculate the stress and penalty due to volume discrepancy ! calculate the stress and penalty due to volume discrepancy
vPen = 0.0_pReal vPen = 0.0_pREAL
do i = 1,nGrain do i = 1,nGrain
vPen(:,:,i) = -real(nGrain,pReal)**(-1)*num%volDiscrMod*num%volDiscrPow/num%maxVolDiscr & vPen(:,:,i) = -real(nGrain,pREAL)**(-1)*num%volDiscrMod*num%volDiscrPow/num%maxVolDiscr &
* sign((abs(vDiscrep)/num%maxVolDiscr)**(num%volDiscrPow - 1.0_pReal),vDiscrep) & * sign((abs(vDiscrep)/num%maxVolDiscr)**(num%volDiscrPow - 1.0_pREAL),vDiscrep) &
* gVol(i)*transpose(math_inv33(fDef(:,:,i))) * gVol(i)*transpose(math_inv33(fDef(:,:,i)))
end do end do
@ -615,21 +615,21 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
function surfaceCorrection(avgF,ho,en) function surfaceCorrection(avgF,ho,en)
real(pReal), dimension(3) :: surfaceCorrection real(pREAL), dimension(3) :: surfaceCorrection
real(pReal), dimension(3,3), intent(in) :: avgF !< average F real(pREAL), dimension(3,3), intent(in) :: avgF !< average F
integer, intent(in) :: & integer, intent(in) :: &
ho, & ho, &
en en
real(pReal), dimension(3,3) :: invC real(pREAL), dimension(3,3) :: invC
real(pReal), dimension(3) :: nVect real(pREAL), dimension(3) :: nVect
real(pReal) :: detF real(pREAL) :: detF
integer :: i,j,iBase integer :: i,j,iBase
logical :: error logical :: error
call math_invert33(invC,detF,error,matmul(transpose(avgF),avgF)) call math_invert33(invC,detF,error,matmul(transpose(avgF),avgF))
surfaceCorrection = 0.0_pReal surfaceCorrection = 0.0_pREAL
do iBase = 1,3 do iBase = 1,3
nVect = interfaceNormal([iBase,1,1,1],ho,en) nVect = interfaceNormal([iBase,1,1,1],ho,en)
do i = 1,3; do j = 1,3 do i = 1,3; do j = 1,3
@ -644,13 +644,13 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy)
!------------------------------------------------------------------------------------------------- !-------------------------------------------------------------------------------------------------
!> @brief compute the equivalent shear and bulk moduli from the elasticity tensor !> @brief compute the equivalent shear and bulk moduli from the elasticity tensor
!------------------------------------------------------------------------------------------------- !-------------------------------------------------------------------------------------------------
real(pReal) function equivalentMu(co,ce) real(pREAL) function equivalentMu(co,ce)
integer, intent(in) :: & integer, intent(in) :: &
co,& co,&
ce ce
real(pReal), dimension(6,6) :: C real(pREAL), dimension(6,6) :: C
C = phase_homogenizedC66(material_ID_phase(co,ce),material_entry_phase(co,ce)) ! damage not included! C = phase_homogenizedC66(material_ID_phase(co,ce),material_entry_phase(co,ce)) ! damage not included!
@ -665,14 +665,14 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy)
!------------------------------------------------------------------------------------------------- !-------------------------------------------------------------------------------------------------
subroutine grainDeformation(F, avgF, ho, en) subroutine grainDeformation(F, avgF, ho, en)
real(pReal), dimension(:,:,:), intent(out) :: F !< partitioned F per grain real(pREAL), dimension(:,:,:), intent(out) :: F !< partitioned F per grain
real(pReal), dimension(:,:), intent(in) :: avgF !< averaged F real(pREAL), dimension(:,:), intent(in) :: avgF !< averaged F
integer, intent(in) :: & integer, intent(in) :: &
ho, & ho, &
en en
real(pReal), dimension(3) :: aVect,nVect real(pREAL), dimension(3) :: aVect,nVect
integer, dimension(4) :: intFace integer, dimension(4) :: intFace
integer, dimension(3) :: iGrain3 integer, dimension(3) :: iGrain3
integer :: iGrain,iFace,i,j integer :: iGrain,iFace,i,j
@ -682,7 +682,7 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy)
associate (prm => param(ho)) associate (prm => param(ho))
F = 0.0_pReal F = 0.0_pREAL
do iGrain = 1,product(prm%N_constituents) do iGrain = 1,product(prm%N_constituents)
iGrain3 = grain1to3(iGrain,prm%N_constituents) iGrain3 = grain1to3(iGrain,prm%N_constituents)
do iFace = 1,6 do iFace = 1,6
@ -739,7 +739,7 @@ end subroutine RGC_result
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function relaxationVector(intFace,ho,en) pure function relaxationVector(intFace,ho,en)
real(pReal), dimension (3) :: relaxationVector real(pREAL), dimension (3) :: relaxationVector
integer, intent(in) :: ho,en integer, intent(in) :: ho,en
integer, dimension(4), intent(in) :: intFace !< set of interface ID in 4D array (normal and position) integer, dimension(4), intent(in) :: intFace !< set of interface ID in 4D array (normal and position)
@ -756,7 +756,7 @@ pure function relaxationVector(intFace,ho,en)
if (iNum > 0) then if (iNum > 0) then
relaxationVector = stt%relaxationVector((3*iNum-2):(3*iNum),en) relaxationVector = stt%relaxationVector((3*iNum-2):(3*iNum),en)
else else
relaxationVector = 0.0_pReal relaxationVector = 0.0_pREAL
end if end if
end associate end associate
@ -769,7 +769,7 @@ end function relaxationVector
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function interfaceNormal(intFace,ho,en) result(n) pure function interfaceNormal(intFace,ho,en) result(n)
real(pReal), dimension(3) :: n real(pREAL), dimension(3) :: n
integer, dimension(4), intent(in) :: intFace !< interface ID in 4D array (normal and position) integer, dimension(4), intent(in) :: intFace !< interface ID in 4D array (normal and position)
integer, intent(in) :: & integer, intent(in) :: &
ho, & ho, &
@ -778,8 +778,8 @@ pure function interfaceNormal(intFace,ho,en) result(n)
associate (dst => dependentState(ho)) associate (dst => dependentState(ho))
n = 0.0_pReal n = 0.0_pREAL
n(abs(intFace(1))) = real(intFace(1)/abs(intFace(1)),pReal) ! get the normal vector w.r.t. cluster axis n(abs(intFace(1))) = real(intFace(1)/abs(intFace(1)),pREAL) ! get the normal vector w.r.t. cluster axis
n = matmul(dst%orientation(1:3,1:3,en),n) ! map the normal vector into sample coordinate system (basis) n = matmul(dst%orientation(1:3,1:3,en),n) ! map the normal vector into sample coordinate system (basis)
@ -800,7 +800,7 @@ pure function getInterface(iFace,iGrain3) result(i)
integer :: iDir !< direction of interface normal integer :: iDir !< direction of interface normal
iDir = (int(real(iFace-1,pReal)/2.0_pReal)+1)*(-1)**iFace iDir = (int(real(iFace-1,pREAL)/2.0_pREAL)+1)*(-1)**iFace
i = [iDir,iGrain3] i = [iDir,iGrain3]
if (iDir < 0) i(1-iDir) = i(1-iDir)-1 ! to have a correlation with coordinate/position in real space if (iDir < 0) i(1-iDir) = i(1-iDir)-1 ! to have a correlation with coordinate/position in real space
@ -907,18 +907,18 @@ pure function interface1to4(iFace1D, nGDim)
if (iFace1D > 0 .and. iFace1D <= nIntFace(1)) then ! interface with normal || e1 if (iFace1D > 0 .and. iFace1D <= nIntFace(1)) then ! interface with normal || e1
interface1to4(1) = 1 interface1to4(1) = 1
interface1to4(3) = mod((iFace1D-1),nGDim(2))+1 interface1to4(3) = mod((iFace1D-1),nGDim(2))+1
interface1to4(4) = mod(int(real(iFace1D-1,pReal)/real(nGDim(2),pReal)),nGDim(3))+1 interface1to4(4) = mod(int(real(iFace1D-1,pREAL)/real(nGDim(2),pREAL)),nGDim(3))+1
interface1to4(2) = int(real(iFace1D-1,pReal)/real(nGDim(2),pReal)/real(nGDim(3),pReal))+1 interface1to4(2) = int(real(iFace1D-1,pREAL)/real(nGDim(2),pREAL)/real(nGDim(3),pREAL))+1
elseif (iFace1D > nIntFace(1) .and. iFace1D <= (nIntFace(2) + nIntFace(1))) then ! interface with normal || e2 elseif (iFace1D > nIntFace(1) .and. iFace1D <= (nIntFace(2) + nIntFace(1))) then ! interface with normal || e2
interface1to4(1) = 2 interface1to4(1) = 2
interface1to4(4) = mod((iFace1D-nIntFace(1)-1),nGDim(3))+1 interface1to4(4) = mod((iFace1D-nIntFace(1)-1),nGDim(3))+1
interface1to4(2) = mod(int(real(iFace1D-nIntFace(1)-1,pReal)/real(nGDim(3),pReal)),nGDim(1))+1 interface1to4(2) = mod(int(real(iFace1D-nIntFace(1)-1,pREAL)/real(nGDim(3),pREAL)),nGDim(1))+1
interface1to4(3) = int(real(iFace1D-nIntFace(1)-1,pReal)/real(nGDim(3),pReal)/real(nGDim(1),pReal))+1 interface1to4(3) = int(real(iFace1D-nIntFace(1)-1,pREAL)/real(nGDim(3),pREAL)/real(nGDim(1),pREAL))+1
elseif (iFace1D > nIntFace(2) + nIntFace(1) .and. iFace1D <= (nIntFace(3) + nIntFace(2) + nIntFace(1))) then ! interface with normal || e3 elseif (iFace1D > nIntFace(2) + nIntFace(1) .and. iFace1D <= (nIntFace(3) + nIntFace(2) + nIntFace(1))) then ! interface with normal || e3
interface1to4(1) = 3 interface1to4(1) = 3
interface1to4(2) = mod((iFace1D-nIntFace(2)-nIntFace(1)-1),nGDim(1))+1 interface1to4(2) = mod((iFace1D-nIntFace(2)-nIntFace(1)-1),nGDim(1))+1
interface1to4(3) = mod(int(real(iFace1D-nIntFace(2)-nIntFace(1)-1,pReal)/real(nGDim(1),pReal)),nGDim(2))+1 interface1to4(3) = mod(int(real(iFace1D-nIntFace(2)-nIntFace(1)-1,pREAL)/real(nGDim(1),pREAL)),nGDim(2))+1
interface1to4(4) = int(real(iFace1D-nIntFace(2)-nIntFace(1)-1,pReal)/real(nGDim(1),pReal)/real(nGDim(2),pReal))+1 interface1to4(4) = int(real(iFace1D-nIntFace(2)-nIntFace(1)-1,pREAL)/real(nGDim(1),pREAL)/real(nGDim(2),pREAL))+1
end if end if
end function interface1to4 end function interface1to4

4
src/homogenization_mechanical_isostrain.f90
View File

@ -40,9 +40,9 @@ end subroutine isostrain_init
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
module subroutine isostrain_partitionDeformation(F,avgF) module subroutine isostrain_partitionDeformation(F,avgF)
real(pReal), dimension (:,:,:), intent(out) :: F !< partitioned deformation gradient real(pREAL), dimension (:,:,:), intent(out) :: F !< partitioned deformation gradient
real(pReal), dimension (3,3), intent(in) :: avgF !< average deformation gradient at material point real(pREAL), dimension (3,3), intent(in) :: avgF !< average deformation gradient at material point
F = spread(avgF,3,size(F,3)) F = spread(avgF,3,size(F,3))

14
src/homogenization_thermal.f90
View File

@ -14,7 +14,7 @@ submodule(homogenization) thermal
end interface end interface
type :: tDataContainer type :: tDataContainer
real(pReal), dimension(:), allocatable :: T, dot_T real(pREAL), dimension(:), allocatable :: T, dot_T
end type tDataContainer end type tDataContainer
type(tDataContainer), dimension(:), allocatable :: current type(tDataContainer), dimension(:), allocatable :: current
@ -51,7 +51,7 @@ module subroutine thermal_init()
do ho = 1, configHomogenizations%length do ho = 1, configHomogenizations%length
allocate(current(ho)%T(count(material_ID_homogenization==ho)), source=T_ROOM) allocate(current(ho)%T(count(material_ID_homogenization==ho)), source=T_ROOM)
allocate(current(ho)%dot_T(count(material_ID_homogenization==ho)), source=0.0_pReal) allocate(current(ho)%dot_T(count(material_ID_homogenization==ho)), source=0.0_pREAL)
configHomogenization => configHomogenizations%get_dict(ho) configHomogenization => configHomogenizations%get_dict(ho)
associate(prm => param(ho)) associate(prm => param(ho))
@ -100,7 +100,7 @@ module subroutine thermal_partition(ce)
integer, intent(in) :: ce integer, intent(in) :: ce
real(pReal) :: T, dot_T real(pREAL) :: T, dot_T
integer :: co integer :: co
@ -119,7 +119,7 @@ end subroutine thermal_partition
module function homogenization_mu_T(ce) result(mu) module function homogenization_mu_T(ce) result(mu)
integer, intent(in) :: ce integer, intent(in) :: ce
real(pReal) :: mu real(pREAL) :: mu
integer :: co integer :: co
@ -138,7 +138,7 @@ end function homogenization_mu_T
module function homogenization_K_T(ce) result(K) module function homogenization_K_T(ce) result(K)
integer, intent(in) :: ce integer, intent(in) :: ce
real(pReal), dimension(3,3) :: K real(pREAL), dimension(3,3) :: K
integer :: co integer :: co
@ -157,7 +157,7 @@ end function homogenization_K_T
module function homogenization_f_T(ce) result(f) module function homogenization_f_T(ce) result(f)
integer, intent(in) :: ce integer, intent(in) :: ce
real(pReal) :: f real(pREAL) :: f
integer :: co integer :: co
@ -176,7 +176,7 @@ end function homogenization_f_T
module subroutine homogenization_thermal_setField(T,dot_T, ce) module subroutine homogenization_thermal_setField(T,dot_T, ce)
integer, intent(in) :: ce integer, intent(in) :: ce
real(pReal), intent(in) :: T, dot_T real(pREAL), intent(in) :: T, dot_T
current(material_ID_homogenization(ce))%T(material_entry_homogenization(ce)) = T current(material_ID_homogenization(ce))%T(material_entry_homogenization(ce)) = T

382
src/lattice.f90
View File

@ -38,7 +38,7 @@ module lattice
CF_NTRANS = sum(CF_NTRANSSYSTEM), & !< total # of transformation systems for cF CF_NTRANS = sum(CF_NTRANSSYSTEM), & !< total # of transformation systems for cF
CF_NCLEAVAGE = sum(CF_NCLEAVAGESYSTEM) !< total # of cleavage systems for cF CF_NCLEAVAGE = sum(CF_NCLEAVAGESYSTEM) !< total # of cleavage systems for cF
real(pReal), dimension(3+3,CF_NSLIP), parameter :: & real(pREAL), dimension(3+3,CF_NSLIP), parameter :: &
CF_SYSTEMSLIP = reshape(real([& CF_SYSTEMSLIP = reshape(real([&
! <110>{111} systems ! <110>{111} systems
0, 1,-1, 1, 1, 1, & ! B2 0, 1,-1, 1, 1, 1, & ! B2
@ -60,9 +60,9 @@ module lattice
1, 0,-1, 1, 0, 1, & 1, 0,-1, 1, 0, 1, &
0, 1, 1, 0, 1,-1, & 0, 1, 1, 0, 1,-1, &
0, 1,-1, 0, 1, 1 & 0, 1,-1, 0, 1, 1 &
],pReal),shape(CF_SYSTEMSLIP)) !< cF slip systems ],pREAL),shape(CF_SYSTEMSLIP)) !< cF slip systems
real(pReal), dimension(3+3,CF_NTWIN), parameter :: & real(pREAL), dimension(3+3,CF_NTWIN), parameter :: &
CF_SYSTEMTWIN = reshape(real( [& CF_SYSTEMTWIN = reshape(real( [&
! <112>{111} systems ! <112>{111} systems
-2, 1, 1, 1, 1, 1, & -2, 1, 1, 1, 1, 1, &
@ -77,7 +77,7 @@ module lattice
2, 1,-1, -1, 1,-1, & 2, 1,-1, -1, 1,-1, &
-1,-2,-1, -1, 1,-1, & -1,-2,-1, -1, 1,-1, &
-1, 1, 2, -1, 1,-1 & -1, 1, 2, -1, 1,-1 &
],pReal),shape(CF_SYSTEMTWIN)) !< cF twin systems ],pREAL),shape(CF_SYSTEMTWIN)) !< cF twin systems
integer, dimension(2,CF_NTWIN), parameter, public :: & integer, dimension(2,CF_NTWIN), parameter, public :: &
lattice_CF_TWINNUCLEATIONSLIPPAIR = reshape( [& lattice_CF_TWINNUCLEATIONSLIPPAIR = reshape( [&
@ -95,13 +95,13 @@ module lattice
10,11 & 10,11 &
],shape(lattice_CF_TWINNUCLEATIONSLIPPAIR)) ],shape(lattice_CF_TWINNUCLEATIONSLIPPAIR))
real(pReal), dimension(3+3,CF_NCLEAVAGE), parameter :: & real(pREAL), dimension(3+3,CF_NCLEAVAGE), parameter :: &
CF_SYSTEMCLEAVAGE = reshape(real([& CF_SYSTEMCLEAVAGE = reshape(real([&
! <001>{001} systems ! <001>{001} systems
0, 1, 0, 1, 0, 0, & 0, 1, 0, 1, 0, 0, &
0, 0, 1, 0, 1, 0, & 0, 0, 1, 0, 1, 0, &
1, 0, 0, 0, 0, 1 & 1, 0, 0, 0, 0, 1 &
],pReal),shape(CF_SYSTEMCLEAVAGE)) !< cF cleavage systems ],pREAL),shape(CF_SYSTEMCLEAVAGE)) !< cF cleavage systems
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! cI: body centered cubic (bcc) ! cI: body centered cubic (bcc)
@ -120,7 +120,7 @@ module lattice
CI_NTWIN = sum(CI_NTWINSYSTEM), & !< total # of twin systems for cI CI_NTWIN = sum(CI_NTWINSYSTEM), & !< total # of twin systems for cI
CI_NCLEAVAGE = sum(CI_NCLEAVAGESYSTEM) !< total # of cleavage systems for cI CI_NCLEAVAGE = sum(CI_NCLEAVAGESYSTEM) !< total # of cleavage systems for cI
real(pReal), dimension(3+3,CI_NSLIP), parameter :: & real(pREAL), dimension(3+3,CI_NSLIP), parameter :: &
CI_SYSTEMSLIP = reshape(real([& CI_SYSTEMSLIP = reshape(real([&
! <111>{110} systems ! <111>{110} systems
1,-1, 1, 0, 1, 1, & ! D1 1,-1, 1, 0, 1, 1, & ! D1
@ -173,9 +173,9 @@ module lattice
1, 1, 1, -3, 2, 1, & 1, 1, 1, -3, 2, 1, &
1, 1,-1, 3,-2, 1, & 1, 1,-1, 3,-2, 1, &
1,-1, 1, 3, 2,-1 & 1,-1, 1, 3, 2,-1 &
],pReal),shape(CI_SYSTEMSLIP)) !< cI slip systems ],pREAL),shape(CI_SYSTEMSLIP)) !< cI slip systems
real(pReal), dimension(3+3,CI_NTWIN), parameter :: & real(pREAL), dimension(3+3,CI_NTWIN), parameter :: &
CI_SYSTEMTWIN = reshape(real([& CI_SYSTEMTWIN = reshape(real([&
! <111>{112} systems ! <111>{112} systems
-1, 1, 1, 2, 1, 1, & -1, 1, 1, 2, 1, 1, &
@ -190,15 +190,15 @@ module lattice
1,-1, 1, -1, 1, 2, & 1,-1, 1, -1, 1, 2, &
-1, 1, 1, 1,-1, 2, & -1, 1, 1, 1,-1, 2, &
1, 1, 1, 1, 1,-2 & 1, 1, 1, 1, 1,-2 &
],pReal),shape(CI_SYSTEMTWIN)) !< cI twin systems ],pREAL),shape(CI_SYSTEMTWIN)) !< cI twin systems
real(pReal), dimension(3+3,CI_NCLEAVAGE), parameter :: & real(pREAL), dimension(3+3,CI_NCLEAVAGE), parameter :: &
CI_SYSTEMCLEAVAGE = reshape(real([& CI_SYSTEMCLEAVAGE = reshape(real([&
! <001>{001} systems ! <001>{001} systems
0, 1, 0, 1, 0, 0, & 0, 1, 0, 1, 0, 0, &
0, 0, 1, 0, 1, 0, & 0, 0, 1, 0, 1, 0, &
1, 0, 0, 0, 0, 1 & 1, 0, 0, 0, 0, 1 &
],pReal),shape(CI_SYSTEMCLEAVAGE)) !< cI cleavage systems ],pREAL),shape(CI_SYSTEMCLEAVAGE)) !< cI cleavage systems
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! hP: hexagonal [close packed] (hex, hcp) ! hP: hexagonal [close packed] (hex, hcp)
@ -213,7 +213,7 @@ module lattice
HP_NSLIP = sum(HP_NSLIPSYSTEM), & !< total # of slip systems for hP HP_NSLIP = sum(HP_NSLIPSYSTEM), & !< total # of slip systems for hP
HP_NTWIN = sum(HP_NTWINSYSTEM) !< total # of twin systems for hP HP_NTWIN = sum(HP_NTWINSYSTEM) !< total # of twin systems for hP
real(pReal), dimension(4+4,HP_NSLIP), parameter :: & real(pREAL), dimension(4+4,HP_NSLIP), parameter :: &
HP_SYSTEMSLIP = reshape(real([& HP_SYSTEMSLIP = reshape(real([&
! <-1-1.0>{00.1}/basal systems (independent of c/a-ratio) ! <-1-1.0>{00.1}/basal systems (independent of c/a-ratio)
2, -1, -1, 0, 0, 0, 0, 1, & 2, -1, -1, 0, 0, 0, 0, 1, &
@ -250,9 +250,9 @@ module lattice
1, 1, -2, 3, -1, -1, 2, 2, & 1, 1, -2, 3, -1, -1, 2, 2, &
-1, 2, -1, 3, 1, -2, 1, 2, & -1, 2, -1, 3, 1, -2, 1, 2, &
-2, 1, 1, 3, 2, -1, -1, 2 & -2, 1, 1, 3, 2, -1, -1, 2 &
],pReal),shape(HP_SYSTEMSLIP)) !< hP slip systems, sorted by P. Eisenlohr CCW around <c> starting next to a_1 axis ],pREAL),shape(HP_SYSTEMSLIP)) !< hP slip systems, sorted by P. Eisenlohr CCW around <c> starting next to a_1 axis
real(pReal), dimension(4+4,HP_NTWIN), parameter :: & real(pREAL), dimension(4+4,HP_NTWIN), parameter :: &
HP_SYSTEMTWIN = reshape(real([& HP_SYSTEMTWIN = reshape(real([&
! <-10.1>{10.2} systems, shear = (3-(c/a)^2)/(sqrt(3) c/a) ! <-10.1>{10.2} systems, shear = (3-(c/a)^2)/(sqrt(3) c/a)
! tension in Co, Mg, Zr, Ti, and Be; compression in Cd and Zn ! tension in Co, Mg, Zr, Ti, and Be; compression in Cd and Zn
@ -286,7 +286,7 @@ module lattice
-1, -1, 2, -3, -1, -1, 2, 2, & -1, -1, 2, -3, -1, -1, 2, 2, &
1, -2, 1, -3, 1, -2, 1, 2, & 1, -2, 1, -3, 1, -2, 1, 2, &
2, -1, -1, -3, 2, -1, -1, 2 & 2, -1, -1, -3, 2, -1, -1, 2 &
],pReal),shape(HP_SYSTEMTWIN)) !< hP twin systems, sorted by P. Eisenlohr CCW around <c> starting next to a_1 axis ],pREAL),shape(HP_SYSTEMTWIN)) !< hP twin systems, sorted by P. Eisenlohr CCW around <c> starting next to a_1 axis
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! tI: body centered tetragonal (bct) ! tI: body centered tetragonal (bct)
@ -297,7 +297,7 @@ module lattice
integer, parameter :: & integer, parameter :: &
TI_NSLIP = sum(TI_NSLIPSYSTEM) !< total # of slip systems for tI TI_NSLIP = sum(TI_NSLIPSYSTEM) !< total # of slip systems for tI
real(pReal), dimension(3+3,TI_NSLIP), parameter :: & real(pREAL), dimension(3+3,TI_NSLIP), parameter :: &
TI_SYSTEMSLIP = reshape(real([& TI_SYSTEMSLIP = reshape(real([&
! {100)<001] systems ! {100)<001] systems
0, 0, 1, 1, 0, 0, & 0, 0, 1, 1, 0, 0, &
@ -364,7 +364,7 @@ module lattice
1,-1, 1, -2,-1, 1, & 1,-1, 1, -2,-1, 1, &
-1, 1, 1, -1,-2, 1, & -1, 1, 1, -1,-2, 1, &
1, 1, 1, 1,-2, 1 & 1, 1, 1, 1,-2, 1 &
],pReal),shape(TI_SYSTEMSLIP)) !< tI slip systems for c/a = 0.5456 (Sn), sorted by Bieler 2009 (https://doi.org/10.1007/s11664-009-0909-x) ],pREAL),shape(TI_SYSTEMSLIP)) !< tI slip systems for c/a = 0.5456 (Sn), sorted by Bieler 2009 (https://doi.org/10.1007/s11664-009-0909-x)
interface lattice_forestProjection_edge interface lattice_forestProjection_edge
@ -424,8 +424,8 @@ function lattice_characteristicShear_Twin(Ntwin,lattice,CoverA) result(character
integer, dimension(:), intent(in) :: Ntwin !< number of active twin systems per family integer, dimension(:), intent(in) :: Ntwin !< number of active twin systems per family
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol)
real(pReal), intent(in) :: cOverA !< c/a ratio real(pREAL), intent(in) :: cOverA !< c/a ratio
real(pReal), dimension(sum(Ntwin)) :: characteristicShear real(pREAL), dimension(sum(Ntwin)) :: characteristicShear
integer :: & integer :: &
a, & !< index of active system a, & !< index of active system
@ -467,20 +467,20 @@ function lattice_characteristicShear_Twin(Ntwin,lattice,CoverA) result(character
a = a + 1 a = a + 1
select case(lattice) select case(lattice)
case('cF','cI') case('cF','cI')
characteristicShear(a) = 0.5_pReal*sqrt(2.0_pReal) characteristicShear(a) = 0.5_pREAL*sqrt(2.0_pREAL)
case('hP') case('hP')
if (cOverA < 1.0_pReal .or. cOverA > 2.0_pReal) & if (cOverA < 1.0_pREAL .or. cOverA > 2.0_pREAL) &
call IO_error(131,ext_msg='lattice_characteristicShear_Twin') call IO_error(131,ext_msg='lattice_characteristicShear_Twin')
p = sum(HP_NTWINSYSTEM(1:f-1))+s p = sum(HP_NTWINSYSTEM(1:f-1))+s
select case(HP_SHEARTWIN(p)) ! from Christian & Mahajan 1995 p.29 select case(HP_SHEARTWIN(p)) ! from Christian & Mahajan 1995 p.29
case (1) ! <-10.1>{10.2} case (1) ! <-10.1>{10.2}
characteristicShear(a) = (3.0_pReal-cOverA**2)/sqrt(3.0_pReal)/CoverA characteristicShear(a) = (3.0_pREAL-cOverA**2)/sqrt(3.0_pREAL)/CoverA
case (2) ! <11.6>{-1-1.1} case (2) ! <11.6>{-1-1.1}
characteristicShear(a) = 1.0_pReal/cOverA characteristicShear(a) = 1.0_pREAL/cOverA
case (3) ! <10.-2>{10.1} case (3) ! <10.-2>{10.1}
characteristicShear(a) = (4.0_pReal*cOverA**2-9.0_pReal)/sqrt(48.0_pReal)/cOverA characteristicShear(a) = (4.0_pREAL*cOverA**2-9.0_pREAL)/sqrt(48.0_pREAL)/cOverA
case (4) ! <11.-3>{11.2} case (4) ! <11.-3>{11.2}
characteristicShear(a) = 2.0_pReal*(cOverA**2-2.0_pReal)/3.0_pReal/cOverA characteristicShear(a) = 2.0_pREAL*(cOverA**2-2.0_pREAL)/3.0_pREAL/cOverA
end select end select
case default case default
call IO_error(137,ext_msg='lattice_characteristicShear_Twin: '//trim(lattice)) call IO_error(137,ext_msg='lattice_characteristicShear_Twin: '//trim(lattice))
@ -498,11 +498,11 @@ function lattice_C66_twin(Ntwin,C66,lattice,CoverA)
integer, dimension(:), intent(in) :: Ntwin !< number of active twin systems per family integer, dimension(:), intent(in) :: Ntwin !< number of active twin systems per family
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol)
real(pReal), dimension(6,6), intent(in) :: C66 !< unrotated parent stiffness matrix real(pREAL), dimension(6,6), intent(in) :: C66 !< unrotated parent stiffness matrix
real(pReal), intent(in) :: cOverA !< c/a ratio real(pREAL), intent(in) :: cOverA !< c/a ratio
real(pReal), dimension(6,6,sum(Ntwin)) :: lattice_C66_twin real(pREAL), dimension(6,6,sum(Ntwin)) :: lattice_C66_twin
real(pReal), dimension(3,3,sum(Ntwin)):: coordinateSystem real(pREAL), dimension(3,3,sum(Ntwin)):: coordinateSystem
type(tRotation) :: R type(tRotation) :: R
integer :: i integer :: i
@ -510,10 +510,10 @@ function lattice_C66_twin(Ntwin,C66,lattice,CoverA)
select case(lattice) select case(lattice)
case('cF') case('cF')
coordinateSystem = buildCoordinateSystem(Ntwin,CF_NSLIPSYSTEM,CF_SYSTEMTWIN,& coordinateSystem = buildCoordinateSystem(Ntwin,CF_NSLIPSYSTEM,CF_SYSTEMTWIN,&
lattice,0.0_pReal) lattice,0.0_pREAL)
case('cI') case('cI')
coordinateSystem = buildCoordinateSystem(Ntwin,CI_NSLIPSYSTEM,CI_SYSTEMTWIN,& coordinateSystem = buildCoordinateSystem(Ntwin,CI_NSLIPSYSTEM,CI_SYSTEMTWIN,&
lattice,0.0_pReal) lattice,0.0_pREAL)
case('hP') case('hP')
coordinateSystem = buildCoordinateSystem(Ntwin,HP_NSLIPSYSTEM,HP_SYSTEMTWIN,& coordinateSystem = buildCoordinateSystem(Ntwin,HP_NSLIPSYSTEM,HP_SYSTEMTWIN,&
lattice,cOverA) lattice,cOverA)
@ -537,12 +537,12 @@ function lattice_C66_trans(Ntrans,C_parent66,lattice_target, &
integer, dimension(:), intent(in) :: Ntrans !< number of active twin systems per family integer, dimension(:), intent(in) :: Ntrans !< number of active twin systems per family
character(len=*), intent(in) :: lattice_target !< Bravais lattice (Pearson symbol) character(len=*), intent(in) :: lattice_target !< Bravais lattice (Pearson symbol)
real(pReal), dimension(6,6), intent(in) :: C_parent66 real(pREAL), dimension(6,6), intent(in) :: C_parent66
real(pReal), optional, intent(in) :: cOverA_trans, a_cF, a_cI real(pREAL), optional, intent(in) :: cOverA_trans, a_cF, a_cI
real(pReal), dimension(6,6,sum(Ntrans)) :: lattice_C66_trans real(pREAL), dimension(6,6,sum(Ntrans)) :: lattice_C66_trans
real(pReal), dimension(6,6) :: C_bar66, C_target_unrotated66 real(pREAL), dimension(6,6) :: C_bar66, C_target_unrotated66
real(pReal), dimension(3,3,sum(Ntrans)) :: Q,S real(pREAL), dimension(3,3,sum(Ntrans)) :: Q,S
type(tRotation) :: R type(tRotation) :: R
integer :: i integer :: i
@ -551,24 +551,24 @@ function lattice_C66_trans(Ntrans,C_parent66,lattice_target, &
if (lattice_target == 'hP' .and. present(cOverA_trans)) then if (lattice_target == 'hP' .and. present(cOverA_trans)) then
! https://doi.org/10.1063/1.1663858 eq. (16), eq. (18), eq. (19) ! https://doi.org/10.1063/1.1663858 eq. (16), eq. (18), eq. (19)
! https://doi.org/10.1016/j.actamat.2016.07.032 eq. (47), eq. (48) ! https://doi.org/10.1016/j.actamat.2016.07.032 eq. (47), eq. (48)
if (cOverA_trans < 1.0_pReal .or. cOverA_trans > 2.0_pReal) & if (cOverA_trans < 1.0_pREAL .or. cOverA_trans > 2.0_pREAL) &
call IO_error(131,ext_msg='lattice_C66_trans: '//trim(lattice_target)) call IO_error(131,ext_msg='lattice_C66_trans: '//trim(lattice_target))
C_bar66(1,1) = (C_parent66(1,1) + C_parent66(1,2) + 2.0_pReal*C_parent66(4,4))/2.0_pReal C_bar66(1,1) = (C_parent66(1,1) + C_parent66(1,2) + 2.0_pREAL*C_parent66(4,4))/2.0_pREAL
C_bar66(1,2) = (C_parent66(1,1) + 5.0_pReal*C_parent66(1,2) - 2.0_pReal*C_parent66(4,4))/6.0_pReal C_bar66(1,2) = (C_parent66(1,1) + 5.0_pREAL*C_parent66(1,2) - 2.0_pREAL*C_parent66(4,4))/6.0_pREAL
C_bar66(3,3) = (C_parent66(1,1) + 2.0_pReal*C_parent66(1,2) + 4.0_pReal*C_parent66(4,4))/3.0_pReal C_bar66(3,3) = (C_parent66(1,1) + 2.0_pREAL*C_parent66(1,2) + 4.0_pREAL*C_parent66(4,4))/3.0_pREAL
C_bar66(1,3) = (C_parent66(1,1) + 2.0_pReal*C_parent66(1,2) - 2.0_pReal*C_parent66(4,4))/3.0_pReal C_bar66(1,3) = (C_parent66(1,1) + 2.0_pREAL*C_parent66(1,2) - 2.0_pREAL*C_parent66(4,4))/3.0_pREAL
C_bar66(4,4) = (C_parent66(1,1) - C_parent66(1,2) + C_parent66(4,4))/3.0_pReal C_bar66(4,4) = (C_parent66(1,1) - C_parent66(1,2) + C_parent66(4,4))/3.0_pREAL
C_bar66(1,4) = (C_parent66(1,1) - C_parent66(1,2) - 2.0_pReal*C_parent66(4,4)) /(3.0_pReal*sqrt(2.0_pReal)) C_bar66(1,4) = (C_parent66(1,1) - C_parent66(1,2) - 2.0_pREAL*C_parent66(4,4)) /(3.0_pREAL*sqrt(2.0_pREAL))
C_target_unrotated66 = 0.0_pReal C_target_unrotated66 = 0.0_pREAL
C_target_unrotated66(1,1) = C_bar66(1,1) - C_bar66(1,4)**2/C_bar66(4,4) C_target_unrotated66(1,1) = C_bar66(1,1) - C_bar66(1,4)**2/C_bar66(4,4)
C_target_unrotated66(1,2) = C_bar66(1,2) + C_bar66(1,4)**2/C_bar66(4,4) C_target_unrotated66(1,2) = C_bar66(1,2) + C_bar66(1,4)**2/C_bar66(4,4)
C_target_unrotated66(1,3) = C_bar66(1,3) C_target_unrotated66(1,3) = C_bar66(1,3)
C_target_unrotated66(3,3) = C_bar66(3,3) C_target_unrotated66(3,3) = C_bar66(3,3)
C_target_unrotated66(4,4) = C_bar66(4,4) - C_bar66(1,4)**2/(0.5_pReal*(C_bar66(1,1) - C_bar66(1,2))) C_target_unrotated66(4,4) = C_bar66(4,4) - C_bar66(1,4)**2/(0.5_pREAL*(C_bar66(1,1) - C_bar66(1,2)))
C_target_unrotated66 = lattice_symmetrize_C66(C_target_unrotated66,'hP') C_target_unrotated66 = lattice_symmetrize_C66(C_target_unrotated66,'hP')
elseif (lattice_target == 'cI' .and. present(a_cF) .and. present(a_cI)) then elseif (lattice_target == 'cI' .and. present(a_cF) .and. present(a_cI)) then
if (a_cI <= 0.0_pReal .or. a_cF <= 0.0_pReal) & if (a_cI <= 0.0_pREAL .or. a_cF <= 0.0_pREAL) &
call IO_error(134,ext_msg='lattice_C66_trans: '//trim(lattice_target)) call IO_error(134,ext_msg='lattice_C66_trans: '//trim(lattice_target))
C_target_unrotated66 = C_parent66 C_target_unrotated66 = C_parent66
else else
@ -598,26 +598,26 @@ function lattice_C66_trans(Ntrans,C_parent66,lattice_target, &
function lattice_nonSchmidMatrix(Nslip,nonSchmidCoefficients,sense) result(nonSchmidMatrix) function lattice_nonSchmidMatrix(Nslip,nonSchmidCoefficients,sense) result(nonSchmidMatrix)
integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family
real(pReal), dimension(:), intent(in) :: nonSchmidCoefficients !< non-Schmid coefficients for projections real(pREAL), dimension(:), intent(in) :: nonSchmidCoefficients !< non-Schmid coefficients for projections
integer, intent(in) :: sense !< sense (-1,+1) integer, intent(in) :: sense !< sense (-1,+1)
real(pReal), dimension(1:3,1:3,sum(Nslip)) :: nonSchmidMatrix real(pREAL), dimension(1:3,1:3,sum(Nslip)) :: nonSchmidMatrix
real(pReal), dimension(1:3,1:3,sum(Nslip)) :: coordinateSystem !< coordinate system of slip system real(pREAL), dimension(1:3,1:3,sum(Nslip)) :: coordinateSystem !< coordinate system of slip system
real(pReal), dimension(3) :: direction, normal, np real(pREAL), dimension(3) :: direction, normal, np
type(tRotation) :: R type(tRotation) :: R
integer :: i integer :: i
if (abs(sense) /= 1) error stop 'Sense in lattice_nonSchmidMatrix' if (abs(sense) /= 1) error stop 'Sense in lattice_nonSchmidMatrix'
coordinateSystem = buildCoordinateSystem(Nslip,CI_NSLIPSYSTEM,CI_SYSTEMSLIP,'cI',0.0_pReal) coordinateSystem = buildCoordinateSystem(Nslip,CI_NSLIPSYSTEM,CI_SYSTEMSLIP,'cI',0.0_pREAL)
coordinateSystem(1:3,1,1:sum(Nslip)) = coordinateSystem(1:3,1,1:sum(Nslip))*real(sense,pReal) ! convert unidirectional coordinate system coordinateSystem(1:3,1,1:sum(Nslip)) = coordinateSystem(1:3,1,1:sum(Nslip))*real(sense,pREAL) ! convert unidirectional coordinate system
nonSchmidMatrix = lattice_SchmidMatrix_slip(Nslip,'cI',0.0_pReal) ! Schmid contribution nonSchmidMatrix = lattice_SchmidMatrix_slip(Nslip,'cI',0.0_pREAL) ! Schmid contribution
do i = 1,sum(Nslip) do i = 1,sum(Nslip)
direction = coordinateSystem(1:3,1,i) direction = coordinateSystem(1:3,1,i)
normal = coordinateSystem(1:3,2,i) normal = coordinateSystem(1:3,2,i)
call R%fromAxisAngle([direction,60.0_pReal],degrees=.true.,P=1) call R%fromAxisAngle([direction,60.0_pREAL],degrees=.true.,P=1)
np = R%rotate(normal) np = R%rotate(normal)
if (size(nonSchmidCoefficients)>0) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) & if (size(nonSchmidCoefficients)>0) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) &
@ -647,9 +647,9 @@ end function lattice_nonSchmidMatrix
function lattice_interaction_SlipBySlip(Nslip,interactionValues,lattice) result(interactionMatrix) function lattice_interaction_SlipBySlip(Nslip,interactionValues,lattice) result(interactionMatrix)
integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family
real(pReal), dimension(:), intent(in) :: interactionValues !< values for slip-slip interaction real(pREAL), dimension(:), intent(in) :: interactionValues !< values for slip-slip interaction
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol)
real(pReal), dimension(sum(Nslip),sum(Nslip)) :: interactionMatrix real(pREAL), dimension(sum(Nslip),sum(Nslip)) :: interactionMatrix
integer, dimension(:), allocatable :: NslipMax integer, dimension(:), allocatable :: NslipMax
integer, dimension(:,:), allocatable :: interactionTypes integer, dimension(:,:), allocatable :: interactionTypes
@ -965,9 +965,9 @@ end function lattice_interaction_SlipBySlip
function lattice_interaction_TwinByTwin(Ntwin,interactionValues,lattice) result(interactionMatrix) function lattice_interaction_TwinByTwin(Ntwin,interactionValues,lattice) result(interactionMatrix)
integer, dimension(:), intent(in) :: Ntwin !< number of active twin systems per family integer, dimension(:), intent(in) :: Ntwin !< number of active twin systems per family
real(pReal), dimension(:), intent(in) :: interactionValues !< values for twin-twin interaction real(pREAL), dimension(:), intent(in) :: interactionValues !< values for twin-twin interaction
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol)
real(pReal), dimension(sum(Ntwin),sum(Ntwin)) :: interactionMatrix real(pREAL), dimension(sum(Ntwin),sum(Ntwin)) :: interactionMatrix
integer, dimension(:), allocatable :: NtwinMax integer, dimension(:), allocatable :: NtwinMax
integer, dimension(:,:), allocatable :: interactionTypes integer, dimension(:,:), allocatable :: interactionTypes
@ -1064,9 +1064,9 @@ end function lattice_interaction_TwinByTwin
function lattice_interaction_TransByTrans(Ntrans,interactionValues,lattice) result(interactionMatrix) function lattice_interaction_TransByTrans(Ntrans,interactionValues,lattice) result(interactionMatrix)
integer, dimension(:), intent(in) :: Ntrans !< number of active trans systems per family integer, dimension(:), intent(in) :: Ntrans !< number of active trans systems per family
real(pReal), dimension(:), intent(in) :: interactionValues !< values for trans-trans interaction real(pREAL), dimension(:), intent(in) :: interactionValues !< values for trans-trans interaction
character(len=*), intent(in) :: lattice !<Bravais lattice (Pearson symbol) (parent crystal) character(len=*), intent(in) :: lattice !<Bravais lattice (Pearson symbol) (parent crystal)
real(pReal), dimension(sum(Ntrans),sum(Ntrans)) :: interactionMatrix real(pREAL), dimension(sum(Ntrans),sum(Ntrans)) :: interactionMatrix
integer, dimension(:), allocatable :: NtransMax integer, dimension(:), allocatable :: NtransMax
integer, dimension(:,:), allocatable :: interactionTypes integer, dimension(:,:), allocatable :: interactionTypes
@ -1107,9 +1107,9 @@ function lattice_interaction_SlipByTwin(Nslip,Ntwin,interactionValues,lattice) r
integer, dimension(:), intent(in) :: Nslip, & !< number of active slip systems per family integer, dimension(:), intent(in) :: Nslip, & !< number of active slip systems per family
Ntwin !< number of active twin systems per family Ntwin !< number of active twin systems per family
real(pReal), dimension(:), intent(in) :: interactionValues !< values for slip-twin interaction real(pREAL), dimension(:), intent(in) :: interactionValues !< values for slip-twin interaction
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol)
real(pReal), dimension(sum(Nslip),sum(Ntwin)) :: interactionMatrix real(pREAL), dimension(sum(Nslip),sum(Ntwin)) :: interactionMatrix
integer, dimension(:), allocatable :: NslipMax, & integer, dimension(:), allocatable :: NslipMax, &
NtwinMax NtwinMax
@ -1267,9 +1267,9 @@ function lattice_interaction_SlipByTrans(Nslip,Ntrans,interactionValues,lattice)
integer, dimension(:), intent(in) :: Nslip, & !< number of active slip systems per family integer, dimension(:), intent(in) :: Nslip, & !< number of active slip systems per family
Ntrans !< number of active trans systems per family Ntrans !< number of active trans systems per family
real(pReal), dimension(:), intent(in) :: interactionValues !< values for slip-trans interaction real(pREAL), dimension(:), intent(in) :: interactionValues !< values for slip-trans interaction
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) (parent crystal) character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) (parent crystal)
real(pReal), dimension(sum(Nslip),sum(Ntrans)) :: interactionMatrix real(pREAL), dimension(sum(Nslip),sum(Ntrans)) :: interactionMatrix
integer, dimension(:), allocatable :: NslipMax, & integer, dimension(:), allocatable :: NslipMax, &
NtransMax NtransMax
@ -1320,9 +1320,9 @@ function lattice_interaction_TwinBySlip(Ntwin,Nslip,interactionValues,lattice) r
integer, dimension(:), intent(in) :: Ntwin, & !< number of active twin systems per family integer, dimension(:), intent(in) :: Ntwin, & !< number of active twin systems per family
Nslip !< number of active slip systems per family Nslip !< number of active slip systems per family
real(pReal), dimension(:), intent(in) :: interactionValues !< values for twin-twin interaction real(pREAL), dimension(:), intent(in) :: interactionValues !< values for twin-twin interaction
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol)
real(pReal), dimension(sum(Ntwin),sum(Nslip)) :: interactionMatrix real(pREAL), dimension(sum(Ntwin),sum(Nslip)) :: interactionMatrix
integer, dimension(:), allocatable :: NtwinMax, & integer, dimension(:), allocatable :: NtwinMax, &
NslipMax NslipMax
@ -1396,11 +1396,11 @@ function lattice_SchmidMatrix_slip(Nslip,lattice,cOverA) result(SchmidMatrix)
integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol)
real(pReal), intent(in) :: cOverA real(pREAL), intent(in) :: cOverA
real(pReal), dimension(3,3,sum(Nslip)) :: SchmidMatrix real(pREAL), dimension(3,3,sum(Nslip)) :: SchmidMatrix
real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem real(pREAL), dimension(3,3,sum(Nslip)) :: coordinateSystem
real(pReal), dimension(:,:), allocatable :: slipSystems real(pREAL), dimension(:,:), allocatable :: slipSystems
integer, dimension(:), allocatable :: NslipMax integer, dimension(:), allocatable :: NslipMax
integer :: i integer :: i
@ -1446,11 +1446,11 @@ function lattice_SchmidMatrix_twin(Ntwin,lattice,cOverA) result(SchmidMatrix)
integer, dimension(:), intent(in) :: Ntwin !< number of active twin systems per family integer, dimension(:), intent(in) :: Ntwin !< number of active twin systems per family
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol)
real(pReal), intent(in) :: cOverA !< c/a ratio real(pREAL), intent(in) :: cOverA !< c/a ratio
real(pReal), dimension(3,3,sum(Ntwin)) :: SchmidMatrix real(pREAL), dimension(3,3,sum(Ntwin)) :: SchmidMatrix
real(pReal), dimension(3,3,sum(Ntwin)) :: coordinateSystem real(pREAL), dimension(3,3,sum(Ntwin)) :: coordinateSystem
real(pReal), dimension(:,:), allocatable :: twinSystems real(pREAL), dimension(:,:), allocatable :: twinSystems
integer, dimension(:), allocatable :: NtwinMax integer, dimension(:), allocatable :: NtwinMax
integer :: i integer :: i
@ -1493,18 +1493,18 @@ function lattice_SchmidMatrix_trans(Ntrans,lattice_target,cOverA,a_cF,a_cI) resu
integer, dimension(:), intent(in) :: Ntrans !< number of active twin systems per family integer, dimension(:), intent(in) :: Ntrans !< number of active twin systems per family
character(len=*), intent(in) :: lattice_target !< Bravais lattice (Pearson symbol) character(len=*), intent(in) :: lattice_target !< Bravais lattice (Pearson symbol)
real(pReal), optional, intent(in) :: cOverA, a_cI, a_cF real(pREAL), optional, intent(in) :: cOverA, a_cI, a_cF
real(pReal), dimension(3,3,sum(Ntrans)) :: SchmidMatrix real(pREAL), dimension(3,3,sum(Ntrans)) :: SchmidMatrix
real(pReal), dimension(3,3,sum(Ntrans)) :: devNull real(pREAL), dimension(3,3,sum(Ntrans)) :: devNull
if (lattice_target == 'hP' .and. present(cOverA)) then if (lattice_target == 'hP' .and. present(cOverA)) then
if (cOverA < 1.0_pReal .or. cOverA > 2.0_pReal) & if (cOverA < 1.0_pREAL .or. cOverA > 2.0_pREAL) &
call IO_error(131,ext_msg='lattice_SchmidMatrix_trans: '//trim(lattice_target)) call IO_error(131,ext_msg='lattice_SchmidMatrix_trans: '//trim(lattice_target))
call buildTransformationSystem(devNull,SchmidMatrix,Ntrans,cOverA=cOverA) call buildTransformationSystem(devNull,SchmidMatrix,Ntrans,cOverA=cOverA)
else if (lattice_target == 'cI' .and. present(a_cF) .and. present(a_cI)) then else if (lattice_target == 'cI' .and. present(a_cF) .and. present(a_cI)) then
if (a_cI <= 0.0_pReal .or. a_cF <= 0.0_pReal) & if (a_cI <= 0.0_pREAL .or. a_cF <= 0.0_pREAL) &
call IO_error(134,ext_msg='lattice_SchmidMatrix_trans: '//trim(lattice_target)) call IO_error(134,ext_msg='lattice_SchmidMatrix_trans: '//trim(lattice_target))
call buildTransformationSystem(devNull,SchmidMatrix,Ntrans,a_cF=a_cF,a_cI=a_cI) call buildTransformationSystem(devNull,SchmidMatrix,Ntrans,a_cF=a_cF,a_cI=a_cI)
else else
@ -1522,11 +1522,11 @@ function lattice_SchmidMatrix_cleavage(Ncleavage,lattice,cOverA) result(SchmidMa
integer, dimension(:), intent(in) :: Ncleavage !< number of active cleavage systems per family integer, dimension(:), intent(in) :: Ncleavage !< number of active cleavage systems per family
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol)
real(pReal), intent(in) :: cOverA !< c/a ratio real(pREAL), intent(in) :: cOverA !< c/a ratio
real(pReal), dimension(3,3,3,sum(Ncleavage)) :: SchmidMatrix real(pREAL), dimension(3,3,3,sum(Ncleavage)) :: SchmidMatrix
real(pReal), dimension(3,3,sum(Ncleavage)) :: coordinateSystem real(pREAL), dimension(3,3,sum(Ncleavage)) :: coordinateSystem
real(pReal), dimension(:,:), allocatable :: cleavageSystems real(pREAL), dimension(:,:), allocatable :: cleavageSystems
integer, dimension(:), allocatable :: NcleavageMax integer, dimension(:), allocatable :: NcleavageMax
integer :: i integer :: i
@ -1565,10 +1565,10 @@ function lattice_slip_direction(Nslip,lattice,cOverA) result(d)
integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol)
real(pReal), intent(in) :: cOverA !< c/a ratio real(pREAL), intent(in) :: cOverA !< c/a ratio
real(pReal), dimension(3,sum(Nslip)) :: d real(pREAL), dimension(3,sum(Nslip)) :: d
real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem real(pREAL), dimension(3,3,sum(Nslip)) :: coordinateSystem
coordinateSystem = coordinateSystem_slip(Nslip,lattice,cOverA) coordinateSystem = coordinateSystem_slip(Nslip,lattice,cOverA)
d = coordinateSystem(1:3,1,1:sum(Nslip)) d = coordinateSystem(1:3,1,1:sum(Nslip))
@ -1583,10 +1583,10 @@ function lattice_slip_normal(Nslip,lattice,cOverA) result(n)
integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol)
real(pReal), intent(in) :: cOverA !< c/a ratio real(pREAL), intent(in) :: cOverA !< c/a ratio
real(pReal), dimension(3,sum(Nslip)) :: n real(pREAL), dimension(3,sum(Nslip)) :: n
real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem real(pREAL), dimension(3,3,sum(Nslip)) :: coordinateSystem
coordinateSystem = coordinateSystem_slip(Nslip,lattice,cOverA) coordinateSystem = coordinateSystem_slip(Nslip,lattice,cOverA)
n = coordinateSystem(1:3,2,1:sum(Nslip)) n = coordinateSystem(1:3,2,1:sum(Nslip))
@ -1601,10 +1601,10 @@ function lattice_slip_transverse(Nslip,lattice,cOverA) result(t)
integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol)
real(pReal), intent(in) :: cOverA !< c/a ratio real(pREAL), intent(in) :: cOverA !< c/a ratio
real(pReal), dimension(3,sum(Nslip)) :: t real(pREAL), dimension(3,sum(Nslip)) :: t
real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem real(pREAL), dimension(3,3,sum(Nslip)) :: coordinateSystem
coordinateSystem = coordinateSystem_slip(Nslip,lattice,cOverA) coordinateSystem = coordinateSystem_slip(Nslip,lattice,cOverA)
t = coordinateSystem(1:3,3,1:sum(Nslip)) t = coordinateSystem(1:3,3,1:sum(Nslip))
@ -1623,7 +1623,7 @@ function lattice_labels_slip(Nslip,lattice) result(labels)
character(len=:), dimension(:), allocatable :: labels character(len=:), dimension(:), allocatable :: labels
real(pReal), dimension(:,:), allocatable :: slipSystems real(pREAL), dimension(:,:), allocatable :: slipSystems
integer, dimension(:), allocatable :: NslipMax integer, dimension(:), allocatable :: NslipMax
select case(lattice) select case(lattice)
@ -1658,13 +1658,13 @@ end function lattice_labels_slip
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function lattice_symmetrize_33(T,lattice) result(T_sym) pure function lattice_symmetrize_33(T,lattice) result(T_sym)
real(pReal), dimension(3,3) :: T_sym real(pREAL), dimension(3,3) :: T_sym
real(pReal), dimension(3,3), intent(in) :: T real(pREAL), dimension(3,3), intent(in) :: T
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol)
T_sym = 0.0_pReal T_sym = 0.0_pREAL
select case(lattice) select case(lattice)
case('cF','cI') case('cF','cI')
@ -1686,15 +1686,15 @@ end function lattice_symmetrize_33
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function lattice_symmetrize_C66(C66,lattice) result(C66_sym) pure function lattice_symmetrize_C66(C66,lattice) result(C66_sym)
real(pReal), dimension(6,6) :: C66_sym real(pREAL), dimension(6,6) :: C66_sym
real(pReal), dimension(6,6), intent(in) :: C66 real(pREAL), dimension(6,6), intent(in) :: C66
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol)
integer :: i,j integer :: i,j
C66_sym = 0.0_pReal C66_sym = 0.0_pREAL
select case(lattice) select case(lattice)
case ('cF','cI') case ('cF','cI')
@ -1707,7 +1707,7 @@ pure function lattice_symmetrize_C66(C66,lattice) result(C66_sym)
C66_sym(1,2) = C66(1,2) C66_sym(1,2) = C66(1,2)
C66_sym(1,3) = C66(1,3); C66_sym(2,3) = C66(1,3) C66_sym(1,3) = C66(1,3); C66_sym(2,3) = C66(1,3)
C66_sym(4,4) = C66(4,4); C66_sym(5,5) = C66(4,4) C66_sym(4,4) = C66(4,4); C66_sym(5,5) = C66(4,4)
C66_sym(6,6) = 0.5_pReal*(C66(1,1)-C66(1,2)) C66_sym(6,6) = 0.5_pREAL*(C66(1,1)-C66(1,2))
case ('tI') case ('tI')
C66_sym(1,1) = C66(1,1); C66_sym(2,2) = C66(1,1) C66_sym(1,1) = C66(1,1); C66_sym(2,2) = C66(1,1)
C66_sym(3,3) = C66(3,3) C66_sym(3,3) = C66(3,3)
@ -1737,7 +1737,7 @@ function lattice_labels_twin(Ntwin,lattice) result(labels)
character(len=:), dimension(:), allocatable :: labels character(len=:), dimension(:), allocatable :: labels
real(pReal), dimension(:,:), allocatable :: twinSystems real(pREAL), dimension(:,:), allocatable :: twinSystems
integer, dimension(:), allocatable :: NtwinMax integer, dimension(:), allocatable :: NtwinMax
select case(lattice) select case(lattice)
@ -1772,10 +1772,10 @@ function slipProjection_transverse(Nslip,lattice,cOverA) result(projection)
integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol)
real(pReal), intent(in) :: cOverA !< c/a ratio real(pREAL), intent(in) :: cOverA !< c/a ratio
real(pReal), dimension(sum(Nslip),sum(Nslip)) :: projection real(pREAL), dimension(sum(Nslip),sum(Nslip)) :: projection
real(pReal), dimension(3,sum(Nslip)) :: n, t real(pREAL), dimension(3,sum(Nslip)) :: n, t
integer :: i, j integer :: i, j
n = lattice_slip_normal (Nslip,lattice,cOverA) n = lattice_slip_normal (Nslip,lattice,cOverA)
@ -1796,10 +1796,10 @@ function slipProjection_direction(Nslip,lattice,cOverA) result(projection)
integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol)
real(pReal), intent(in) :: cOverA !< c/a ratio real(pREAL), intent(in) :: cOverA !< c/a ratio
real(pReal), dimension(sum(Nslip),sum(Nslip)) :: projection real(pREAL), dimension(sum(Nslip),sum(Nslip)) :: projection
real(pReal), dimension(3,sum(Nslip)) :: n, d real(pREAL), dimension(3,sum(Nslip)) :: n, d
integer :: i, j integer :: i, j
n = lattice_slip_normal (Nslip,lattice,cOverA) n = lattice_slip_normal (Nslip,lattice,cOverA)
@ -1820,10 +1820,10 @@ function coordinateSystem_slip(Nslip,lattice,cOverA) result(coordinateSystem)
integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol) character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol)
real(pReal), intent(in) :: cOverA !< c/a ratio real(pREAL), intent(in) :: cOverA !< c/a ratio
real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem real(pREAL), dimension(3,3,sum(Nslip)) :: coordinateSystem
real(pReal), dimension(:,:), allocatable :: slipSystems real(pREAL), dimension(:,:), allocatable :: slipSystems
integer, dimension(:), allocatable :: NslipMax integer, dimension(:), allocatable :: NslipMax
select case(lattice) select case(lattice)
@ -1864,9 +1864,9 @@ function buildInteraction(reacting_used,acting_used,reacting_max,acting_max,valu
acting_used, & !< # of acting systems per family as specified in material.config acting_used, & !< # of acting systems per family as specified in material.config
reacting_max, & !< max # of reacting systems per family for given lattice reacting_max, & !< max # of reacting systems per family for given lattice
acting_max !< max # of acting systems per family for given lattice acting_max !< max # of acting systems per family for given lattice
real(pReal), dimension(:), intent(in) :: values !< interaction values real(pREAL), dimension(:), intent(in) :: values !< interaction values
integer, dimension(:,:), intent(in) :: matrix !< interaction types integer, dimension(:,:), intent(in) :: matrix !< interaction types
real(pReal), dimension(sum(reacting_used),sum(acting_used)) :: buildInteraction real(pREAL), dimension(sum(reacting_used),sum(acting_used)) :: buildInteraction
integer :: & integer :: &
acting_family_index, acting_family, acting_system, & acting_family_index, acting_family, acting_system, &
@ -1906,16 +1906,16 @@ function buildCoordinateSystem(active,potential,system,lattice,cOverA)
integer, dimension(:), intent(in) :: & integer, dimension(:), intent(in) :: &
active, & !< # of active systems per family active, & !< # of active systems per family
potential !< # of potential systems per family potential !< # of potential systems per family
real(pReal), dimension(:,:), intent(in) :: & real(pREAL), dimension(:,:), intent(in) :: &
system system
character(len=*), intent(in) :: & character(len=*), intent(in) :: &
lattice !< Bravais lattice (Pearson symbol) lattice !< Bravais lattice (Pearson symbol)
real(pReal), intent(in) :: & real(pREAL), intent(in) :: &
cOverA cOverA
real(pReal), dimension(3,3,sum(active)) :: & real(pREAL), dimension(3,3,sum(active)) :: &
buildCoordinateSystem buildCoordinateSystem
real(pReal), dimension(3) :: & real(pREAL), dimension(3) :: &
direction, normal direction, normal
integer :: & integer :: &
a, & !< index of active system a, & !< index of active system
@ -1923,9 +1923,9 @@ function buildCoordinateSystem(active,potential,system,lattice,cOverA)
f, & !< index of my family f, & !< index of my family
s !< index of my system in current family s !< index of my system in current family
if (lattice == 'tI' .and. cOverA > 2.0_pReal) & if (lattice == 'tI' .and. cOverA > 2.0_pREAL) &
call IO_error(131,ext_msg='buildCoordinateSystem:'//trim(lattice)) call IO_error(131,ext_msg='buildCoordinateSystem:'//trim(lattice))
if (lattice == 'hP' .and. (cOverA < 1.0_pReal .or. cOverA > 2.0_pReal)) & if (lattice == 'hP' .and. (cOverA < 1.0_pREAL .or. cOverA > 2.0_pREAL)) &
call IO_error(131,ext_msg='buildCoordinateSystem:'//trim(lattice)) call IO_error(131,ext_msg='buildCoordinateSystem:'//trim(lattice))
a = 0 a = 0
@ -1941,11 +1941,11 @@ function buildCoordinateSystem(active,potential,system,lattice,cOverA)
normal = system(4:6,p) normal = system(4:6,p)
case ('hP') case ('hP')
direction = [ system(1,p)*1.5_pReal, & direction = [ system(1,p)*1.5_pREAL, &
(system(1,p)+2.0_pReal*system(2,p))*sqrt(0.75_pReal), & (system(1,p)+2.0_pREAL*system(2,p))*sqrt(0.75_pREAL), &
system(4,p)*cOverA ] ! direction [uvtw]->[3u/2 (u+2v)*sqrt(3)/2 w*(p/a)]) system(4,p)*cOverA ] ! direction [uvtw]->[3u/2 (u+2v)*sqrt(3)/2 w*(p/a)])
normal = [ system(5,p), & normal = [ system(5,p), &
(system(5,p)+2.0_pReal*system(6,p))/sqrt(3.0_pReal), & (system(5,p)+2.0_pREAL*system(6,p))/sqrt(3.0_pREAL), &
system(8,p)/cOverA ] ! plane (hkil)->(h (h+2k)/sqrt(3) l/(p/a)) system(8,p)/cOverA ] ! plane (hkil)->(h (h+2k)/sqrt(3) l/(p/a))
case default case default
@ -1974,10 +1974,10 @@ subroutine buildTransformationSystem(Q,S,Ntrans,cOverA,a_cF,a_cI)
integer, dimension(:), intent(in) :: & integer, dimension(:), intent(in) :: &
Ntrans Ntrans
real(pReal), dimension(3,3,sum(Ntrans)), intent(out) :: & real(pREAL), dimension(3,3,sum(Ntrans)), intent(out) :: &
Q, & !< Total rotation: Q = R*B Q, & !< Total rotation: Q = R*B
S !< Eigendeformation tensor for phase transformation S !< Eigendeformation tensor for phase transformation
real(pReal), optional, intent(in) :: & real(pREAL), optional, intent(in) :: &
cOverA, & !< c/a for target hP lattice cOverA, & !< c/a for target hP lattice
a_cF, & !< lattice parameter a for cF target lattice a_cF, & !< lattice parameter a for cF target lattice
a_cI !< lattice parameter a for cI parent lattice a_cI !< lattice parameter a for cI parent lattice
@ -1985,14 +1985,14 @@ subroutine buildTransformationSystem(Q,S,Ntrans,cOverA,a_cF,a_cI)
type(tRotation) :: & type(tRotation) :: &
R, & !< Pitsch rotation R, & !< Pitsch rotation
B !< Rotation of cF to Bain coordinate system B !< Rotation of cF to Bain coordinate system
real(pReal), dimension(3,3) :: & real(pREAL), dimension(3,3) :: &
U, & !< Bain deformation U, & !< Bain deformation
ss, sd ss, sd
real(pReal), dimension(3) :: & real(pREAL), dimension(3) :: &
x, y, z x, y, z
integer :: & integer :: &
i i
real(pReal), dimension(3+3,CF_NTRANS), parameter :: & real(pREAL), dimension(3+3,CF_NTRANS), parameter :: &
CFTOHP_SYSTEMTRANS = reshape(real( [& CFTOHP_SYSTEMTRANS = reshape(real( [&
-2, 1, 1, 1, 1, 1, & -2, 1, 1, 1, 1, 1, &
1,-2, 1, 1, 1, 1, & 1,-2, 1, 1, 1, 1, &
@ -2006,9 +2006,9 @@ subroutine buildTransformationSystem(Q,S,Ntrans,cOverA,a_cF,a_cI)
2, 1,-1, -1, 1,-1, & 2, 1,-1, -1, 1,-1, &
-1,-2,-1, -1, 1,-1, & -1,-2,-1, -1, 1,-1, &
-1, 1, 2, -1, 1,-1 & -1, 1, 2, -1, 1,-1 &
],pReal),shape(CFTOHP_SYSTEMTRANS)) ],pREAL),shape(CFTOHP_SYSTEMTRANS))
real(pReal), dimension(4,cF_Ntrans), parameter :: & real(pREAL), dimension(4,cF_Ntrans), parameter :: &
CFTOCI_SYSTEMTRANS = real(reshape([& CFTOCI_SYSTEMTRANS = real(reshape([&
0.0, 1.0, 0.0, 10.26, & ! Pitsch OR (Ma & Hartmaier 2014, Table 3) 0.0, 1.0, 0.0, 10.26, & ! Pitsch OR (Ma & Hartmaier 2014, Table 3)
0.0,-1.0, 0.0, 10.26, & 0.0,-1.0, 0.0, 10.26, &
@ -2022,7 +2022,7 @@ subroutine buildTransformationSystem(Q,S,Ntrans,cOverA,a_cF,a_cI)
-1.0, 0.0, 0.0, 10.26, & -1.0, 0.0, 0.0, 10.26, &
0.0, 1.0, 0.0, 10.26, & 0.0, 1.0, 0.0, 10.26, &
0.0,-1.0, 0.0, 10.26 & 0.0,-1.0, 0.0, 10.26 &
],shape(CFTOCI_SYSTEMTRANS)),pReal) ],shape(CFTOCI_SYSTEMTRANS)),pREAL)
integer, dimension(9,cF_Ntrans), parameter :: & integer, dimension(9,cF_Ntrans), parameter :: &
CFTOCI_BAINVARIANT = reshape( [& CFTOCI_BAINVARIANT = reshape( [&
@ -2040,7 +2040,7 @@ subroutine buildTransformationSystem(Q,S,Ntrans,cOverA,a_cF,a_cI)
0, 0, 1, 1, 0, 0, 0, 1, 0 & 0, 0, 1, 1, 0, 0, 0, 1, 0 &
],shape(CFTOCI_BAINVARIANT)) ],shape(CFTOCI_BAINVARIANT))
real(pReal), dimension(4,cF_Ntrans), parameter :: & real(pREAL), dimension(4,cF_Ntrans), parameter :: &
CFTOCI_BAINROT = real(reshape([& CFTOCI_BAINROT = real(reshape([&
1.0, 0.0, 0.0, 45.0, & ! Rotate cF austensite to bain variant 1.0, 0.0, 0.0, 45.0, & ! Rotate cF austensite to bain variant
1.0, 0.0, 0.0, 45.0, & 1.0, 0.0, 0.0, 45.0, &
@ -2054,25 +2054,25 @@ subroutine buildTransformationSystem(Q,S,Ntrans,cOverA,a_cF,a_cI)
0.0, 0.0, 1.0, 45.0, & 0.0, 0.0, 1.0, 45.0, &
0.0, 0.0, 1.0, 45.0, & 0.0, 0.0, 1.0, 45.0, &
0.0, 0.0, 1.0, 45.0 & 0.0, 0.0, 1.0, 45.0 &
],shape(CFTOCI_BAINROT)),pReal) ],shape(CFTOCI_BAINROT)),pREAL)
if (present(a_cI) .and. present(a_cF)) then if (present(a_cI) .and. present(a_cF)) then
do i = 1,sum(Ntrans) do i = 1,sum(Ntrans)
call R%fromAxisAngle(CFTOCI_SYSTEMTRANS(:,i),degrees=.true.,P=1) call R%fromAxisAngle(CFTOCI_SYSTEMTRANS(:,i),degrees=.true.,P=1)
call B%fromAxisAngle(CFTOCI_BAINROT(:,i), degrees=.true.,P=1) call B%fromAxisAngle(CFTOCI_BAINROT(:,i), degrees=.true.,P=1)
x = real(CFTOCI_BAINVARIANT(1:3,i),pReal) x = real(CFTOCI_BAINVARIANT(1:3,i),pREAL)
y = real(CFTOCI_BAINVARIANT(4:6,i),pReal) y = real(CFTOCI_BAINVARIANT(4:6,i),pREAL)
z = real(CFTOCI_BAINVARIANT(7:9,i),pReal) z = real(CFTOCI_BAINVARIANT(7:9,i),pREAL)
U = (a_cI/a_cF) * (math_outer(x,x) + (math_outer(y,y)+math_outer(z,z)) * sqrt(2.0_pReal)) U = (a_cI/a_cF) * (math_outer(x,x) + (math_outer(y,y)+math_outer(z,z)) * sqrt(2.0_pREAL))
Q(1:3,1:3,i) = matmul(R%asMatrix(),B%asMatrix()) Q(1:3,1:3,i) = matmul(R%asMatrix(),B%asMatrix())
S(1:3,1:3,i) = matmul(R%asMatrix(),U) - MATH_I3 S(1:3,1:3,i) = matmul(R%asMatrix(),U) - MATH_I3
end do end do
else if (present(cOverA)) then else if (present(cOverA)) then
ss = MATH_I3 ss = MATH_I3
sd = MATH_I3 sd = MATH_I3
ss(1,3) = sqrt(2.0_pReal)/4.0_pReal ss(1,3) = sqrt(2.0_pREAL)/4.0_pREAL
sd(3,3) = cOverA/sqrt(8.0_pReal/3.0_pReal) sd(3,3) = cOverA/sqrt(8.0_pREAL/3.0_pREAL)
do i = 1,sum(Ntrans) do i = 1,sum(Ntrans)
x = CFTOHP_SYSTEMTRANS(1:3,i)/norm2(CFTOHP_SYSTEMTRANS(1:3,i)) x = CFTOHP_SYSTEMTRANS(1:3,i)/norm2(CFTOHP_SYSTEMTRANS(1:3,i))
@ -2098,7 +2098,7 @@ function getlabels(active,potential,system) result(labels)
integer, dimension(:), intent(in) :: & integer, dimension(:), intent(in) :: &
active, & !< # of active systems per family active, & !< # of active systems per family
potential !< # of potential systems per family potential !< # of potential systems per family
real(pReal), dimension(:,:), intent(in) :: & real(pREAL), dimension(:,:), intent(in) :: &
system system
character(len=:), dimension(:), allocatable :: labels character(len=:), dimension(:), allocatable :: labels
@ -2152,28 +2152,28 @@ end function getlabels
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function lattice_isotropic_nu(C,assumption,lattice) result(nu) pure function lattice_isotropic_nu(C,assumption,lattice) result(nu)
real(pReal), dimension(6,6), intent(in) :: C !< Stiffness tensor (Voigt notation) real(pREAL), dimension(6,6), intent(in) :: C !< Stiffness tensor (Voigt notation)
character(len=*), intent(in) :: assumption !< Assumption (isostrain = 'Voigt', isostress = 'Reuss') character(len=*), intent(in) :: assumption !< Assumption (isostrain = 'Voigt', isostress = 'Reuss')
character(len=*), optional, intent(in) :: lattice character(len=*), optional, intent(in) :: lattice
real(pReal) :: nu real(pREAL) :: nu
real(pReal) :: K, mu real(pREAL) :: K, mu
logical :: error logical :: error
real(pReal), dimension(6,6) :: S real(pREAL), dimension(6,6) :: S
if (IO_lc(assumption) == 'isostrain') then if (IO_lc(assumption) == 'isostrain') then
K = sum(C(1:3,1:3)) / 9.0_pReal K = sum(C(1:3,1:3)) / 9.0_pREAL
elseif (IO_lc(assumption) == 'isostress') then elseif (IO_lc(assumption) == 'isostress') then
call math_invert(S,error,C) call math_invert(S,error,C)
if (error) error stop 'matrix inversion failed' if (error) error stop 'matrix inversion failed'
K = 1.0_pReal / sum(S(1:3,1:3)) K = 1.0_pREAL / sum(S(1:3,1:3))
else else
error stop 'invalid assumption' error stop 'invalid assumption'
end if end if
mu = lattice_isotropic_mu(C,assumption,lattice) mu = lattice_isotropic_mu(C,assumption,lattice)
nu = (1.5_pReal*K-mu)/(3.0_pReal*K+mu) nu = (1.5_pREAL*K-mu)/(3.0_pREAL*K+mu)
end function lattice_isotropic_nu end function lattice_isotropic_nu
@ -2185,36 +2185,36 @@ end function lattice_isotropic_nu
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function lattice_isotropic_mu(C,assumption,lattice) result(mu) pure function lattice_isotropic_mu(C,assumption,lattice) result(mu)
real(pReal), dimension(6,6), intent(in) :: C !< Stiffness tensor (Voigt notation) real(pREAL), dimension(6,6), intent(in) :: C !< Stiffness tensor (Voigt notation)
character(len=*), intent(in) :: assumption !< Assumption (isostrain = 'Voigt', isostress = 'Reuss') character(len=*), intent(in) :: assumption !< Assumption (isostrain = 'Voigt', isostress = 'Reuss')
character(len=*), optional, intent(in) :: lattice character(len=*), optional, intent(in) :: lattice
real(pReal) :: mu real(pREAL) :: mu
logical :: error logical :: error
real(pReal), dimension(6,6) :: S real(pREAL), dimension(6,6) :: S
if (IO_lc(assumption) == 'isostrain') then if (IO_lc(assumption) == 'isostrain') then
select case(misc_optional(lattice,'')) select case(misc_optional(lattice,''))
case('cF','cI') case('cF','cI')
mu = ( C(1,1) - C(1,2) + C(4,4)*3.0_pReal) / 5.0_pReal mu = ( C(1,1) - C(1,2) + C(4,4)*3.0_pREAL) / 5.0_pREAL
case default case default
mu = ( C(1,1)+C(2,2)+C(3,3) & mu = ( C(1,1)+C(2,2)+C(3,3) &
- C(1,2)-C(2,3)-C(1,3) & - C(1,2)-C(2,3)-C(1,3) &
+(C(4,4)+C(5,5)+C(6,6)) * 3.0_pReal & +(C(4,4)+C(5,5)+C(6,6)) * 3.0_pREAL &
) / 15.0_pReal ) / 15.0_pREAL
end select end select
elseif (IO_lc(assumption) == 'isostress') then elseif (IO_lc(assumption) == 'isostress') then
select case(misc_optional(lattice,'')) select case(misc_optional(lattice,''))
case('cF','cI') case('cF','cI')
mu = 5.0_pReal & mu = 5.0_pREAL &
/ (4.0_pReal/(C(1,1)-C(1,2)) + 3.0_pReal/C(4,4)) / (4.0_pREAL/(C(1,1)-C(1,2)) + 3.0_pREAL/C(4,4))
case default case default
call math_invert(S,error,C) call math_invert(S,error,C)
if (error) error stop 'matrix inversion failed' if (error) error stop 'matrix inversion failed'
mu = 15.0_pReal & mu = 15.0_pREAL &
/ (4.0_pReal*(S(1,1)+S(2,2)+S(3,3)-S(1,2)-S(2,3)-S(1,3)) + 3.0_pReal*(S(4,4)+S(5,5)+S(6,6))) / (4.0_pREAL*(S(1,1)+S(2,2)+S(3,3)-S(1,2)-S(2,3)-S(1,3)) + 3.0_pREAL*(S(4,4)+S(5,5)+S(6,6)))
end select end select
else else
error stop 'invalid assumption' error stop 'invalid assumption'
@ -2228,20 +2228,20 @@ end function lattice_isotropic_mu
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine selfTest subroutine selfTest
real(pReal), dimension(:,:,:), allocatable :: CoSy real(pREAL), dimension(:,:,:), allocatable :: CoSy
real(pReal), dimension(:,:), allocatable :: system real(pREAL), dimension(:,:), allocatable :: system
real(pReal), dimension(6,6) :: C, C_cF, C_cI, C_hP, C_tI real(pREAL), dimension(6,6) :: C, C_cF, C_cI, C_hP, C_tI
real(pReal), dimension(3,3) :: T, T_cF, T_cI, T_hP, T_tI real(pREAL), dimension(3,3) :: T, T_cF, T_cI, T_hP, T_tI
real(pReal), dimension(2) :: r real(pREAL), dimension(2) :: r
real(pReal) :: lambda real(pREAL) :: lambda
integer :: i integer :: i
call random_number(r) call random_number(r)
system = reshape([1.0_pReal+r(1),0.0_pReal,0.0_pReal, 0.0_pReal,1.0_pReal+r(2),0.0_pReal],[6,1]) system = reshape([1.0_pREAL+r(1),0.0_pREAL,0.0_pREAL, 0.0_pREAL,1.0_pREAL+r(2),0.0_pREAL],[6,1])
CoSy = buildCoordinateSystem([1],[1],system,'cF',0.0_pReal) CoSy = buildCoordinateSystem([1],[1],system,'cF',0.0_pREAL)
if (any(dNeq(CoSy(1:3,1:3,1),math_I3))) error stop 'buildCoordinateSystem' if (any(dNeq(CoSy(1:3,1:3,1),math_I3))) error stop 'buildCoordinateSystem'
do i = 1, 10 do i = 1, 10
@ -2274,9 +2274,9 @@ subroutine selfTest
T_hP = lattice_symmetrize_33(T,'hP') T_hP = lattice_symmetrize_33(T,'hP')
T_tI = lattice_symmetrize_33(T,'tI') T_tI = lattice_symmetrize_33(T,'tI')
if (any(dNeq0(T_cF) .and. math_I3<1.0_pReal)) error stop 'Symmetry33/c' if (any(dNeq0(T_cF) .and. math_I3<1.0_pREAL)) error stop 'Symmetry33/c'
if (any(dNeq0(T_hP) .and. math_I3<1.0_pReal)) error stop 'Symmetry33/hP' if (any(dNeq0(T_hP) .and. math_I3<1.0_pREAL)) error stop 'Symmetry33/hP'
if (any(dNeq0(T_tI) .and. math_I3<1.0_pReal)) error stop 'Symmetry33/tI' if (any(dNeq0(T_tI) .and. math_I3<1.0_pREAL)) error stop 'Symmetry33/tI'
if (any(dNeq(T(1,1),[T_cI(1,1),T_cI(2,2),T_cI(3,3)]))) error stop 'Symmetry33_11-22-33/c' if (any(dNeq(T(1,1),[T_cI(1,1),T_cI(2,2),T_cI(3,3)]))) error stop 'Symmetry33_11-22-33/c'
if (any(dNeq(T(1,1),[T_hP(1,1),T_hP(2,2)]))) error stop 'Symmetry33_11-22/hP' if (any(dNeq(T(1,1),[T_hP(1,1),T_hP(2,2)]))) error stop 'Symmetry33_11-22/hP'
@ -2285,52 +2285,52 @@ subroutine selfTest
end do end do
call random_number(C) call random_number(C)
C(1,1) = C(1,1) + C(1,2) + 0.1_pReal C(1,1) = C(1,1) + C(1,2) + 0.1_pREAL
C(1,3) = C(1,2) C(1,3) = C(1,2)
C(3,3) = C(1,1) C(3,3) = C(1,1)
C(4,4) = 0.5_pReal * (C(1,1) - C(1,2)) C(4,4) = 0.5_pREAL * (C(1,1) - C(1,2))
C(6,6) = C(4,4) C(6,6) = C(4,4)
C_cI = lattice_symmetrize_C66(C,'cI') C_cI = lattice_symmetrize_C66(C,'cI')
if (dNeq(C_cI(4,4),lattice_isotropic_mu(C_cI,'isostrain','cI'),1.0e-12_pReal)) error stop 'isotropic_mu/isostrain/cI' if (dNeq(C_cI(4,4),lattice_isotropic_mu(C_cI,'isostrain','cI'),1.0e-12_pREAL)) error stop 'isotropic_mu/isostrain/cI'
if (dNeq(C_cI(4,4),lattice_isotropic_mu(C_cI,'isostress','cI'),1.0e-12_pReal)) error stop 'isotropic_mu/isostress/cI' if (dNeq(C_cI(4,4),lattice_isotropic_mu(C_cI,'isostress','cI'),1.0e-12_pREAL)) error stop 'isotropic_mu/isostress/cI'
lambda = C_cI(1,2) lambda = C_cI(1,2)
if (dNeq(lambda*0.5_pReal/(lambda+lattice_isotropic_mu(C_cI,'isostrain','cI')), & if (dNeq(lambda*0.5_pREAL/(lambda+lattice_isotropic_mu(C_cI,'isostrain','cI')), &
lattice_isotropic_nu(C_cI,'isostrain','cI'),1.0e-12_pReal)) error stop 'isotropic_nu/isostrain/cI' lattice_isotropic_nu(C_cI,'isostrain','cI'),1.0e-12_pREAL)) error stop 'isotropic_nu/isostrain/cI'
if (dNeq(lambda*0.5_pReal/(lambda+lattice_isotropic_mu(C_cI,'isostress','cI')), & if (dNeq(lambda*0.5_pREAL/(lambda+lattice_isotropic_mu(C_cI,'isostress','cI')), &
lattice_isotropic_nu(C_cI,'isostress','cI'),1.0e-12_pReal)) error stop 'isotropic_nu/isostress/cI' lattice_isotropic_nu(C_cI,'isostress','cI'),1.0e-12_pREAL)) error stop 'isotropic_nu/isostress/cI'
C_hP = lattice_symmetrize_C66(C,'hP') C_hP = lattice_symmetrize_C66(C,'hP')
if (dNeq(C(4,4),lattice_isotropic_mu(C_hP,'isostrain','hP'),1.0e-12_pReal)) error stop 'isotropic_mu/isostrain/hP' if (dNeq(C(4,4),lattice_isotropic_mu(C_hP,'isostrain','hP'),1.0e-12_pREAL)) error stop 'isotropic_mu/isostrain/hP'
if (dNeq(C(4,4),lattice_isotropic_mu(C_hP,'isostress','hP'),1.0e-12_pReal)) error stop 'isotropic_mu/isostress/hP' if (dNeq(C(4,4),lattice_isotropic_mu(C_hP,'isostress','hP'),1.0e-12_pREAL)) error stop 'isotropic_mu/isostress/hP'
lambda = C_hP(1,2) lambda = C_hP(1,2)
if (dNeq(lambda*0.5_pReal/(lambda+lattice_isotropic_mu(C_hP,'isostrain','hP')), & if (dNeq(lambda*0.5_pREAL/(lambda+lattice_isotropic_mu(C_hP,'isostrain','hP')), &
lattice_isotropic_nu(C_hP,'isostrain','hP'),1.0e-12_pReal)) error stop 'isotropic_nu/isostrain/hP' lattice_isotropic_nu(C_hP,'isostrain','hP'),1.0e-12_pREAL)) error stop 'isotropic_nu/isostrain/hP'
if (dNeq(lambda*0.5_pReal/(lambda+lattice_isotropic_mu(C_hP,'isostress','hP')), & if (dNeq(lambda*0.5_pREAL/(lambda+lattice_isotropic_mu(C_hP,'isostress','hP')), &
lattice_isotropic_nu(C_hP,'isostress','hP'),1.0e-12_pReal)) error stop 'isotropic_nu/isostress/hP' lattice_isotropic_nu(C_hP,'isostress','hP'),1.0e-12_pREAL)) error stop 'isotropic_nu/isostress/hP'
C_tI = lattice_symmetrize_C66(C,'tI') C_tI = lattice_symmetrize_C66(C,'tI')
if (dNeq(C(6,6),lattice_isotropic_mu(C_tI,'isostrain','tI'),1.0e-12_pReal)) error stop 'isotropic_mu/isostrain/tI' if (dNeq(C(6,6),lattice_isotropic_mu(C_tI,'isostrain','tI'),1.0e-12_pREAL)) error stop 'isotropic_mu/isostrain/tI'
if (dNeq(C(6,6),lattice_isotropic_mu(C_tI,'isostress','tI'),1.0e-12_pReal)) error stop 'isotropic_mu/isostress/tI' if (dNeq(C(6,6),lattice_isotropic_mu(C_tI,'isostress','tI'),1.0e-12_pREAL)) error stop 'isotropic_mu/isostress/tI'
lambda = C_tI(1,2) lambda = C_tI(1,2)
if (dNeq(lambda*0.5_pReal/(lambda+lattice_isotropic_mu(C_tI,'isostrain','tI')), & if (dNeq(lambda*0.5_pREAL/(lambda+lattice_isotropic_mu(C_tI,'isostrain','tI')), &
lattice_isotropic_nu(C_tI,'isostrain','tI'),1.0e-12_pReal)) error stop 'isotropic_nu/isostrain/tI' lattice_isotropic_nu(C_tI,'isostrain','tI'),1.0e-12_pREAL)) error stop 'isotropic_nu/isostrain/tI'
if (dNeq(lambda*0.5_pReal/(lambda+lattice_isotropic_mu(C_tI,'isostress','tI')), & if (dNeq(lambda*0.5_pREAL/(lambda+lattice_isotropic_mu(C_tI,'isostress','tI')), &
lattice_isotropic_nu(C_tI,'isostress','tI'),1.0e-12_pReal)) error stop 'isotropic_nu/isostress/tI' lattice_isotropic_nu(C_tI,'isostress','tI'),1.0e-12_pREAL)) error stop 'isotropic_nu/isostress/tI'
call random_number(C) call random_number(C)
C = lattice_symmetrize_C66(C+math_eye(6),'cI') C = lattice_symmetrize_C66(C+math_eye(6),'cI')
if (dNeq(lattice_isotropic_mu(C,'isostrain','cI'), lattice_isotropic_mu(C,'isostrain','hP'), 1.0e-12_pReal)) & if (dNeq(lattice_isotropic_mu(C,'isostrain','cI'), lattice_isotropic_mu(C,'isostrain','hP'), 1.0e-12_pREAL)) &
error stop 'isotropic_mu/isostrain/cI-hP' error stop 'isotropic_mu/isostrain/cI-hP'
if (dNeq(lattice_isotropic_nu(C,'isostrain','cF'), lattice_isotropic_nu(C,'isostrain','cI'), 1.0e-12_pReal)) & if (dNeq(lattice_isotropic_nu(C,'isostrain','cF'), lattice_isotropic_nu(C,'isostrain','cI'), 1.0e-12_pREAL)) &
error stop 'isotropic_nu/isostrain/cF-tI' error stop 'isotropic_nu/isostrain/cF-tI'
if (dNeq(lattice_isotropic_mu(C,'isostress','cI'), lattice_isotropic_mu(C,'isostress'), 1.0e-12_pReal)) & if (dNeq(lattice_isotropic_mu(C,'isostress','cI'), lattice_isotropic_mu(C,'isostress'), 1.0e-12_pREAL)) &
error stop 'isotropic_mu/isostress/cI-hP' error stop 'isotropic_mu/isostress/cI-hP'
if (dNeq(lattice_isotropic_nu(C,'isostress','cF'), lattice_isotropic_nu(C,'isostress'), 1.0e-12_pReal)) & if (dNeq(lattice_isotropic_nu(C,'isostress','cF'), lattice_isotropic_nu(C,'isostress'), 1.0e-12_pREAL)) &
error stop 'isotropic_nu/isostress/cF-tI' error stop 'isotropic_nu/isostress/cF-tI'
end subroutine selfTest end subroutine selfTest

14
src/material.f90
View File

@ -22,7 +22,7 @@ module material
end type tRotationContainer end type tRotationContainer
type, public :: tTensorContainer type, public :: tTensorContainer
real(pReal), dimension(:,:,:), allocatable :: data real(pREAL), dimension(:,:,:), allocatable :: data
end type tTensorContainer end type tTensorContainer
@ -45,7 +45,7 @@ module material
material_ID_phase, & !< Number of the phase material_ID_phase, & !< Number of the phase
material_entry_phase !< Position in array of used phase material_entry_phase !< Position in array of used phase
real(pReal), dimension(:,:), allocatable, public, protected :: & real(pREAL), dimension(:,:), allocatable, public, protected :: &
material_v ! fraction material_v ! fraction
public :: & public :: &
@ -97,9 +97,9 @@ subroutine parse()
counterHomogenization, & counterHomogenization, &
ho_of ho_of
integer, dimension(:,:), allocatable :: ph_of integer, dimension(:,:), allocatable :: ph_of
real(pReal), dimension(:,:), allocatable :: v_of real(pREAL), dimension(:,:), allocatable :: v_of
real(pReal) :: v real(pREAL) :: v
integer :: & integer :: &
el, ip, & el, ip, &
ho, ph, & ho, ph, &
@ -125,14 +125,14 @@ subroutine parse()
end do end do
homogenization_maxNconstituents = maxval(homogenization_Nconstituents) homogenization_maxNconstituents = maxval(homogenization_Nconstituents)
allocate(material_v(homogenization_maxNconstituents,discretization_Ncells),source=0.0_pReal) allocate(material_v(homogenization_maxNconstituents,discretization_Ncells),source=0.0_pREAL)
allocate(material_O_0(materials%length)) allocate(material_O_0(materials%length))
allocate(material_V_e_0(materials%length)) allocate(material_V_e_0(materials%length))
allocate(ho_of(materials%length)) allocate(ho_of(materials%length))
allocate(ph_of(materials%length,homogenization_maxNconstituents),source=-1) allocate(ph_of(materials%length,homogenization_maxNconstituents),source=-1)
allocate( v_of(materials%length,homogenization_maxNconstituents),source=0.0_pReal) allocate( v_of(materials%length,homogenization_maxNconstituents),source=0.0_pREAL)
! Parse YAML structure. Manual loop over linked list to have O(n) instead of O(n^2) complexity ! Parse YAML structure. Manual loop over linked list to have O(n) instead of O(n^2) complexity
item => materials%first item => materials%first
@ -158,7 +158,7 @@ subroutine parse()
call IO_error(147) call IO_error(147)
end do end do
if (dNeq(sum(v_of(ma,:)),1.0_pReal,1.e-9_pReal)) call IO_error(153,ext_msg='constituent') if (dNeq(sum(v_of(ma,:)),1.0_pREAL,1.e-9_pREAL)) call IO_error(153,ext_msg='constituent')
item => item%next item => item%next
end do end do

2
src/materialpoint.f90
View File

@ -141,7 +141,7 @@ end subroutine materialpoint_forward
subroutine materialpoint_result(inc,time) subroutine materialpoint_result(inc,time)
integer, intent(in) :: inc integer, intent(in) :: inc
real(pReal), intent(in) :: time real(pREAL), intent(in) :: time
call result_openJobFile() call result_openJobFile()
call result_addIncrement(inc,time) call result_addIncrement(inc,time)

448
src/math.f90
View File

@ -31,24 +31,24 @@ module math
config config
#endif #endif
real(pReal), parameter :: & real(pREAL), parameter :: &
PI = acos(-1.0_pReal), & !< ratio of a circle's circumference to its diameter PI = acos(-1.0_pREAL), & !< ratio of a circle's circumference to its diameter
TAU = 2.0_pReal*PI, & !< ratio of a circle's circumference to its radius TAU = 2.0_pREAL*PI, & !< ratio of a circle's circumference to its radius
INDEG = 360.0_pReal/TAU, & !< conversion from radian to degree INDEG = 360.0_pREAL/TAU, & !< conversion from radian to degree
INRAD = TAU/360.0_pReal !< conversion from degree to radian INRAD = TAU/360.0_pREAL !< conversion from degree to radian
real(pReal), dimension(3,3), parameter :: & real(pREAL), dimension(3,3), parameter :: &
math_I3 = reshape([& math_I3 = reshape([&
1.0_pReal,0.0_pReal,0.0_pReal, & 1.0_pREAL,0.0_pREAL,0.0_pREAL, &
0.0_pReal,1.0_pReal,0.0_pReal, & 0.0_pREAL,1.0_pREAL,0.0_pREAL, &
0.0_pReal,0.0_pReal,1.0_pReal & 0.0_pREAL,0.0_pREAL,1.0_pREAL &
],shape(math_I3)) !< 3x3 Identity ],shape(math_I3)) !< 3x3 Identity
real(pReal), dimension(*), parameter, private :: & real(pREAL), dimension(*), parameter, private :: &
NRMMANDEL = [1.0_pReal, 1.0_pReal,1.0_pReal, sqrt(2.0_pReal), sqrt(2.0_pReal), sqrt(2.0_pReal)] !< forward weighting for Mandel notation NRMMANDEL = [1.0_pREAL, 1.0_pREAL,1.0_pREAL, sqrt(2.0_pREAL), sqrt(2.0_pREAL), sqrt(2.0_pREAL)] !< forward weighting for Mandel notation
real(pReal), dimension(*), parameter, private :: & real(pREAL), dimension(*), parameter, private :: &
INVNRMMANDEL = 1.0_pReal/NRMMANDEL !< backward weighting for Mandel notation INVNRMMANDEL = 1.0_pREAL/NRMMANDEL !< backward weighting for Mandel notation
integer, dimension (2,6), parameter, private :: & integer, dimension (2,6), parameter, private :: &
MAPNYE = reshape([& MAPNYE = reshape([&
@ -94,7 +94,7 @@ contains
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine math_init() subroutine math_init()
real(pReal), dimension(4) :: randTest real(pREAL), dimension(4) :: randTest
integer :: randSize integer :: randSize
integer, dimension(:), allocatable :: seed integer, dimension(:), allocatable :: seed
type(tDict), pointer :: & type(tDict), pointer :: &
@ -201,9 +201,9 @@ end subroutine math_sort
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_expand(what,how) pure function math_expand(what,how)
real(pReal), dimension(:), intent(in) :: what real(pREAL), dimension(:), intent(in) :: what
integer, dimension(:), intent(in) :: how integer, dimension(:), intent(in) :: how
real(pReal), dimension(sum(how)) :: math_expand real(pREAL), dimension(sum(how)) :: math_expand
integer :: i integer :: i
@ -239,14 +239,14 @@ end function math_range
pure function math_eye(d) pure function math_eye(d)
integer, intent(in) :: d !< tensor dimension integer, intent(in) :: d !< tensor dimension
real(pReal), dimension(d,d) :: math_eye real(pREAL), dimension(d,d) :: math_eye
integer :: i integer :: i
math_eye = 0.0_pReal math_eye = 0.0_pREAL
do i=1,d do i=1,d
math_eye(i,i) = 1.0_pReal math_eye(i,i) = 1.0_pREAL
end do end do
end function math_eye end function math_eye
@ -258,18 +258,18 @@ end function math_eye
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_identity4th() pure function math_identity4th()
real(pReal), dimension(3,3,3,3) :: math_identity4th real(pREAL), dimension(3,3,3,3) :: math_identity4th
integer :: i,j,k,l integer :: i,j,k,l
#ifndef __INTEL_COMPILER #ifndef __INTEL_COMPILER
do concurrent(i=1:3, j=1:3, k=1:3, l=1:3) do concurrent(i=1:3, j=1:3, k=1:3, l=1:3)
math_identity4th(i,j,k,l) = 0.5_pReal*(math_I3(i,k)*math_I3(j,l)+math_I3(i,l)*math_I3(j,k)) math_identity4th(i,j,k,l) = 0.5_pREAL*(math_I3(i,k)*math_I3(j,l)+math_I3(i,l)*math_I3(j,k))
end do end do
#else #else
forall(i=1:3, j=1:3, k=1:3, l=1:3) & forall(i=1:3, j=1:3, k=1:3, l=1:3) &
math_identity4th(i,j,k,l) = 0.5_pReal*(math_I3(i,k)*math_I3(j,l)+math_I3(i,l)*math_I3(j,k)) math_identity4th(i,j,k,l) = 0.5_pREAL*(math_I3(i,k)*math_I3(j,l)+math_I3(i,l)*math_I3(j,k))
#endif #endif
end function math_identity4th end function math_identity4th
@ -281,7 +281,7 @@ end function math_identity4th
! e_ijk = -1 if odd permutation of ijk ! e_ijk = -1 if odd permutation of ijk
! e_ijk = 0 otherwise ! e_ijk = 0 otherwise
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
real(pReal) pure function math_LeviCivita(i,j,k) real(pREAL) pure function math_LeviCivita(i,j,k)
integer, intent(in) :: i,j,k integer, intent(in) :: i,j,k
@ -289,11 +289,11 @@ real(pReal) pure function math_LeviCivita(i,j,k)
if (any([(all(cshift([i,j,k],o) == [1,2,3]),o=0,2)])) then if (any([(all(cshift([i,j,k],o) == [1,2,3]),o=0,2)])) then
math_LeviCivita = +1.0_pReal math_LeviCivita = +1.0_pREAL
elseif (any([(all(cshift([i,j,k],o) == [3,2,1]),o=0,2)])) then elseif (any([(all(cshift([i,j,k],o) == [3,2,1]),o=0,2)])) then
math_LeviCivita = -1.0_pReal math_LeviCivita = -1.0_pREAL
else else
math_LeviCivita = 0.0_pReal math_LeviCivita = 0.0_pREAL
end if end if
end function math_LeviCivita end function math_LeviCivita
@ -304,12 +304,12 @@ end function math_LeviCivita
! d_ij = 1 if i = j ! d_ij = 1 if i = j
! d_ij = 0 otherwise ! d_ij = 0 otherwise
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
real(pReal) pure function math_delta(i,j) real(pREAL) pure function math_delta(i,j)
integer, intent (in) :: i,j integer, intent (in) :: i,j
math_delta = merge(0.0_pReal, 1.0_pReal, i /= j) math_delta = merge(0.0_pREAL, 1.0_pREAL, i /= j)
end function math_delta end function math_delta
@ -319,8 +319,8 @@ end function math_delta
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_cross(A,B) pure function math_cross(A,B)
real(pReal), dimension(3), intent(in) :: A,B real(pREAL), dimension(3), intent(in) :: A,B
real(pReal), dimension(3) :: math_cross real(pREAL), dimension(3) :: math_cross
math_cross = [ A(2)*B(3) -A(3)*B(2), & math_cross = [ A(2)*B(3) -A(3)*B(2), &
@ -335,8 +335,8 @@ end function math_cross
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_outer(A,B) pure function math_outer(A,B)
real(pReal), dimension(:), intent(in) :: A,B real(pREAL), dimension(:), intent(in) :: A,B
real(pReal), dimension(size(A,1),size(B,1)) :: math_outer real(pREAL), dimension(size(A,1),size(B,1)) :: math_outer
integer :: i,j integer :: i,j
@ -355,10 +355,10 @@ end function math_outer
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief inner product of arbitrary sized vectors (A · B / i,i) !> @brief inner product of arbitrary sized vectors (A · B / i,i)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
real(pReal) pure function math_inner(A,B) real(pREAL) pure function math_inner(A,B)
real(pReal), dimension(:), intent(in) :: A real(pREAL), dimension(:), intent(in) :: A
real(pReal), dimension(size(A,1)), intent(in) :: B real(pREAL), dimension(size(A,1)), intent(in) :: B
math_inner = sum(A*B) math_inner = sum(A*B)
@ -369,9 +369,9 @@ end function math_inner
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief double contraction of 3x3 matrices (A : B / ij,ij) !> @brief double contraction of 3x3 matrices (A : B / ij,ij)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
real(pReal) pure function math_tensordot(A,B) real(pREAL) pure function math_tensordot(A,B)
real(pReal), dimension(3,3), intent(in) :: A,B real(pREAL), dimension(3,3), intent(in) :: A,B
math_tensordot = sum(A*B) math_tensordot = sum(A*B)
@ -384,9 +384,9 @@ end function math_tensordot
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_mul3333xx33(A,B) pure function math_mul3333xx33(A,B)
real(pReal), dimension(3,3,3,3), intent(in) :: A real(pREAL), dimension(3,3,3,3), intent(in) :: A
real(pReal), dimension(3,3), intent(in) :: B real(pREAL), dimension(3,3), intent(in) :: B
real(pReal), dimension(3,3) :: math_mul3333xx33 real(pREAL), dimension(3,3) :: math_mul3333xx33
integer :: i,j integer :: i,j
@ -407,9 +407,9 @@ end function math_mul3333xx33
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_mul3333xx3333(A,B) pure function math_mul3333xx3333(A,B)
real(pReal), dimension(3,3,3,3), intent(in) :: A real(pREAL), dimension(3,3,3,3), intent(in) :: A
real(pReal), dimension(3,3,3,3), intent(in) :: B real(pREAL), dimension(3,3,3,3), intent(in) :: B
real(pReal), dimension(3,3,3,3) :: math_mul3333xx3333 real(pREAL), dimension(3,3,3,3) :: math_mul3333xx3333
integer :: i,j,k,l integer :: i,j,k,l
@ -430,20 +430,20 @@ end function math_mul3333xx3333
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_exp33(A,n) pure function math_exp33(A,n)
real(pReal), dimension(3,3), intent(in) :: A real(pREAL), dimension(3,3), intent(in) :: A
integer, intent(in), optional :: n integer, intent(in), optional :: n
real(pReal), dimension(3,3) :: B, math_exp33 real(pREAL), dimension(3,3) :: B, math_exp33
real(pReal) :: invFac real(pREAL) :: invFac
integer :: i integer :: i
invFac = 1.0_pReal ! 0! invFac = 1.0_pREAL ! 0!
B = math_I3 B = math_I3
math_exp33 = math_I3 ! A^0 = I math_exp33 = math_I3 ! A^0 = I
do i = 1, misc_optional(n,5) do i = 1, misc_optional(n,5)
invFac = invFac/real(i,pReal) ! invfac = 1/(i!) invFac = invFac/real(i,pREAL) ! invfac = 1/(i!)
B = matmul(B,A) B = matmul(B,A)
math_exp33 = math_exp33 + invFac*B ! exp = SUM (A^i)/(i!) math_exp33 = math_exp33 + invFac*B ! exp = SUM (A^i)/(i!)
end do end do
@ -458,15 +458,15 @@ end function math_exp33
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_inv33(A) pure function math_inv33(A)
real(pReal), dimension(3,3), intent(in) :: A real(pREAL), dimension(3,3), intent(in) :: A
real(pReal), dimension(3,3) :: math_inv33 real(pREAL), dimension(3,3) :: math_inv33
real(pReal) :: DetA real(pREAL) :: DetA
logical :: error logical :: error
call math_invert33(math_inv33,DetA,error,A) call math_invert33(math_inv33,DetA,error,A)
if (error) math_inv33 = 0.0_pReal if (error) math_inv33 = 0.0_pREAL
end function math_inv33 end function math_inv33
@ -478,12 +478,12 @@ end function math_inv33
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure subroutine math_invert33(InvA,DetA,error, A) pure subroutine math_invert33(InvA,DetA,error, A)
real(pReal), dimension(3,3), intent(out) :: InvA real(pREAL), dimension(3,3), intent(out) :: InvA
real(pReal), intent(out), optional :: DetA real(pREAL), intent(out), optional :: DetA
logical, intent(out) :: error logical, intent(out) :: error
real(pReal), dimension(3,3), intent(in) :: A real(pREAL), dimension(3,3), intent(in) :: A
real(pReal) :: Det real(pREAL) :: Det
InvA(1,1) = A(2,2) * A(3,3) - A(2,3) * A(3,2) InvA(1,1) = A(2,2) * A(3,3) - A(2,3) * A(3,2)
@ -493,8 +493,8 @@ pure subroutine math_invert33(InvA,DetA,error, A)
Det = A(1,1) * InvA(1,1) + A(1,2) * InvA(2,1) + A(1,3) * InvA(3,1) Det = A(1,1) * InvA(1,1) + A(1,2) * InvA(2,1) + A(1,3) * InvA(3,1)
if (dEq0(Det)) then if (dEq0(Det)) then
InvA = 0.0_pReal InvA = 0.0_pREAL
if (present(DetA)) DetA = 0.0_pReal if (present(DetA)) DetA = 0.0_pREAL
error = .true. error = .true.
else else
InvA(1,2) = -A(1,2) * A(3,3) + A(1,3) * A(3,2) InvA(1,2) = -A(1,2) * A(3,3) + A(1,3) * A(3,2)
@ -518,13 +518,13 @@ end subroutine math_invert33
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_invSym3333(A) pure function math_invSym3333(A)
real(pReal),dimension(3,3,3,3) :: math_invSym3333 real(pREAL),dimension(3,3,3,3) :: math_invSym3333
real(pReal),dimension(3,3,3,3),intent(in) :: A real(pREAL),dimension(3,3,3,3),intent(in) :: A
integer, dimension(6) :: ipiv6 integer, dimension(6) :: ipiv6
real(pReal), dimension(6,6) :: temp66 real(pREAL), dimension(6,6) :: temp66
real(pReal), dimension(6*6) :: work real(pREAL), dimension(6*6) :: work
integer :: ierr_i, ierr_f integer :: ierr_i, ierr_f
@ -545,12 +545,12 @@ end function math_invSym3333
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure subroutine math_invert(InvA, error, A) pure subroutine math_invert(InvA, error, A)
real(pReal), dimension(:,:), intent(in) :: A real(pREAL), dimension(:,:), intent(in) :: A
real(pReal), dimension(size(A,1),size(A,1)), intent(out) :: invA real(pREAL), dimension(size(A,1),size(A,1)), intent(out) :: invA
logical, intent(out) :: error logical, intent(out) :: error
integer, dimension(size(A,1)) :: ipiv integer, dimension(size(A,1)) :: ipiv
real(pReal), dimension(size(A,1)**2) :: work real(pREAL), dimension(size(A,1)**2) :: work
integer :: ierr integer :: ierr
@ -568,11 +568,11 @@ end subroutine math_invert
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_symmetric33(m) pure function math_symmetric33(m)
real(pReal), dimension(3,3) :: math_symmetric33 real(pREAL), dimension(3,3) :: math_symmetric33
real(pReal), dimension(3,3), intent(in) :: m real(pREAL), dimension(3,3), intent(in) :: m
math_symmetric33 = 0.5_pReal * (m + transpose(m)) math_symmetric33 = 0.5_pREAL * (m + transpose(m))
end function math_symmetric33 end function math_symmetric33
@ -582,8 +582,8 @@ end function math_symmetric33
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_skew33(m) pure function math_skew33(m)
real(pReal), dimension(3,3) :: math_skew33 real(pREAL), dimension(3,3) :: math_skew33
real(pReal), dimension(3,3), intent(in) :: m real(pREAL), dimension(3,3), intent(in) :: m
math_skew33 = m - math_symmetric33(m) math_skew33 = m - math_symmetric33(m)
@ -596,11 +596,11 @@ end function math_skew33
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_spherical33(m) pure function math_spherical33(m)
real(pReal), dimension(3,3) :: math_spherical33 real(pREAL), dimension(3,3) :: math_spherical33
real(pReal), dimension(3,3), intent(in) :: m real(pREAL), dimension(3,3), intent(in) :: m
math_spherical33 = math_I3 * math_trace33(m)/3.0_pReal math_spherical33 = math_I3 * math_trace33(m)/3.0_pREAL
end function math_spherical33 end function math_spherical33
@ -610,8 +610,8 @@ end function math_spherical33
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_deviatoric33(m) pure function math_deviatoric33(m)
real(pReal), dimension(3,3) :: math_deviatoric33 real(pREAL), dimension(3,3) :: math_deviatoric33
real(pReal), dimension(3,3), intent(in) :: m real(pREAL), dimension(3,3), intent(in) :: m
math_deviatoric33 = m - math_spherical33(m) math_deviatoric33 = m - math_spherical33(m)
@ -622,9 +622,9 @@ end function math_deviatoric33
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Calculate trace of a 3x3 matrix. !> @brief Calculate trace of a 3x3 matrix.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
real(pReal) pure function math_trace33(m) real(pREAL) pure function math_trace33(m)
real(pReal), dimension(3,3), intent(in) :: m real(pREAL), dimension(3,3), intent(in) :: m
math_trace33 = m(1,1) + m(2,2) + m(3,3) math_trace33 = m(1,1) + m(2,2) + m(3,3)
@ -635,9 +635,9 @@ end function math_trace33
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Calculate determinant of a 3x3 matrix. !> @brief Calculate determinant of a 3x3 matrix.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
real(pReal) pure function math_det33(m) real(pREAL) pure function math_det33(m)
real(pReal), dimension(3,3), intent(in) :: m real(pREAL), dimension(3,3), intent(in) :: m
math_det33 = m(1,1)* (m(2,2)*m(3,3)-m(2,3)*m(3,2)) & math_det33 = m(1,1)* (m(2,2)*m(3,3)-m(2,3)*m(3,2)) &
@ -650,13 +650,13 @@ end function math_det33
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Calculate determinant of a symmetric 3x3 matrix. !> @brief Calculate determinant of a symmetric 3x3 matrix.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
real(pReal) pure function math_detSym33(m) real(pREAL) pure function math_detSym33(m)
real(pReal), dimension(3,3), intent(in) :: m real(pREAL), dimension(3,3), intent(in) :: m
math_detSym33 = -(m(1,1)*m(2,3)**2 + m(2,2)*m(1,3)**2 + m(3,3)*m(1,2)**2) & math_detSym33 = -(m(1,1)*m(2,3)**2 + m(2,2)*m(1,3)**2 + m(3,3)*m(1,2)**2) &
+ m(1,1)*m(2,2)*m(3,3) + 2.0_pReal * m(1,2)*m(1,3)*m(2,3) + m(1,1)*m(2,2)*m(3,3) + 2.0_pREAL * m(1,2)*m(1,3)*m(2,3)
end function math_detSym33 end function math_detSym33
@ -666,8 +666,8 @@ end function math_detSym33
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_33to9(m33) pure function math_33to9(m33)
real(pReal), dimension(9) :: math_33to9 real(pREAL), dimension(9) :: math_33to9
real(pReal), dimension(3,3), intent(in) :: m33 real(pREAL), dimension(3,3), intent(in) :: m33
integer :: i integer :: i
@ -682,8 +682,8 @@ end function math_33to9
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_9to33(v9) pure function math_9to33(v9)
real(pReal), dimension(3,3) :: math_9to33 real(pREAL), dimension(3,3) :: math_9to33
real(pReal), dimension(9), intent(in) :: v9 real(pREAL), dimension(9), intent(in) :: v9
integer :: i integer :: i
@ -703,14 +703,14 @@ end function math_9to33
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_sym33to6(m33,weighted) pure function math_sym33to6(m33,weighted)
real(pReal), dimension(6) :: math_sym33to6 real(pREAL), dimension(6) :: math_sym33to6
real(pReal), dimension(3,3), intent(in) :: m33 !< symmetric 3x3 matrix (no internal check) real(pREAL), dimension(3,3), intent(in) :: m33 !< symmetric 3x3 matrix (no internal check)
logical, optional, intent(in) :: weighted !< weight according to Mandel (.true. by default) logical, optional, intent(in) :: weighted !< weight according to Mandel (.true. by default)
real(pReal), dimension(6) :: w real(pREAL), dimension(6) :: w
integer :: i integer :: i
w = merge(NRMMANDEL,1.0_pReal,misc_optional(weighted,.true.)) w = merge(NRMMANDEL,1.0_pREAL,misc_optional(weighted,.true.))
math_sym33to6 = [(w(i)*m33(MAPNYE(1,i),MAPNYE(2,i)),i=1,6)] math_sym33to6 = [(w(i)*m33(MAPNYE(1,i),MAPNYE(2,i)),i=1,6)]
@ -725,15 +725,15 @@ end function math_sym33to6
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_6toSym33(v6,weighted) pure function math_6toSym33(v6,weighted)
real(pReal), dimension(3,3) :: math_6toSym33 real(pREAL), dimension(3,3) :: math_6toSym33
real(pReal), dimension(6), intent(in) :: v6 !< 6 vector real(pREAL), dimension(6), intent(in) :: v6 !< 6 vector
logical, optional, intent(in) :: weighted !< weight according to Mandel (.true. by default) logical, optional, intent(in) :: weighted !< weight according to Mandel (.true. by default)
real(pReal), dimension(6) :: w real(pREAL), dimension(6) :: w
integer :: i integer :: i
w = merge(INVNRMMANDEL,1.0_pReal,misc_optional(weighted,.true.)) w = merge(INVNRMMANDEL,1.0_pREAL,misc_optional(weighted,.true.))
do i=1,6 do i=1,6
math_6toSym33(MAPNYE(1,i),MAPNYE(2,i)) = w(i)*v6(i) math_6toSym33(MAPNYE(1,i),MAPNYE(2,i)) = w(i)*v6(i)
@ -748,8 +748,8 @@ end function math_6toSym33
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_3333to99(m3333) pure function math_3333to99(m3333)
real(pReal), dimension(9,9) :: math_3333to99 real(pREAL), dimension(9,9) :: math_3333to99
real(pReal), dimension(3,3,3,3), intent(in) :: m3333 real(pREAL), dimension(3,3,3,3), intent(in) :: m3333
integer :: i,j integer :: i,j
@ -770,8 +770,8 @@ end function math_3333to99
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_99to3333(m99) pure function math_99to3333(m99)
real(pReal), dimension(3,3,3,3) :: math_99to3333 real(pREAL), dimension(3,3,3,3) :: math_99to3333
real(pReal), dimension(9,9), intent(in) :: m99 real(pREAL), dimension(9,9), intent(in) :: m99
integer :: i,j integer :: i,j
@ -795,15 +795,15 @@ end function math_99to3333
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_sym3333to66(m3333,weighted) pure function math_sym3333to66(m3333,weighted)
real(pReal), dimension(6,6) :: math_sym3333to66 real(pREAL), dimension(6,6) :: math_sym3333to66
real(pReal), dimension(3,3,3,3), intent(in) :: m3333 !< symmetric 3x3x3x3 matrix (no internal check) real(pREAL), dimension(3,3,3,3), intent(in) :: m3333 !< symmetric 3x3x3x3 matrix (no internal check)
logical, optional, intent(in) :: weighted !< weight according to Mandel (.true. by default) logical, optional, intent(in) :: weighted !< weight according to Mandel (.true. by default)
real(pReal), dimension(6) :: w real(pREAL), dimension(6) :: w
integer :: i,j integer :: i,j
w = merge(NRMMANDEL,1.0_pReal,misc_optional(weighted,.true.)) w = merge(NRMMANDEL,1.0_pREAL,misc_optional(weighted,.true.))
#ifndef __INTEL_COMPILER #ifndef __INTEL_COMPILER
do concurrent(i=1:6, j=1:6) do concurrent(i=1:6, j=1:6)
@ -824,15 +824,15 @@ end function math_sym3333to66
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_66toSym3333(m66,weighted) pure function math_66toSym3333(m66,weighted)
real(pReal), dimension(3,3,3,3) :: math_66toSym3333 real(pREAL), dimension(3,3,3,3) :: math_66toSym3333
real(pReal), dimension(6,6), intent(in) :: m66 !< 6x6 matrix real(pREAL), dimension(6,6), intent(in) :: m66 !< 6x6 matrix
logical, optional, intent(in) :: weighted !< weight according to Mandel (.true. by default) logical, optional, intent(in) :: weighted !< weight according to Mandel (.true. by default)
real(pReal), dimension(6) :: w real(pREAL), dimension(6) :: w
integer :: i,j integer :: i,j
w = merge(INVNRMMANDEL,1.0_pReal,misc_optional(weighted,.true.)) w = merge(INVNRMMANDEL,1.0_pREAL,misc_optional(weighted,.true.))
do i=1,6; do j=1,6 do i=1,6; do j=1,6
math_66toSym3333(MAPNYE(1,i),MAPNYE(2,i),MAPNYE(1,j),MAPNYE(2,j)) = w(i)*w(j)*m66(i,j) math_66toSym3333(MAPNYE(1,i),MAPNYE(2,i),MAPNYE(1,j),MAPNYE(2,j)) = w(i)*w(j)*m66(i,j)
@ -849,8 +849,8 @@ end function math_66toSym3333
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_Voigt6to33_stress(sigma_tilde) result(sigma) pure function math_Voigt6to33_stress(sigma_tilde) result(sigma)
real(pReal), dimension(3,3) :: sigma real(pREAL), dimension(3,3) :: sigma
real(pReal), dimension(6), intent(in) :: sigma_tilde real(pREAL), dimension(6), intent(in) :: sigma_tilde
sigma = reshape([sigma_tilde(1), sigma_tilde(6), sigma_tilde(5), & sigma = reshape([sigma_tilde(1), sigma_tilde(6), sigma_tilde(5), &
@ -865,13 +865,13 @@ end function math_Voigt6to33_stress
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_Voigt6to33_strain(epsilon_tilde) result(epsilon) pure function math_Voigt6to33_strain(epsilon_tilde) result(epsilon)
real(pReal), dimension(3,3) :: epsilon real(pREAL), dimension(3,3) :: epsilon
real(pReal), dimension(6), intent(in) :: epsilon_tilde real(pREAL), dimension(6), intent(in) :: epsilon_tilde
epsilon = reshape([ epsilon_tilde(1), 0.5_pReal*epsilon_tilde(6), 0.5_pReal*epsilon_tilde(5), & epsilon = reshape([ epsilon_tilde(1), 0.5_pREAL*epsilon_tilde(6), 0.5_pREAL*epsilon_tilde(5), &
0.5_pReal*epsilon_tilde(6), epsilon_tilde(2), 0.5_pReal*epsilon_tilde(4), & 0.5_pREAL*epsilon_tilde(6), epsilon_tilde(2), 0.5_pREAL*epsilon_tilde(4), &
0.5_pReal*epsilon_tilde(5), 0.5_pReal*epsilon_tilde(4), epsilon_tilde(3)],[3,3]) 0.5_pREAL*epsilon_tilde(5), 0.5_pREAL*epsilon_tilde(4), epsilon_tilde(3)],[3,3])
end function math_Voigt6to33_strain end function math_Voigt6to33_strain
@ -881,8 +881,8 @@ end function math_Voigt6to33_strain
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_33toVoigt6_stress(sigma) result(sigma_tilde) pure function math_33toVoigt6_stress(sigma) result(sigma_tilde)
real(pReal), dimension(6) :: sigma_tilde real(pREAL), dimension(6) :: sigma_tilde
real(pReal), dimension(3,3), intent(in) :: sigma real(pREAL), dimension(3,3), intent(in) :: sigma
sigma_tilde = [sigma(1,1), sigma(2,2), sigma(3,3), & sigma_tilde = [sigma(1,1), sigma(2,2), sigma(3,3), &
@ -896,12 +896,12 @@ end function math_33toVoigt6_stress
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_33toVoigt6_strain(epsilon) result(epsilon_tilde) pure function math_33toVoigt6_strain(epsilon) result(epsilon_tilde)
real(pReal), dimension(6) :: epsilon_tilde real(pREAL), dimension(6) :: epsilon_tilde
real(pReal), dimension(3,3), intent(in) :: epsilon real(pREAL), dimension(3,3), intent(in) :: epsilon
epsilon_tilde = [ epsilon(1,1), epsilon(2,2), epsilon(3,3), & epsilon_tilde = [ epsilon(1,1), epsilon(2,2), epsilon(3,3), &
2.0_pReal*epsilon(3,2), 2.0_pReal*epsilon(3,1), 2.0_pReal*epsilon(1,2)] 2.0_pREAL*epsilon(3,2), 2.0_pREAL*epsilon(3,1), 2.0_pREAL*epsilon(1,2)]
end function math_33toVoigt6_strain end function math_33toVoigt6_strain
@ -912,8 +912,8 @@ end function math_33toVoigt6_strain
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_Voigt66to3333_stiffness(C_tilde) result(C) pure function math_Voigt66to3333_stiffness(C_tilde) result(C)
real(pReal), dimension(3,3,3,3) :: C real(pREAL), dimension(3,3,3,3) :: C
real(pReal), dimension(6,6), intent(in) :: C_tilde real(pREAL), dimension(6,6), intent(in) :: C_tilde
integer :: i,j integer :: i,j
@ -933,8 +933,8 @@ end function math_Voigt66to3333_stiffness
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_3333toVoigt66_stiffness(C) result(C_tilde) pure function math_3333toVoigt66_stiffness(C) result(C_tilde)
real(pReal), dimension(6,6) :: C_tilde real(pREAL), dimension(6,6) :: C_tilde
real(pReal), dimension(3,3,3,3), intent(in) :: C real(pREAL), dimension(3,3,3,3), intent(in) :: C
integer :: i,j integer :: i,j
@ -957,15 +957,15 @@ end function math_3333toVoigt66_stiffness
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
impure elemental subroutine math_normal(x,mu,sigma) impure elemental subroutine math_normal(x,mu,sigma)
real(pReal), intent(out) :: x real(pREAL), intent(out) :: x
real(pReal), intent(in), optional :: mu, sigma real(pREAL), intent(in), optional :: mu, sigma
real(pReal), dimension(2) :: rnd real(pREAL), dimension(2) :: rnd
call random_number(rnd) call random_number(rnd)
x = misc_optional(mu,0.0_pReal) & x = misc_optional(mu,0.0_pREAL) &
+ misc_optional(sigma,1.0_pReal) * sqrt(-2.0_pReal*log(1.0_pReal-rnd(1)))*cos(TAU*(1.0_pReal - rnd(2))) + misc_optional(sigma,1.0_pREAL) * sqrt(-2.0_pREAL*log(1.0_pREAL-rnd(1)))*cos(TAU*(1.0_pREAL - rnd(2)))
end subroutine math_normal end subroutine math_normal
@ -975,13 +975,13 @@ end subroutine math_normal
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure subroutine math_eigh(w,v,error,m) pure subroutine math_eigh(w,v,error,m)
real(pReal), dimension(:,:), intent(in) :: m !< quadratic matrix to compute eigenvectors and values of real(pREAL), dimension(:,:), intent(in) :: m !< quadratic matrix to compute eigenvectors and values of
real(pReal), dimension(size(m,1)), intent(out) :: w !< eigenvalues real(pREAL), dimension(size(m,1)), intent(out) :: w !< eigenvalues
real(pReal), dimension(size(m,1),size(m,1)), intent(out) :: v !< eigenvectors real(pREAL), dimension(size(m,1),size(m,1)), intent(out) :: v !< eigenvectors
logical, intent(out) :: error logical, intent(out) :: error
integer :: ierr integer :: ierr
real(pReal), dimension(size(m,1)**2) :: work real(pREAL), dimension(size(m,1)**2) :: work
v = m ! copy matrix to input (doubles as output) array v = m ! copy matrix to input (doubles as output) array
@ -1000,11 +1000,11 @@ end subroutine math_eigh
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure subroutine math_eigh33(w,v,m) pure subroutine math_eigh33(w,v,m)
real(pReal), dimension(3,3),intent(in) :: m !< 3x3 matrix to compute eigenvectors and values of real(pREAL), dimension(3,3),intent(in) :: m !< 3x3 matrix to compute eigenvectors and values of
real(pReal), dimension(3), intent(out) :: w !< eigenvalues real(pREAL), dimension(3), intent(out) :: w !< eigenvalues
real(pReal), dimension(3,3),intent(out) :: v !< eigenvectors real(pREAL), dimension(3,3),intent(out) :: v !< eigenvectors
real(pReal) :: T, U, norm, threshold real(pREAL) :: T, U, norm, threshold
logical :: error logical :: error
@ -1016,7 +1016,7 @@ pure subroutine math_eigh33(w,v,m)
T = maxval(abs(w)) T = maxval(abs(w))
U = max(T, T**2) U = max(T, T**2)
threshold = sqrt(5.68e-14_pReal * U**2) threshold = sqrt(5.68e-14_pREAL * U**2)
#ifndef __INTEL_LLVM_COMPILER #ifndef __INTEL_LLVM_COMPILER
v(1:3,1) = [m(1,3)*w(1) + v(1,2), & v(1:3,1) = [m(1,3)*w(1) + v(1,2), &
@ -1059,32 +1059,32 @@ end subroutine math_eigh33
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_rotationalPart(F) result(R) pure function math_rotationalPart(F) result(R)
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
F ! deformation gradient F ! deformation gradient
real(pReal), dimension(3,3) :: & real(pREAL), dimension(3,3) :: &
C, & ! right Cauchy-Green tensor C, & ! right Cauchy-Green tensor
R ! rotational part R ! rotational part
real(pReal), dimension(3) :: & real(pREAL), dimension(3) :: &
lambda, & ! principal stretches lambda, & ! principal stretches
I_C, & ! invariants of C I_C, & ! invariants of C
I_U ! invariants of U I_U ! invariants of U
real(pReal), dimension(2) :: & real(pREAL), dimension(2) :: &
I_F ! first two invariants of F I_F ! first two invariants of F
real(pReal) :: x,Phi real(pREAL) :: x,Phi
C = matmul(transpose(F),F) C = matmul(transpose(F),F)
I_C = math_invariantsSym33(C) I_C = math_invariantsSym33(C)
I_F = [math_trace33(F), 0.5_pReal*(math_trace33(F)**2 - math_trace33(matmul(F,F)))] I_F = [math_trace33(F), 0.5_pREAL*(math_trace33(F)**2 - math_trace33(matmul(F,F)))]
x = math_clip(I_C(1)**2 -3.0_pReal*I_C(2),0.0_pReal)**(3.0_pReal/2.0_pReal) x = math_clip(I_C(1)**2 -3.0_pREAL*I_C(2),0.0_pREAL)**(3.0_pREAL/2.0_pREAL)
if (dNeq0(x)) then if (dNeq0(x)) then
Phi = acos(math_clip((I_C(1)**3 -4.5_pReal*I_C(1)*I_C(2) +13.5_pReal*I_C(3))/x,-1.0_pReal,1.0_pReal)) Phi = acos(math_clip((I_C(1)**3 -4.5_pREAL*I_C(1)*I_C(2) +13.5_pREAL*I_C(3))/x,-1.0_pREAL,1.0_pREAL))
lambda = I_C(1) +(2.0_pReal * sqrt(math_clip(I_C(1)**2-3.0_pReal*I_C(2),0.0_pReal))) & lambda = I_C(1) +(2.0_pREAL * sqrt(math_clip(I_C(1)**2-3.0_pREAL*I_C(2),0.0_pREAL))) &
*cos((Phi-TAU*[1.0_pReal,2.0_pReal,3.0_pReal])/3.0_pReal) *cos((Phi-TAU*[1.0_pREAL,2.0_pREAL,3.0_pREAL])/3.0_pREAL)
lambda = sqrt(math_clip(lambda,0.0_pReal)/3.0_pReal) lambda = sqrt(math_clip(lambda,0.0_pREAL)/3.0_pREAL)
else else
lambda = sqrt(I_C(1)/3.0_pReal) lambda = sqrt(I_C(1)/3.0_pREAL)
end if end if
I_U = [sum(lambda), lambda(1)*lambda(2)+lambda(2)*lambda(3)+lambda(3)*lambda(1), product(lambda)] I_U = [sum(lambda), lambda(1)*lambda(2)+lambda(2)*lambda(3)+lambda(3)*lambda(1), product(lambda)]
@ -1094,7 +1094,7 @@ pure function math_rotationalPart(F) result(R)
- I_U(1)*I_F(1) * transpose(F) & - I_U(1)*I_F(1) * transpose(F) &
+ I_U(1) * transpose(matmul(F,F)) & + I_U(1) * transpose(matmul(F,F)) &
- matmul(F,C) - matmul(F,C)
R = R*math_det33(R)**(-1.0_pReal/3.0_pReal) R = R*math_det33(R)**(-1.0_pREAL/3.0_pREAL)
end function math_rotationalPart end function math_rotationalPart
@ -1105,17 +1105,17 @@ end function math_rotationalPart
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_eigvalsh(m) pure function math_eigvalsh(m)
real(pReal), dimension(:,:), intent(in) :: m !< symmetric matrix to compute eigenvalues of real(pREAL), dimension(:,:), intent(in) :: m !< symmetric matrix to compute eigenvalues of
real(pReal), dimension(size(m,1)) :: math_eigvalsh real(pREAL), dimension(size(m,1)) :: math_eigvalsh
real(pReal), dimension(size(m,1),size(m,1)) :: m_ real(pREAL), dimension(size(m,1),size(m,1)) :: m_
integer :: ierr integer :: ierr
real(pReal), dimension(size(m,1)**2) :: work real(pREAL), dimension(size(m,1)**2) :: work
m_ = m ! m_ will be destroyed m_ = m ! m_ will be destroyed
call dsyev('N','U',size(m,1),m_,size(m,1),math_eigvalsh,work,size(work),ierr) call dsyev('N','U',size(m,1),m_,size(m,1),math_eigvalsh,work,size(work),ierr)
if (ierr /= 0) math_eigvalsh = IEEE_value(1.0_pReal,IEEE_quiet_NaN) if (ierr /= 0) math_eigvalsh = IEEE_value(1.0_pREAL,IEEE_quiet_NaN)
end function math_eigvalsh end function math_eigvalsh
@ -1129,30 +1129,30 @@ end function math_eigvalsh
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_eigvalsh33(m) pure function math_eigvalsh33(m)
real(pReal), intent(in), dimension(3,3) :: m !< 3x3 symmetric matrix to compute eigenvalues of real(pREAL), intent(in), dimension(3,3) :: m !< 3x3 symmetric matrix to compute eigenvalues of
real(pReal), dimension(3) :: math_eigvalsh33,I real(pREAL), dimension(3) :: math_eigvalsh33,I
real(pReal) :: P, Q, rho, phi real(pREAL) :: P, Q, rho, phi
real(pReal), parameter :: TOL=1.e-14_pReal real(pREAL), parameter :: TOL=1.e-14_pREAL
I = math_invariantsSym33(m) ! invariants are coefficients in characteristic polynomial apart for the sign of c0 and c2 in http://arxiv.org/abs/physics/0610206 I = math_invariantsSym33(m) ! invariants are coefficients in characteristic polynomial apart for the sign of c0 and c2 in http://arxiv.org/abs/physics/0610206
P = I(2)-I(1)**2/3.0_pReal ! different from http://arxiv.org/abs/physics/0610206 (this formulation was in DAMASK) P = I(2)-I(1)**2/3.0_pREAL ! different from http://arxiv.org/abs/physics/0610206 (this formulation was in DAMASK)
Q = product(I(1:2))/3.0_pReal & Q = product(I(1:2))/3.0_pREAL &
- 2.0_pReal/27.0_pReal*I(1)**3 & - 2.0_pREAL/27.0_pREAL*I(1)**3 &
- I(3) ! different from http://arxiv.org/abs/physics/0610206 (this formulation was in DAMASK) - I(3) ! different from http://arxiv.org/abs/physics/0610206 (this formulation was in DAMASK)
if (all(abs([P,Q]) < TOL)) then if (all(abs([P,Q]) < TOL)) then
math_eigvalsh33 = math_eigvalsh(m) math_eigvalsh33 = math_eigvalsh(m)
else else
rho=sqrt(-3.0_pReal*P**3)/9.0_pReal rho=sqrt(-3.0_pREAL*P**3)/9.0_pREAL
phi=acos(math_clip(-Q/rho*0.5_pReal,-1.0_pReal,1.0_pReal)) phi=acos(math_clip(-Q/rho*0.5_pREAL,-1.0_pREAL,1.0_pREAL))
math_eigvalsh33 = 2.0_pReal*rho**(1.0_pReal/3.0_pReal)* & math_eigvalsh33 = 2.0_pREAL*rho**(1.0_pREAL/3.0_pREAL)* &
[cos( phi /3.0_pReal), & [cos( phi /3.0_pREAL), &
cos((phi+TAU)/3.0_pReal), & cos((phi+TAU)/3.0_pREAL), &
cos((phi+2.0_pReal*TAU)/3.0_pReal) & cos((phi+2.0_pREAL*TAU)/3.0_pREAL) &
] & ] &
+ I(1)/3.0_pReal + I(1)/3.0_pREAL
end if end if
end function math_eigvalsh33 end function math_eigvalsh33
@ -1163,8 +1163,8 @@ end function math_eigvalsh33
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function math_invariantsSym33(m) pure function math_invariantsSym33(m)
real(pReal), dimension(3,3), intent(in) :: m real(pREAL), dimension(3,3), intent(in) :: m
real(pReal), dimension(3) :: math_invariantsSym33 real(pREAL), dimension(3) :: math_invariantsSym33
math_invariantsSym33(1) = math_trace33(m) math_invariantsSym33(1) = math_trace33(m)
@ -1225,17 +1225,17 @@ end function math_multinomial
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief volume of tetrahedron given by four vertices !> @brief volume of tetrahedron given by four vertices
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
real(pReal) pure function math_volTetrahedron(v1,v2,v3,v4) real(pREAL) pure function math_volTetrahedron(v1,v2,v3,v4)
real(pReal), dimension (3), intent(in) :: v1,v2,v3,v4 real(pREAL), dimension (3), intent(in) :: v1,v2,v3,v4
real(pReal), dimension (3,3) :: m real(pREAL), dimension (3,3) :: m
m(1:3,1) = v1-v2 m(1:3,1) = v1-v2
m(1:3,2) = v1-v3 m(1:3,2) = v1-v3
m(1:3,3) = v1-v4 m(1:3,3) = v1-v4
math_volTetrahedron = abs(math_det33(m))/6.0_pReal math_volTetrahedron = abs(math_det33(m))/6.0_pREAL
end function math_volTetrahedron end function math_volTetrahedron
@ -1243,12 +1243,12 @@ end function math_volTetrahedron
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief area of triangle given by three vertices !> @brief area of triangle given by three vertices
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
real(pReal) pure function math_areaTriangle(v1,v2,v3) real(pREAL) pure function math_areaTriangle(v1,v2,v3)
real(pReal), dimension (3), intent(in) :: v1,v2,v3 real(pREAL), dimension (3), intent(in) :: v1,v2,v3
math_areaTriangle = 0.5_pReal * norm2(math_cross(v1-v2,v1-v3)) math_areaTriangle = 0.5_pREAL * norm2(math_cross(v1-v2,v1-v3))
end function math_areaTriangle end function math_areaTriangle
@ -1256,10 +1256,10 @@ end function math_areaTriangle
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Limit a scalar value to a certain range (either one or two sided). !> @brief Limit a scalar value to a certain range (either one or two sided).
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
real(pReal) pure elemental function math_clip(a, left, right) real(pREAL) pure elemental function math_clip(a, left, right)
real(pReal), intent(in) :: a real(pREAL), intent(in) :: a
real(pReal), intent(in), optional :: left, right real(pREAL), intent(in), optional :: left, right
math_clip = a math_clip = a
@ -1285,30 +1285,30 @@ subroutine selfTest()
integer, dimension(5) :: range_out_ = [1,2,3,4,5] integer, dimension(5) :: range_out_ = [1,2,3,4,5]
integer, dimension(3) :: ijk integer, dimension(3) :: ijk
real(pReal) :: det real(pREAL) :: det
real(pReal), dimension(3) :: v3_1,v3_2,v3_3,v3_4 real(pREAL), dimension(3) :: v3_1,v3_2,v3_3,v3_4
real(pReal), dimension(6) :: v6 real(pREAL), dimension(6) :: v6
real(pReal), dimension(9) :: v9 real(pREAL), dimension(9) :: v9
real(pReal), dimension(3,3) :: t33,t33_2 real(pREAL), dimension(3,3) :: t33,t33_2
real(pReal), dimension(6,6) :: t66 real(pREAL), dimension(6,6) :: t66
real(pReal), dimension(9,9) :: t99,t99_2 real(pREAL), dimension(9,9) :: t99,t99_2
real(pReal), dimension(:,:), & real(pREAL), dimension(:,:), &
allocatable :: txx,txx_2 allocatable :: txx,txx_2
real(pReal) :: r real(pREAL) :: r
integer :: d integer :: d
logical :: e logical :: e
if (any(abs([1.0_pReal,2.0_pReal,2.0_pReal,3.0_pReal,3.0_pReal,3.0_pReal] - & if (any(abs([1.0_pREAL,2.0_pREAL,2.0_pREAL,3.0_pREAL,3.0_pREAL,3.0_pREAL] - &
math_expand([1.0_pReal,2.0_pReal,3.0_pReal],[1,2,3,0])) > tol_math_check)) & math_expand([1.0_pREAL,2.0_pREAL,3.0_pREAL],[1,2,3,0])) > tol_math_check)) &
error stop 'math_expand [1,2,3] by [1,2,3,0] => [1,2,2,3,3,3]' error stop 'math_expand [1,2,3] by [1,2,3,0] => [1,2,2,3,3,3]'
if (any(abs([1.0_pReal,2.0_pReal,2.0_pReal] - & if (any(abs([1.0_pREAL,2.0_pREAL,2.0_pREAL] - &
math_expand([1.0_pReal,2.0_pReal,3.0_pReal],[1,2])) > tol_math_check)) & math_expand([1.0_pREAL,2.0_pREAL,3.0_pREAL],[1,2])) > tol_math_check)) &
error stop 'math_expand [1,2,3] by [1,2] => [1,2,2]' error stop 'math_expand [1,2,3] by [1,2] => [1,2,2]'
if (any(abs([1.0_pReal,2.0_pReal,2.0_pReal,1.0_pReal,1.0_pReal,1.0_pReal] - & if (any(abs([1.0_pREAL,2.0_pREAL,2.0_pREAL,1.0_pREAL,1.0_pREAL,1.0_pREAL] - &
math_expand([1.0_pReal,2.0_pReal],[1,2,3])) > tol_math_check)) & math_expand([1.0_pREAL,2.0_pREAL],[1,2,3])) > tol_math_check)) &
error stop 'math_expand [1,2] by [1,2,3] => [1,2,2,1,1,1]' error stop 'math_expand [1,2] by [1,2,3] => [1,2,2,1,1,1]'
call math_sort(sort_in_,1,3,2) call math_sort(sort_in_,1,3,2)
@ -1320,7 +1320,7 @@ subroutine selfTest()
if (any(dNeq(math_exp33(math_I3,0),math_I3))) & if (any(dNeq(math_exp33(math_I3,0),math_I3))) &
error stop 'math_exp33(math_I3,1)' error stop 'math_exp33(math_I3,1)'
if (any(dNeq(math_exp33(math_I3,128),exp(1.0_pReal)*math_I3))) & if (any(dNeq(math_exp33(math_I3,128),exp(1.0_pREAL)*math_I3))) &
error stop 'math_exp33(math_I3,128)' error stop 'math_exp33(math_I3,128)'
call random_number(v9) call random_number(v9)
@ -1336,10 +1336,10 @@ subroutine selfTest()
error stop 'math_sym33to6/math_6toSym33' error stop 'math_sym33to6/math_6toSym33'
call random_number(t66) call random_number(t66)
if (any(dNeq(math_sym3333to66(math_66toSym3333(t66)),t66,1.0e-15_pReal))) & if (any(dNeq(math_sym3333to66(math_66toSym3333(t66)),t66,1.0e-15_pREAL))) &
error stop 'math_sym3333to66/math_66toSym3333' error stop 'math_sym3333to66/math_66toSym3333'
if (any(dNeq(math_3333toVoigt66_stiffness(math_Voigt66to3333_stiffness(t66)),t66,1.0e-15_pReal))) & if (any(dNeq(math_3333toVoigt66_stiffness(math_Voigt66to3333_stiffness(t66)),t66,1.0e-15_pREAL))) &
error stop 'math_3333toVoigt66/math_Voigt66to3333' error stop 'math_3333toVoigt66/math_Voigt66to3333'
call random_number(v6) call random_number(v6)
@ -1351,12 +1351,12 @@ subroutine selfTest()
call random_number(v3_3) call random_number(v3_3)
call random_number(v3_4) call random_number(v3_4)
if (dNeq(abs(dot_product(math_cross(v3_1-v3_4,v3_2-v3_4),v3_3-v3_4))/6.0_pReal, & if (dNeq(abs(dot_product(math_cross(v3_1-v3_4,v3_2-v3_4),v3_3-v3_4))/6.0_pREAL, &
math_volTetrahedron(v3_1,v3_2,v3_3,v3_4),tol=1.0e-12_pReal)) & math_volTetrahedron(v3_1,v3_2,v3_3,v3_4),tol=1.0e-12_pREAL)) &
error stop 'math_volTetrahedron' error stop 'math_volTetrahedron'
call random_number(t33) call random_number(t33)
if (dNeq(math_det33(math_symmetric33(t33)),math_detSym33(math_symmetric33(t33)),tol=1.0e-12_pReal)) & if (dNeq(math_det33(math_symmetric33(t33)),math_detSym33(math_symmetric33(t33)),tol=1.0e-12_pREAL)) &
error stop 'math_det33/math_detSym33' error stop 'math_det33/math_detSym33'
if (any(dNeq(t33+transpose(t33),math_mul3333xx33(math_identity4th(),t33+transpose(t33))))) & if (any(dNeq(t33+transpose(t33),math_mul3333xx33(math_identity4th(),t33+transpose(t33))))) &
@ -1365,34 +1365,34 @@ subroutine selfTest()
if (any(dNeq0(math_eye(3),math_inv33(math_I3)))) & if (any(dNeq0(math_eye(3),math_inv33(math_I3)))) &
error stop 'math_inv33(math_I3)' error stop 'math_inv33(math_I3)'
do while(abs(math_det33(t33))<1.0e-9_pReal) do while(abs(math_det33(t33))<1.0e-9_pREAL)
call random_number(t33) call random_number(t33)
end do end do
if (any(dNeq0(matmul(t33,math_inv33(t33)) - math_eye(3),tol=1.0e-8_pReal))) & if (any(dNeq0(matmul(t33,math_inv33(t33)) - math_eye(3),tol=1.0e-8_pREAL))) &
error stop 'math_inv33' error stop 'math_inv33'
call math_invert33(t33_2,det,e,t33) call math_invert33(t33_2,det,e,t33)
if (any(dNeq0(matmul(t33,t33_2) - math_eye(3),tol=1.0e-9_pReal)) .or. e) & if (any(dNeq0(matmul(t33,t33_2) - math_eye(3),tol=1.0e-9_pREAL)) .or. e) &
error stop 'math_invert33: T:T^-1 != I' error stop 'math_invert33: T:T^-1 != I'
if (dNeq(det,math_det33(t33),tol=1.0e-12_pReal)) & if (dNeq(det,math_det33(t33),tol=1.0e-12_pREAL)) &
error stop 'math_invert33 (determinant)' error stop 'math_invert33 (determinant)'
call math_invert(t33_2,e,t33) call math_invert(t33_2,e,t33)
if (any(dNeq0(matmul(t33,t33_2) - math_eye(3),tol=1.0e-9_pReal)) .or. e) & if (any(dNeq0(matmul(t33,t33_2) - math_eye(3),tol=1.0e-9_pREAL)) .or. e) &
error stop 'math_invert t33' error stop 'math_invert t33'
do while(math_det33(t33)<1.0e-2_pReal) ! O(det(F)) = 1 do while(math_det33(t33)<1.0e-2_pREAL) ! O(det(F)) = 1
call random_number(t33) call random_number(t33)
end do end do
t33_2 = math_rotationalPart(transpose(t33)) t33_2 = math_rotationalPart(transpose(t33))
t33 = math_rotationalPart(t33) t33 = math_rotationalPart(t33)
if (any(dNeq0(matmul(t33_2,t33) - math_I3,tol=1.0e-10_pReal))) & if (any(dNeq0(matmul(t33_2,t33) - math_I3,tol=1.0e-10_pREAL))) &
error stop 'math_rotationalPart (forward-backward)' error stop 'math_rotationalPart (forward-backward)'
if (dNeq(1.0_pReal,math_det33(math_rotationalPart(t33)),tol=1.0e-10_pReal)) & if (dNeq(1.0_pREAL,math_det33(math_rotationalPart(t33)),tol=1.0e-10_pREAL)) &
error stop 'math_rotationalPart (determinant)' error stop 'math_rotationalPart (determinant)'
call random_number(r) call random_number(r)
d = int(r*5.0_pReal) + 1 d = int(r*5.0_pREAL) + 1
txx = math_eye(d) txx = math_eye(d)
allocate(txx_2(d,d)) allocate(txx_2(d,d))
call math_invert(txx_2,e,txx) call math_invert(txx_2,e,txx)
@ -1400,10 +1400,10 @@ subroutine selfTest()
error stop 'math_invert(txx)/math_eye' error stop 'math_invert(txx)/math_eye'
call math_invert(t99_2,e,t99) ! not sure how likely it is that we get a singular matrix call math_invert(t99_2,e,t99) ! not sure how likely it is that we get a singular matrix
if (any(dNeq0(matmul(t99_2,t99)-math_eye(9),tol=1.0e-9_pReal)) .or. e) & if (any(dNeq0(matmul(t99_2,t99)-math_eye(9),tol=1.0e-9_pREAL)) .or. e) &
error stop 'math_invert(t99)' error stop 'math_invert(t99)'
if (any(dNeq(math_clip([4.0_pReal,9.0_pReal],5.0_pReal,6.5_pReal),[5.0_pReal,6.5_pReal]))) & if (any(dNeq(math_clip([4.0_pREAL,9.0_pREAL],5.0_pREAL,6.5_pREAL),[5.0_pREAL,6.5_pREAL]))) &
error stop 'math_clip' error stop 'math_clip'
if (math_factorial(10) /= 3628800) & if (math_factorial(10) /= 3628800) &
@ -1415,35 +1415,35 @@ subroutine selfTest()
if (math_multinomial([1,2,3,4]) /= 12600) & if (math_multinomial([1,2,3,4]) /= 12600) &
error stop 'math_multinomial' error stop 'math_multinomial'
ijk = cshift([1,2,3],int(r*1.0e2_pReal)) ijk = cshift([1,2,3],int(r*1.0e2_pREAL))
if (dNeq(math_LeviCivita(ijk(1),ijk(2),ijk(3)),+1.0_pReal)) & if (dNeq(math_LeviCivita(ijk(1),ijk(2),ijk(3)),+1.0_pREAL)) &
error stop 'math_LeviCivita(even)' error stop 'math_LeviCivita(even)'
ijk = cshift([3,2,1],int(r*2.0e2_pReal)) ijk = cshift([3,2,1],int(r*2.0e2_pREAL))
if (dNeq(math_LeviCivita(ijk(1),ijk(2),ijk(3)),-1.0_pReal)) & if (dNeq(math_LeviCivita(ijk(1),ijk(2),ijk(3)),-1.0_pREAL)) &
error stop 'math_LeviCivita(odd)' error stop 'math_LeviCivita(odd)'
ijk = cshift([2,2,1],int(r*2.0e2_pReal)) ijk = cshift([2,2,1],int(r*2.0e2_pREAL))
if (dNeq0(math_LeviCivita(ijk(1),ijk(2),ijk(3)))) & if (dNeq0(math_LeviCivita(ijk(1),ijk(2),ijk(3)))) &
error stop 'math_LeviCivita' error stop 'math_LeviCivita'
normal_distribution: block normal_distribution: block
integer, parameter :: N = 1000000 integer, parameter :: N = 1000000
real(pReal), dimension(:), allocatable :: r real(pREAL), dimension(:), allocatable :: r
real(pReal) :: mu, sigma real(pREAL) :: mu, sigma
allocate(r(N)) allocate(r(N))
call random_number(mu) call random_number(mu)
call random_number(sigma) call random_number(sigma)
sigma = 1.0_pReal + sigma*5.0_pReal sigma = 1.0_pREAL + sigma*5.0_pREAL
mu = (mu-0.5_pReal)*10_pReal mu = (mu-0.5_pREAL)*10_pREAL
call math_normal(r,mu,sigma) call math_normal(r,mu,sigma)
if (abs(mu -sum(r)/real(N,pReal))>5.0e-2_pReal) & if (abs(mu -sum(r)/real(N,pREAL))>5.0e-2_pREAL) &
error stop 'math_normal(mu)' error stop 'math_normal(mu)'
mu = sum(r)/real(N,pReal) mu = sum(r)/real(N,pREAL)
if (abs(sigma**2 -1.0_pReal/real(N-1,pReal) * sum((r-mu)**2))/sigma > 5.0e-2_pReal) & if (abs(sigma**2 -1.0_pREAL/real(N-1,pREAL) * sum((r-mu)**2))/sigma > 5.0e-2_pREAL) &
error stop 'math_normal(sigma)' error stop 'math_normal(sigma)'
end block normal_distribution end block normal_distribution

24
src/mesh/DAMASK_mesh.f90
View File

@ -23,7 +23,7 @@ program DAMASK_mesh
implicit none(type,external) implicit none(type,external)
type :: tLoadCase type :: tLoadCase
real(pReal) :: time = 0.0_pReal !< length of increment real(pREAL) :: time = 0.0_pREAL !< length of increment
integer :: incs = 0, & !< number of increments integer :: incs = 0, & !< number of increments
outputfrequency = 1 !< frequency of result writes outputfrequency = 1 !< frequency of result writes
logical :: followFormerTrajectory = .true. !< follow trajectory of former loadcase logical :: followFormerTrajectory = .true. !< follow trajectory of former loadcase
@ -43,12 +43,12 @@ program DAMASK_mesh
! loop variables, convergence etc. ! loop variables, convergence etc.
integer, parameter :: & integer, parameter :: &
subStepFactor = 2 !< for each substep, divide the last time increment by 2.0 subStepFactor = 2 !< for each substep, divide the last time increment by 2.0
real(pReal) :: & real(pREAL) :: &
time = 0.0_pReal, & !< elapsed time time = 0.0_pREAL, & !< elapsed time
time0 = 0.0_pReal, & !< begin of interval time0 = 0.0_pREAL, & !< begin of interval
timeinc = 0.0_pReal, & !< current time interval timeinc = 0.0_pREAL, & !< current time interval
timeIncOld = 0.0_pReal, & !< previous time interval timeIncOld = 0.0_pREAL, & !< previous time interval
remainingLoadCaseTime = 0.0_pReal !< remaining time of current load case remainingLoadCaseTime = 0.0_pREAL !< remaining time of current load case
logical :: & logical :: &
guess, & !< guess along former trajectory guess, & !< guess along former trajectory
stagIterate stagIterate
@ -140,7 +140,7 @@ program DAMASK_mesh
end select end select
end do end do
do component = 1, loadCases(i)%fieldBC(1)%nComponents do component = 1, loadCases(i)%fieldBC(1)%nComponents
allocate(loadCases(i)%fieldBC(1)%componentBC(component)%Value(mesh_Nboundaries), source = 0.0_pReal) allocate(loadCases(i)%fieldBC(1)%componentBC(component)%Value(mesh_Nboundaries), source = 0.0_pREAL)
allocate(loadCases(i)%fieldBC(1)%componentBC(component)%Mask (mesh_Nboundaries), source = .false.) allocate(loadCases(i)%fieldBC(1)%componentBC(component)%Mask (mesh_Nboundaries), source = .false.)
end do end do
end do end do
@ -240,7 +240,7 @@ program DAMASK_mesh
print'(/,1x,a)', '... writing initial configuration to file .................................' print'(/,1x,a)', '... writing initial configuration to file .................................'
flush(IO_STDOUT) flush(IO_STDOUT)
call materialpoint_result(0,0.0_pReal) call materialpoint_result(0,0.0_pREAL)
loadCaseLooping: do currentLoadCase = 1, size(loadCases) loadCaseLooping: do currentLoadCase = 1, size(loadCases)
time0 = time ! load case start time time0 = time ! load case start time
@ -252,8 +252,8 @@ program DAMASK_mesh
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! forwarding time ! forwarding time
timeIncOld = timeinc ! last timeinc that brought former inc to an end timeIncOld = timeinc ! last timeinc that brought former inc to an end
timeinc = loadCases(currentLoadCase)%time/real(loadCases(currentLoadCase)%incs,pReal) timeinc = loadCases(currentLoadCase)%time/real(loadCases(currentLoadCase)%incs,pREAL)
timeinc = timeinc * real(subStepFactor,pReal)**real(-cutBackLevel,pReal) ! depending on cut back level, decrease time step timeinc = timeinc * real(subStepFactor,pREAL)**real(-cutBackLevel,pREAL) ! depending on cut back level, decrease time step
stepFraction = 0 ! fraction scaled by stepFactor**cutLevel stepFraction = 0 ! fraction scaled by stepFactor**cutLevel
subStepLooping: do while (stepFraction < subStepFactor**cutBackLevel) subStepLooping: do while (stepFraction < subStepFactor**cutBackLevel)
@ -298,7 +298,7 @@ program DAMASK_mesh
stepFraction = (stepFraction - 1) * subStepFactor ! adjust to new denominator stepFraction = (stepFraction - 1) * subStepFactor ! adjust to new denominator
cutBackLevel = cutBackLevel + 1 cutBackLevel = cutBackLevel + 1
time = time - timeinc ! rewind time time = time - timeinc ! rewind time
timeinc = timeinc/2.0_pReal timeinc = timeinc/2.0_pREAL
print'(/,1x,a)', 'cutting back' print'(/,1x,a)', 'cutting back'
else ! default behavior, exit if spectral solver does not converge else ! default behavior, exit if spectral solver does not converge
if (worldrank == 0) close(statUnit) if (worldrank == 0) close(statUnit)

280
src/mesh/FEM_quadrature.f90
View File

@ -10,18 +10,18 @@ module FEM_quadrature
integer, parameter :: & integer, parameter :: &
maxOrder = 5 !< maximum integration order maxOrder = 5 !< maximum integration order
real(pReal), dimension(2,3), parameter :: & real(pREAL), dimension(2,3), parameter :: &
triangle = reshape([-1.0_pReal, -1.0_pReal, & triangle = reshape([-1.0_pREAL, -1.0_pREAL, &
1.0_pReal, -1.0_pReal, & 1.0_pREAL, -1.0_pREAL, &
-1.0_pReal, 1.0_pReal], shape=[2,3]) -1.0_pREAL, 1.0_pREAL], shape=[2,3])
real(pReal), dimension(3,4), parameter :: & real(pREAL), dimension(3,4), parameter :: &
tetrahedron = reshape([-1.0_pReal, -1.0_pReal, -1.0_pReal, & tetrahedron = reshape([-1.0_pREAL, -1.0_pREAL, -1.0_pREAL, &
1.0_pReal, -1.0_pReal, -1.0_pReal, & 1.0_pREAL, -1.0_pREAL, -1.0_pREAL, &
-1.0_pReal, 1.0_pReal, -1.0_pReal, & -1.0_pREAL, 1.0_pREAL, -1.0_pREAL, &
-1.0_pReal, -1.0_pReal, 1.0_pReal], shape=[3,4]) -1.0_pREAL, -1.0_pREAL, 1.0_pREAL], shape=[3,4])
type :: group_real !< variable length datatype type :: group_real !< variable length datatype
real(pReal), dimension(:), allocatable :: p real(pREAL), dimension(:), allocatable :: p
end type group_real end type group_real
integer, dimension(2:3,maxOrder), public, protected :: & integer, dimension(2:3,maxOrder), public, protected :: &
@ -51,132 +51,132 @@ subroutine FEM_quadrature_init()
FEM_nQuadrature(2,1) = 1 FEM_nQuadrature(2,1) = 1
allocate(FEM_quadrature_weights(2,1)%p(FEM_nQuadrature(2,1))) allocate(FEM_quadrature_weights(2,1)%p(FEM_nQuadrature(2,1)))
FEM_quadrature_weights(2,1)%p(1) = 1._pReal FEM_quadrature_weights(2,1)%p(1) = 1._pREAL
FEM_quadrature_points (2,1)%p = permutationStar3([1._pReal/3._pReal]) FEM_quadrature_points (2,1)%p = permutationStar3([1._pREAL/3._pREAL])
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! 2D quadratic ! 2D quadratic
FEM_nQuadrature(2,2) = 3 FEM_nQuadrature(2,2) = 3
allocate(FEM_quadrature_weights(2,2)%p(FEM_nQuadrature(2,2))) allocate(FEM_quadrature_weights(2,2)%p(FEM_nQuadrature(2,2)))
FEM_quadrature_weights(2,2)%p(1:3) = 1._pReal/3._pReal FEM_quadrature_weights(2,2)%p(1:3) = 1._pREAL/3._pREAL
FEM_quadrature_points (2,2)%p = permutationStar21([1._pReal/6._pReal]) FEM_quadrature_points (2,2)%p = permutationStar21([1._pREAL/6._pREAL])
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! 2D cubic ! 2D cubic
FEM_nQuadrature(2,3) = 6 FEM_nQuadrature(2,3) = 6
allocate(FEM_quadrature_weights(2,3)%p(FEM_nQuadrature(2,3))) allocate(FEM_quadrature_weights(2,3)%p(FEM_nQuadrature(2,3)))
FEM_quadrature_weights(2,3)%p(1:3) = 2.2338158967801147e-1_pReal FEM_quadrature_weights(2,3)%p(1:3) = 2.2338158967801147e-1_pREAL
FEM_quadrature_weights(2,3)%p(4:6) = 1.0995174365532187e-1_pReal FEM_quadrature_weights(2,3)%p(4:6) = 1.0995174365532187e-1_pREAL
FEM_quadrature_points (2,3)%p = [ & FEM_quadrature_points (2,3)%p = [ &
permutationStar21([4.4594849091596489e-1_pReal]), & permutationStar21([4.4594849091596489e-1_pREAL]), &
permutationStar21([9.157621350977074e-2_pReal]) ] permutationStar21([9.157621350977074e-2_pREAL]) ]
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! 2D quartic ! 2D quartic
FEM_nQuadrature(2,4) = 12 FEM_nQuadrature(2,4) = 12
allocate(FEM_quadrature_weights(2,4)%p(FEM_nQuadrature(2,4))) allocate(FEM_quadrature_weights(2,4)%p(FEM_nQuadrature(2,4)))
FEM_quadrature_weights(2,4)%p(1:3) = 1.1678627572637937e-1_pReal FEM_quadrature_weights(2,4)%p(1:3) = 1.1678627572637937e-1_pREAL
FEM_quadrature_weights(2,4)%p(4:6) = 5.0844906370206817e-2_pReal FEM_quadrature_weights(2,4)%p(4:6) = 5.0844906370206817e-2_pREAL
FEM_quadrature_weights(2,4)%p(7:12) = 8.285107561837358e-2_pReal FEM_quadrature_weights(2,4)%p(7:12) = 8.285107561837358e-2_pREAL
FEM_quadrature_points (2,4)%p = [ & FEM_quadrature_points (2,4)%p = [ &
permutationStar21([2.4928674517091042e-1_pReal]), & permutationStar21([2.4928674517091042e-1_pREAL]), &
permutationStar21([6.308901449150223e-2_pReal]), & permutationStar21([6.308901449150223e-2_pREAL]), &
permutationStar111([3.1035245103378440e-1_pReal, 5.3145049844816947e-2_pReal]) ] permutationStar111([3.1035245103378440e-1_pREAL, 5.3145049844816947e-2_pREAL]) ]
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! 2D quintic ! 2D quintic
FEM_nQuadrature(2,5) = 16 FEM_nQuadrature(2,5) = 16
allocate(FEM_quadrature_weights(2,5)%p(FEM_nQuadrature(2,5))) allocate(FEM_quadrature_weights(2,5)%p(FEM_nQuadrature(2,5)))
FEM_quadrature_weights(2,5)%p(1:1) = 1.4431560767778717e-1_pReal FEM_quadrature_weights(2,5)%p(1:1) = 1.4431560767778717e-1_pREAL
FEM_quadrature_weights(2,5)%p(2:4) = 9.509163426728463e-2_pReal FEM_quadrature_weights(2,5)%p(2:4) = 9.509163426728463e-2_pREAL
FEM_quadrature_weights(2,5)%p(5:7) = 1.0321737053471825e-1_pReal FEM_quadrature_weights(2,5)%p(5:7) = 1.0321737053471825e-1_pREAL
FEM_quadrature_weights(2,5)%p(8:10) = 3.2458497623198080e-2_pReal FEM_quadrature_weights(2,5)%p(8:10) = 3.2458497623198080e-2_pREAL
FEM_quadrature_weights(2,5)%p(11:16) = 2.7230314174434994e-2_pReal FEM_quadrature_weights(2,5)%p(11:16) = 2.7230314174434994e-2_pREAL
FEM_quadrature_points (2,5)%p = [ & FEM_quadrature_points (2,5)%p = [ &
permutationStar3([1._pReal/3._pReal]), & permutationStar3([1._pREAL/3._pREAL]), &
permutationStar21([4.5929258829272316e-1_pReal]), & permutationStar21([4.5929258829272316e-1_pREAL]), &
permutationStar21([1.705693077517602e-1_pReal]), & permutationStar21([1.705693077517602e-1_pREAL]), &
permutationStar21([5.0547228317030975e-2_pReal]), & permutationStar21([5.0547228317030975e-2_pREAL]), &
permutationStar111([2.631128296346381e-1_pReal, 8.3947774099576053e-2_pReal]) ] permutationStar111([2.631128296346381e-1_pREAL, 8.3947774099576053e-2_pREAL]) ]
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! 3D linear ! 3D linear
FEM_nQuadrature(3,1) = 1 FEM_nQuadrature(3,1) = 1
allocate(FEM_quadrature_weights(3,1)%p(FEM_nQuadrature(3,1))) allocate(FEM_quadrature_weights(3,1)%p(FEM_nQuadrature(3,1)))
FEM_quadrature_weights(3,1)%p(1) = 1.0_pReal FEM_quadrature_weights(3,1)%p(1) = 1.0_pREAL
FEM_quadrature_points (3,1)%p = permutationStar4([0.25_pReal]) FEM_quadrature_points (3,1)%p = permutationStar4([0.25_pREAL])
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! 3D quadratic ! 3D quadratic
FEM_nQuadrature(3,2) = 4 FEM_nQuadrature(3,2) = 4
allocate(FEM_quadrature_weights(3,2)%p(FEM_nQuadrature(3,2))) allocate(FEM_quadrature_weights(3,2)%p(FEM_nQuadrature(3,2)))
FEM_quadrature_weights(3,2)%p(1:4) = 0.25_pReal FEM_quadrature_weights(3,2)%p(1:4) = 0.25_pREAL
FEM_quadrature_points (3,2)%p = permutationStar31([1.3819660112501052e-1_pReal]) FEM_quadrature_points (3,2)%p = permutationStar31([1.3819660112501052e-1_pREAL])
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! 3D cubic ! 3D cubic
FEM_nQuadrature(3,3) = 14 FEM_nQuadrature(3,3) = 14
allocate(FEM_quadrature_weights(3,3)%p(FEM_nQuadrature(3,3))) allocate(FEM_quadrature_weights(3,3)%p(FEM_nQuadrature(3,3)))
FEM_quadrature_weights(3,3)%p(1:4) = 7.3493043116361949e-2_pReal FEM_quadrature_weights(3,3)%p(1:4) = 7.3493043116361949e-2_pREAL
FEM_quadrature_weights(3,3)%p(5:8) = 1.1268792571801585e-1_pReal FEM_quadrature_weights(3,3)%p(5:8) = 1.1268792571801585e-1_pREAL
FEM_quadrature_weights(3,3)%p(9:14) = 4.2546020777081467e-2_pReal FEM_quadrature_weights(3,3)%p(9:14) = 4.2546020777081467e-2_pREAL
FEM_quadrature_points (3,3)%p = [ & FEM_quadrature_points (3,3)%p = [ &
permutationStar31([9.273525031089123e-2_pReal]), & permutationStar31([9.273525031089123e-2_pREAL]), &
permutationStar31([3.108859192633006e-1_pReal]), & permutationStar31([3.108859192633006e-1_pREAL]), &
permutationStar22([4.5503704125649649e-2_pReal]) ] permutationStar22([4.5503704125649649e-2_pREAL]) ]
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! 3D quartic (lower precision/unknown source) ! 3D quartic (lower precision/unknown source)
FEM_nQuadrature(3,4) = 35 FEM_nQuadrature(3,4) = 35
allocate(FEM_quadrature_weights(3,4)%p(FEM_nQuadrature(3,4))) allocate(FEM_quadrature_weights(3,4)%p(FEM_nQuadrature(3,4)))
FEM_quadrature_weights(3,4)%p(1:4) = 0.0021900463965388_pReal FEM_quadrature_weights(3,4)%p(1:4) = 0.0021900463965388_pREAL
FEM_quadrature_weights(3,4)%p(5:16) = 0.0143395670177665_pReal FEM_quadrature_weights(3,4)%p(5:16) = 0.0143395670177665_pREAL
FEM_quadrature_weights(3,4)%p(17:22) = 0.0250305395686746_pReal FEM_quadrature_weights(3,4)%p(17:22) = 0.0250305395686746_pREAL
FEM_quadrature_weights(3,4)%p(23:34) = 0.0479839333057554_pReal FEM_quadrature_weights(3,4)%p(23:34) = 0.0479839333057554_pREAL
FEM_quadrature_weights(3,4)%p(35) = 0.0931745731195340_pReal FEM_quadrature_weights(3,4)%p(35) = 0.0931745731195340_pREAL
FEM_quadrature_points (3,4)%p = [ & FEM_quadrature_points (3,4)%p = [ &
permutationStar31([0.0267367755543735_pReal]), & permutationStar31([0.0267367755543735_pREAL]), &
permutationStar211([0.0391022406356488_pReal, 0.7477598884818090_pReal]), & permutationStar211([0.0391022406356488_pREAL, 0.7477598884818090_pREAL]), &
permutationStar22([0.4547545999844830_pReal]), & permutationStar22([0.4547545999844830_pREAL]), &
permutationStar211([0.2232010379623150_pReal, 0.0504792790607720_pReal]), & permutationStar211([0.2232010379623150_pREAL, 0.0504792790607720_pREAL]), &
permutationStar4([0.25_pReal]) ] permutationStar4([0.25_pREAL]) ]
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! 3D quintic (lower precision/unknown source) ! 3D quintic (lower precision/unknown source)
FEM_nQuadrature(3,5) = 56 FEM_nQuadrature(3,5) = 56
allocate(FEM_quadrature_weights(3,5)%p(FEM_nQuadrature(3,5))) allocate(FEM_quadrature_weights(3,5)%p(FEM_nQuadrature(3,5)))
FEM_quadrature_weights(3,5)%p(1:4) = 0.0010373112336140_pReal FEM_quadrature_weights(3,5)%p(1:4) = 0.0010373112336140_pREAL
FEM_quadrature_weights(3,5)%p(5:16) = 0.0096016645399480_pReal FEM_quadrature_weights(3,5)%p(5:16) = 0.0096016645399480_pREAL
FEM_quadrature_weights(3,5)%p(17:28) = 0.0164493976798232_pReal FEM_quadrature_weights(3,5)%p(17:28) = 0.0164493976798232_pREAL
FEM_quadrature_weights(3,5)%p(29:40) = 0.0153747766513310_pReal FEM_quadrature_weights(3,5)%p(29:40) = 0.0153747766513310_pREAL
FEM_quadrature_weights(3,5)%p(41:52) = 0.0293520118375230_pReal FEM_quadrature_weights(3,5)%p(41:52) = 0.0293520118375230_pREAL
FEM_quadrature_weights(3,5)%p(53:56) = 0.0366291366405108_pReal FEM_quadrature_weights(3,5)%p(53:56) = 0.0366291366405108_pREAL
FEM_quadrature_points (3,5)%p = [ & FEM_quadrature_points (3,5)%p = [ &
permutationStar31([0.0149520651530592_pReal]), & permutationStar31([0.0149520651530592_pREAL]), &
permutationStar211([0.0340960211962615_pReal, 0.1518319491659370_pReal]), & permutationStar211([0.0340960211962615_pREAL, 0.1518319491659370_pREAL]), &
permutationStar211([0.0462051504150017_pReal, 0.3549340560639790_pReal]), & permutationStar211([0.0462051504150017_pREAL, 0.3549340560639790_pREAL]), &
permutationStar211([0.2281904610687610_pReal, 0.0055147549744775_pReal]), & permutationStar211([0.2281904610687610_pREAL, 0.0055147549744775_pREAL]), &
permutationStar211([0.3523052600879940_pReal, 0.0992057202494530_pReal]), & permutationStar211([0.3523052600879940_pREAL, 0.0992057202494530_pREAL]), &
permutationStar31([0.1344783347929940_pReal]) ] permutationStar31([0.1344783347929940_pREAL]) ]
call selfTest() call selfTest()
@ -188,8 +188,8 @@ end subroutine FEM_quadrature_init
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function permutationStar3(point) result(qPt) pure function permutationStar3(point) result(qPt)
real(pReal), dimension(2) :: qPt real(pREAL), dimension(2) :: qPt
real(pReal), dimension(1), intent(in) :: point real(pREAL), dimension(1), intent(in) :: point
qPt = pack(matmul(triangle,reshape([ & qPt = pack(matmul(triangle,reshape([ &
@ -203,14 +203,14 @@ end function permutationStar3
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function permutationStar21(point) result(qPt) pure function permutationStar21(point) result(qPt)
real(pReal), dimension(6) :: qPt real(pREAL), dimension(6) :: qPt
real(pReal), dimension(1), intent(in) :: point real(pREAL), dimension(1), intent(in) :: point
qPt = pack(matmul(triangle,reshape([ & qPt = pack(matmul(triangle,reshape([ &
point(1), point(1), 1.0_pReal - 2.0_pReal*point(1), & point(1), point(1), 1.0_pREAL - 2.0_pREAL*point(1), &
point(1), 1.0_pReal - 2.0_pReal*point(1), point(1), & point(1), 1.0_pREAL - 2.0_pREAL*point(1), point(1), &
1.0_pReal - 2.0_pReal*point(1), point(1), point(1)],[3,3])),.true.) 1.0_pREAL - 2.0_pREAL*point(1), point(1), point(1)],[3,3])),.true.)
end function permutationStar21 end function permutationStar21
@ -220,17 +220,17 @@ end function permutationStar21
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function permutationStar111(point) result(qPt) pure function permutationStar111(point) result(qPt)
real(pReal), dimension(12) :: qPt real(pREAL), dimension(12) :: qPt
real(pReal), dimension(2), intent(in) :: point real(pREAL), dimension(2), intent(in) :: point
qPt = pack(matmul(triangle,reshape([ & qPt = pack(matmul(triangle,reshape([ &
point(1), point(2), 1.0_pReal - point(1) - point(2), & point(1), point(2), 1.0_pREAL - point(1) - point(2), &
point(1), 1.0_pReal - point(1) - point(2), point(2), & point(1), 1.0_pREAL - point(1) - point(2), point(2), &
point(2), point(1), 1.0_pReal - point(1) - point(2), & point(2), point(1), 1.0_pREAL - point(1) - point(2), &
point(2), 1.0_pReal - point(1) - point(2), point(1), & point(2), 1.0_pREAL - point(1) - point(2), point(1), &
1.0_pReal - point(1) - point(2), point(2), point(1), & 1.0_pREAL - point(1) - point(2), point(2), point(1), &
1.0_pReal - point(1) - point(2), point(1), point(2)],[3,6])),.true.) 1.0_pREAL - point(1) - point(2), point(1), point(2)],[3,6])),.true.)
end function permutationStar111 end function permutationStar111
@ -240,8 +240,8 @@ end function permutationStar111
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function permutationStar4(point) result(qPt) pure function permutationStar4(point) result(qPt)
real(pReal), dimension(3) :: qPt real(pREAL), dimension(3) :: qPt
real(pReal), dimension(1), intent(in) :: point real(pREAL), dimension(1), intent(in) :: point
qPt = pack(matmul(tetrahedron,reshape([ & qPt = pack(matmul(tetrahedron,reshape([ &
@ -255,15 +255,15 @@ end function permutationStar4
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function permutationStar31(point) result(qPt) pure function permutationStar31(point) result(qPt)
real(pReal), dimension(12) :: qPt real(pREAL), dimension(12) :: qPt
real(pReal), dimension(1), intent(in) :: point real(pREAL), dimension(1), intent(in) :: point
qPt = pack(matmul(tetrahedron,reshape([ & qPt = pack(matmul(tetrahedron,reshape([ &
point(1), point(1), point(1), 1.0_pReal - 3.0_pReal*point(1), & point(1), point(1), point(1), 1.0_pREAL - 3.0_pREAL*point(1), &
point(1), point(1), 1.0_pReal - 3.0_pReal*point(1), point(1), & point(1), point(1), 1.0_pREAL - 3.0_pREAL*point(1), point(1), &
point(1), 1.0_pReal - 3.0_pReal*point(1), point(1), point(1), & point(1), 1.0_pREAL - 3.0_pREAL*point(1), point(1), point(1), &
1.0_pReal - 3.0_pReal*point(1), point(1), point(1), point(1)],[4,4])),.true.) 1.0_pREAL - 3.0_pREAL*point(1), point(1), point(1), point(1)],[4,4])),.true.)
end function permutationStar31 end function permutationStar31
@ -273,17 +273,17 @@ end function permutationStar31
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
function permutationStar22(point) result(qPt) function permutationStar22(point) result(qPt)
real(pReal), dimension(18) :: qPt real(pREAL), dimension(18) :: qPt
real(pReal), dimension(1), intent(in) :: point real(pREAL), dimension(1), intent(in) :: point
qPt = pack(matmul(tetrahedron,reshape([ & qPt = pack(matmul(tetrahedron,reshape([ &
point(1), point(1), 0.5_pReal - point(1), 0.5_pReal - point(1), & point(1), point(1), 0.5_pREAL - point(1), 0.5_pREAL - point(1), &
point(1), 0.5_pReal - point(1), point(1), 0.5_pReal - point(1), & point(1), 0.5_pREAL - point(1), point(1), 0.5_pREAL - point(1), &
0.5_pReal - point(1), point(1), point(1), 0.5_pReal - point(1), & 0.5_pREAL - point(1), point(1), point(1), 0.5_pREAL - point(1), &
0.5_pReal - point(1), point(1), 0.5_pReal - point(1), point(1), & 0.5_pREAL - point(1), point(1), 0.5_pREAL - point(1), point(1), &
0.5_pReal - point(1), 0.5_pReal - point(1), point(1), point(1), & 0.5_pREAL - point(1), 0.5_pREAL - point(1), point(1), point(1), &
point(1), 0.5_pReal - point(1), 0.5_pReal - point(1), point(1)],[4,6])),.true.) point(1), 0.5_pREAL - point(1), 0.5_pREAL - point(1), point(1)],[4,6])),.true.)
end function permutationStar22 end function permutationStar22
@ -293,23 +293,23 @@ end function permutationStar22
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function permutationStar211(point) result(qPt) pure function permutationStar211(point) result(qPt)
real(pReal), dimension(36) :: qPt real(pREAL), dimension(36) :: qPt
real(pReal), dimension(2), intent(in) :: point real(pREAL), dimension(2), intent(in) :: point
qPt = pack(matmul(tetrahedron,reshape([ & qPt = pack(matmul(tetrahedron,reshape([ &
point(1), point(1), point(2), 1.0_pReal - 2.0_pReal*point(1) - point(2), & point(1), point(1), point(2), 1.0_pREAL - 2.0_pREAL*point(1) - point(2), &
point(1), point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(2), & point(1), point(1), 1.0_pREAL - 2.0_pREAL*point(1) - point(2), point(2), &
point(1), point(2), point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2), & point(1), point(2), point(1), 1.0_pREAL - 2.0_pREAL*point(1) - point(2), &
point(1), point(2), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(1), & point(1), point(2), 1.0_pREAL - 2.0_pREAL*point(1) - point(2), point(1), &
point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(1), point(2), & point(1), 1.0_pREAL - 2.0_pREAL*point(1) - point(2), point(1), point(2), &
point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(2), point(1), & point(1), 1.0_pREAL - 2.0_pREAL*point(1) - point(2), point(2), point(1), &
point(2), point(1), point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2), & point(2), point(1), point(1), 1.0_pREAL - 2.0_pREAL*point(1) - point(2), &
point(2), point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(1), & point(2), point(1), 1.0_pREAL - 2.0_pREAL*point(1) - point(2), point(1), &
point(2), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(1), point(1), & point(2), 1.0_pREAL - 2.0_pREAL*point(1) - point(2), point(1), point(1), &
1.0_pReal - 2.0_pReal*point(1) - point(2), point(1), point(1), point(2), & 1.0_pREAL - 2.0_pREAL*point(1) - point(2), point(1), point(1), point(2), &
1.0_pReal - 2.0_pReal*point(1) - point(2), point(1), point(2), point(1), & 1.0_pREAL - 2.0_pREAL*point(1) - point(2), point(1), point(2), point(1), &
1.0_pReal - 2.0_pReal*point(1) - point(2), point(2), point(1), point(1)],[4,12])),.true.) 1.0_pREAL - 2.0_pREAL*point(1) - point(2), point(2), point(1), point(1)],[4,12])),.true.)
end function permutationStar211 end function permutationStar211
@ -319,35 +319,35 @@ end function permutationStar211
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function permutationStar1111(point) result(qPt) pure function permutationStar1111(point) result(qPt)
real(pReal), dimension(72) :: qPt real(pREAL), dimension(72) :: qPt
real(pReal), dimension(3), intent(in) :: point real(pREAL), dimension(3), intent(in) :: point
qPt = pack(matmul(tetrahedron,reshape([ & qPt = pack(matmul(tetrahedron,reshape([ &
point(1), point(2), point(3), 1.0_pReal - point(1) - point(2)- point(3), & point(1), point(2), point(3), 1.0_pREAL - point(1) - point(2)- point(3), &
point(1), point(2), 1.0_pReal - point(1) - point(2)- point(3), point(3), & point(1), point(2), 1.0_pREAL - point(1) - point(2)- point(3), point(3), &
point(1), point(3), point(2), 1.0_pReal - point(1) - point(2)- point(3), & point(1), point(3), point(2), 1.0_pREAL - point(1) - point(2)- point(3), &
point(1), point(3), 1.0_pReal - point(1) - point(2)- point(3), point(2), & point(1), point(3), 1.0_pREAL - point(1) - point(2)- point(3), point(2), &
point(1), 1.0_pReal - point(1) - point(2)- point(3), point(2), point(3), & point(1), 1.0_pREAL - point(1) - point(2)- point(3), point(2), point(3), &
point(1), 1.0_pReal - point(1) - point(2)- point(3), point(3), point(2), & point(1), 1.0_pREAL - point(1) - point(2)- point(3), point(3), point(2), &
point(2), point(1), point(3), 1.0_pReal - point(1) - point(2)- point(3), & point(2), point(1), point(3), 1.0_pREAL - point(1) - point(2)- point(3), &
point(2), point(1), 1.0_pReal - point(1) - point(2)- point(3), point(3), & point(2), point(1), 1.0_pREAL - point(1) - point(2)- point(3), point(3), &
point(2), point(3), point(1), 1.0_pReal - point(1) - point(2)- point(3), & point(2), point(3), point(1), 1.0_pREAL - point(1) - point(2)- point(3), &
point(2), point(3), 1.0_pReal - point(1) - point(2)- point(3), point(1), & point(2), point(3), 1.0_pREAL - point(1) - point(2)- point(3), point(1), &
point(2), 1.0_pReal - point(1) - point(2)- point(3), point(1), point(3), & point(2), 1.0_pREAL - point(1) - point(2)- point(3), point(1), point(3), &
point(2), 1.0_pReal - point(1) - point(2)- point(3), point(3), point(1), & point(2), 1.0_pREAL - point(1) - point(2)- point(3), point(3), point(1), &
point(3), point(1), point(2), 1.0_pReal - point(1) - point(2)- point(3), & point(3), point(1), point(2), 1.0_pREAL - point(1) - point(2)- point(3), &
point(3), point(1), 1.0_pReal - point(1) - point(2)- point(3), point(2), & point(3), point(1), 1.0_pREAL - point(1) - point(2)- point(3), point(2), &
point(3), point(2), point(1), 1.0_pReal - point(1) - point(2)- point(3), & point(3), point(2), point(1), 1.0_pREAL - point(1) - point(2)- point(3), &
point(3), point(2), 1.0_pReal - point(1) - point(2)- point(3), point(1), & point(3), point(2), 1.0_pREAL - point(1) - point(2)- point(3), point(1), &
point(3), 1.0_pReal - point(1) - point(2)- point(3), point(1), point(2), & point(3), 1.0_pREAL - point(1) - point(2)- point(3), point(1), point(2), &
point(3), 1.0_pReal - point(1) - point(2)- point(3), point(2), point(1), & point(3), 1.0_pREAL - point(1) - point(2)- point(3), point(2), point(1), &
1.0_pReal - point(1) - point(2)- point(3), point(1), point(2), point(3), & 1.0_pREAL - point(1) - point(2)- point(3), point(1), point(2), point(3), &
1.0_pReal - point(1) - point(2)- point(3), point(1), point(3), point(2), & 1.0_pREAL - point(1) - point(2)- point(3), point(1), point(3), point(2), &
1.0_pReal - point(1) - point(2)- point(3), point(2), point(1), point(3), & 1.0_pREAL - point(1) - point(2)- point(3), point(2), point(1), point(3), &
1.0_pReal - point(1) - point(2)- point(3), point(2), point(3), point(1), & 1.0_pREAL - point(1) - point(2)- point(3), point(2), point(3), point(1), &
1.0_pReal - point(1) - point(2)- point(3), point(3), point(1), point(2), & 1.0_pREAL - point(1) - point(2)- point(3), point(3), point(1), point(2), &
1.0_pReal - point(1) - point(2)- point(3), point(3), point(2), point(1)],[4,24])),.true.) 1.0_pREAL - point(1) - point(2)- point(3), point(3), point(2), point(1)],[4,24])),.true.)
end function permutationStar1111 end function permutationStar1111
@ -358,12 +358,12 @@ end function permutationStar1111
subroutine selfTest subroutine selfTest
integer :: o, d, n integer :: o, d, n
real(pReal), dimension(2:3), parameter :: w = [3.0_pReal,2.0_pReal] real(pREAL), dimension(2:3), parameter :: w = [3.0_pREAL,2.0_pREAL]
do d = lbound(FEM_quadrature_weights,1), ubound(FEM_quadrature_weights,1) do d = lbound(FEM_quadrature_weights,1), ubound(FEM_quadrature_weights,1)
do o = lbound(FEM_quadrature_weights(d,:),1), ubound(FEM_quadrature_weights(d,:),1) do o = lbound(FEM_quadrature_weights(d,:),1), ubound(FEM_quadrature_weights(d,:),1)
if (dNeq(sum(FEM_quadrature_weights(d,o)%p),1.0_pReal,5e-15_pReal)) & if (dNeq(sum(FEM_quadrature_weights(d,o)%p),1.0_pREAL,5e-15_pREAL)) &
error stop 'quadrature weights' error stop 'quadrature weights'
end do end do
end do end do
@ -371,7 +371,7 @@ subroutine selfTest
do d = lbound(FEM_quadrature_points,1), ubound(FEM_quadrature_points,1) do d = lbound(FEM_quadrature_points,1), ubound(FEM_quadrature_points,1)
do o = lbound(FEM_quadrature_points(d,:),1), ubound(FEM_quadrature_points(d,:),1) do o = lbound(FEM_quadrature_points(d,:),1), ubound(FEM_quadrature_points(d,:),1)
n = size(FEM_quadrature_points(d,o)%p,1)/d n = size(FEM_quadrature_points(d,o)%p,1)/d
if (any(dNeq(sum(reshape(FEM_quadrature_points(d,o)%p,[d,n]),2),-real(n,pReal)/w(d),1.e-14_pReal))) & if (any(dNeq(sum(reshape(FEM_quadrature_points(d,o)%p,[d,n]),2),-real(n,pREAL)/w(d),1.e-14_pREAL))) &
error stop 'quadrature points' error stop 'quadrature points'
end do end do
end do end do

14
src/mesh/FEM_utilities.f90
View File

@ -29,7 +29,7 @@ module FEM_utilities
private private
logical, public :: cutBack = .false. !< cut back of BVP solver in case convergence is not achieved or a material point is terminally ill logical, public :: cutBack = .false. !< cut back of BVP solver in case convergence is not achieved or a material point is terminally ill
real(pReal), public, protected :: wgt !< weighting factor 1/Nelems real(pREAL), public, protected :: wgt !< weighting factor 1/Nelems
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
@ -59,7 +59,7 @@ module FEM_utilities
type, public :: tComponentBC type, public :: tComponentBC
integer(kind(COMPONENT_UNDEFINED_ID)) :: ID integer(kind(COMPONENT_UNDEFINED_ID)) :: ID
real(pReal), allocatable, dimension(:) :: Value real(pREAL), allocatable, dimension(:) :: Value
logical, allocatable, dimension(:) :: Mask logical, allocatable, dimension(:) :: Mask
end type tComponentBC end type tComponentBC
@ -128,7 +128,7 @@ subroutine FEM_utilities_init
call PetscOptionsInsertString(PETSC_NULL_OPTIONS,trim(petsc_optionsOrder),err_PETSc) call PetscOptionsInsertString(PETSC_NULL_OPTIONS,trim(petsc_optionsOrder),err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
wgt = real(mesh_maxNips*mesh_NcpElemsGlobal,pReal)**(-1) wgt = real(mesh_maxNips*mesh_NcpElemsGlobal,pREAL)**(-1)
end subroutine FEM_utilities_init end subroutine FEM_utilities_init
@ -139,9 +139,9 @@ end subroutine FEM_utilities_init
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine utilities_constitutiveResponse(timeinc,P_av,forwardData) subroutine utilities_constitutiveResponse(timeinc,P_av,forwardData)
real(pReal), intent(in) :: timeinc !< loading time real(pREAL), intent(in) :: timeinc !< loading time
logical, intent(in) :: forwardData !< age results logical, intent(in) :: forwardData !< age results
real(pReal),intent(out), dimension(3,3) :: P_av !< average PK stress real(pREAL),intent(out), dimension(3,3) :: P_av !< average PK stress
integer(MPI_INTEGER_KIND) :: err_MPI integer(MPI_INTEGER_KIND) :: err_MPI
@ -170,8 +170,8 @@ subroutine utilities_projectBCValues(localVec,section,field,comp,bcPointsIS,BCVa
PetscSection :: section PetscSection :: section
IS :: bcPointsIS IS :: bcPointsIS
PetscInt, pointer :: bcPoints(:) PetscInt, pointer :: bcPoints(:)
real(pReal), pointer :: localArray(:) real(pREAL), pointer :: localArray(:)
real(pReal) :: BCValue,BCDotValue,timeinc real(pREAL) :: BCValue,BCDotValue,timeinc
PetscErrorCode :: err_PETSc PetscErrorCode :: err_PETSc

18
src/mesh/discretization_mesh.f90
View File

@ -49,11 +49,11 @@ module discretization_mesh
PetscInt, dimension(:), allocatable, public, protected :: & PetscInt, dimension(:), allocatable, public, protected :: &
mesh_boundaries mesh_boundaries
real(pReal), dimension(:,:), allocatable :: & real(pREAL), dimension(:,:), allocatable :: &
mesh_ipVolume, & !< volume associated with IP (initially!) mesh_ipVolume, & !< volume associated with IP (initially!)
mesh_node0 !< node x,y,z coordinates (initially!) mesh_node0 !< node x,y,z coordinates (initially!)
real(pReal), dimension(:,:,:), allocatable :: & real(pREAL), dimension(:,:,:), allocatable :: &
mesh_ipCoordinates !< IP x,y,z coordinates (after deformation!) mesh_ipCoordinates !< IP x,y,z coordinates (after deformation!)
#ifdef PETSC_USE_64BIT_INDICES #ifdef PETSC_USE_64BIT_INDICES
@ -92,7 +92,7 @@ subroutine discretization_mesh_init(restart)
num_mesh num_mesh
integer :: p_i, dim !< integration order (quadrature rule) integer :: p_i, dim !< integration order (quadrature rule)
type(tvec) :: coords_node0 type(tvec) :: coords_node0
real(pReal), pointer, dimension(:) :: & real(pREAL), pointer, dimension(:) :: &
mesh_node0_temp mesh_node0_temp
print'(/,1x,a)', '<<<+- discretization_mesh init -+>>>' print'(/,1x,a)', '<<<+- discretization_mesh init -+>>>'
@ -176,7 +176,7 @@ subroutine discretization_mesh_init(restart)
end do end do
materialAt = materialAt + 1_pPETSCINT materialAt = materialAt + 1_pPETSCINT
allocate(mesh_node0(3,mesh_Nnodes),source=0.0_pReal) allocate(mesh_node0(3,mesh_Nnodes),source=0.0_pREAL)
mesh_node0(1:dimPlex,:) = reshape(mesh_node0_temp,[dimPlex,mesh_Nnodes]) mesh_node0(1:dimPlex,:) = reshape(mesh_node0_temp,[dimPlex,mesh_Nnodes])
@ -200,7 +200,7 @@ subroutine mesh_FEM_build_ipVolumes(dimPlex)
PetscInt :: cellStart, cellEnd, cell PetscInt :: cellStart, cellEnd, cell
PetscErrorCode :: err_PETSc PetscErrorCode :: err_PETSc
allocate(mesh_ipVolume(mesh_maxNips,mesh_NcpElems),source=0.0_pReal) allocate(mesh_ipVolume(mesh_maxNips,mesh_NcpElems),source=0.0_pREAL)
call DMPlexGetHeightStratum(geomMesh,0_pPETSCINT,cellStart,cellEnd,err_PETSc) call DMPlexGetHeightStratum(geomMesh,0_pPETSCINT,cellStart,cellEnd,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
@ -209,7 +209,7 @@ subroutine mesh_FEM_build_ipVolumes(dimPlex)
do cell = cellStart, cellEnd-1 do cell = cellStart, cellEnd-1
call DMPlexComputeCellGeometryFVM(geomMesh,cell,vol,pCent,pNorm,err_PETSc) call DMPlexComputeCellGeometryFVM(geomMesh,cell,vol,pCent,pNorm,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
mesh_ipVolume(:,cell+1) = vol/real(mesh_maxNips,pReal) mesh_ipVolume(:,cell+1) = vol/real(mesh_maxNips,pREAL)
end do end do
end subroutine mesh_FEM_build_ipVolumes end subroutine mesh_FEM_build_ipVolumes
@ -229,7 +229,7 @@ subroutine mesh_FEM_build_ipCoordinates(dimPlex,qPoints)
PetscErrorCode :: err_PETSc PetscErrorCode :: err_PETSc
allocate(mesh_ipCoordinates(3,mesh_maxNips,mesh_NcpElems),source=0.0_pReal) allocate(mesh_ipCoordinates(3,mesh_maxNips,mesh_NcpElems),source=0.0_pREAL)
allocate(pV0(dimPlex)) allocate(pV0(dimPlex))
allocatE(pCellJ(dimPlex**2)) allocatE(pCellJ(dimPlex**2))
@ -245,7 +245,7 @@ subroutine mesh_FEM_build_ipCoordinates(dimPlex,qPoints)
mesh_ipCoordinates(dirI,qPt,cell+1) = pV0(dirI) mesh_ipCoordinates(dirI,qPt,cell+1) = pV0(dirI)
do dirJ = 1_pPETSCINT, dimPlex do dirJ = 1_pPETSCINT, dimPlex
mesh_ipCoordinates(dirI,qPt,cell+1) = mesh_ipCoordinates(dirI,qPt,cell+1) + & mesh_ipCoordinates(dirI,qPt,cell+1) = mesh_ipCoordinates(dirI,qPt,cell+1) + &
pCellJ((dirI-1)*dimPlex+dirJ)*(qPoints(qOffset+dirJ) + 1.0_pReal) pCellJ((dirI-1)*dimPlex+dirJ)*(qPoints(qOffset+dirJ) + 1.0_pREAL)
end do end do
end do end do
qOffset = qOffset + dimPlex qOffset = qOffset + dimPlex
@ -259,7 +259,7 @@ end subroutine mesh_FEM_build_ipCoordinates
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine writeGeometry(coordinates_points,coordinates_nodes) subroutine writeGeometry(coordinates_points,coordinates_nodes)
real(pReal), dimension(:,:), intent(in) :: & real(pREAL), dimension(:,:), intent(in) :: &
coordinates_nodes, & coordinates_nodes, &
coordinates_points coordinates_points

102
src/mesh/mesh_mech_FEM.f90
View File

@ -37,7 +37,7 @@ module mesh_mechanical_FEM
! derived types ! derived types
type tSolutionParams type tSolutionParams
type(tFieldBC) :: fieldBC type(tFieldBC) :: fieldBC
real(pReal) :: timeinc real(pREAL) :: timeinc
end type tSolutionParams end type tSolutionParams
type(tSolutionParams) :: params type(tSolutionParams) :: params
@ -48,7 +48,7 @@ module mesh_mechanical_FEM
itmax itmax
logical :: & logical :: &
BBarStabilisation BBarStabilisation
real(pReal) :: & real(pREAL) :: &
eps_struct_atol, & !< absolute tolerance for mechanical equilibrium eps_struct_atol, & !< absolute tolerance for mechanical equilibrium
eps_struct_rtol !< relative tolerance for mechanical equilibrium eps_struct_rtol !< relative tolerance for mechanical equilibrium
end type tNumerics end type tNumerics
@ -66,10 +66,10 @@ module mesh_mechanical_FEM
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! stress, stiffness and compliance average etc. ! stress, stiffness and compliance average etc.
character(len=pSTRLEN) :: incInfo character(len=pSTRLEN) :: incInfo
real(pReal), dimension(3,3) :: & real(pREAL), dimension(3,3) :: &
P_av = 0.0_pReal P_av = 0.0_pREAL
logical :: ForwardData logical :: ForwardData
real(pReal), parameter :: eps = 1.0e-18_pReal real(pREAL), parameter :: eps = 1.0e-18_pREAL
external :: & ! ToDo: write interfaces external :: & ! ToDo: write interfaces
#ifdef PETSC_USE_64BIT_INDICES #ifdef PETSC_USE_64BIT_INDICES
@ -120,12 +120,12 @@ subroutine FEM_mechanical_init(fieldBC)
PetscReal :: detJ PetscReal :: detJ
PetscReal, allocatable, target :: cellJMat(:,:) PetscReal, allocatable, target :: cellJMat(:,:)
real(pReal), pointer, dimension(:) :: px_scal real(pREAL), pointer, dimension(:) :: px_scal
real(pReal), allocatable, target, dimension(:) :: x_scal real(pREAL), allocatable, target, dimension(:) :: x_scal
character(len=*), parameter :: prefix = 'mechFE_' character(len=*), parameter :: prefix = 'mechFE_'
PetscErrorCode :: err_PETSc PetscErrorCode :: err_PETSc
real(pReal), dimension(3,3) :: devNull real(pREAL), dimension(3,3) :: devNull
type(tDict), pointer :: & type(tDict), pointer :: &
num_mesh num_mesh
@ -137,12 +137,12 @@ subroutine FEM_mechanical_init(fieldBC)
num%p_i = int(num_mesh%get_asInt('p_i',defaultVal = 2),pPETSCINT) num%p_i = int(num_mesh%get_asInt('p_i',defaultVal = 2),pPETSCINT)
num%itmax = int(num_mesh%get_asInt('itmax',defaultVal=250),pPETSCINT) num%itmax = int(num_mesh%get_asInt('itmax',defaultVal=250),pPETSCINT)
num%BBarStabilisation = num_mesh%get_asBool('bbarstabilisation',defaultVal = .false.) num%BBarStabilisation = num_mesh%get_asBool('bbarstabilisation',defaultVal = .false.)
num%eps_struct_atol = num_mesh%get_asReal('eps_struct_atol', defaultVal = 1.0e-10_pReal) num%eps_struct_atol = num_mesh%get_asReal('eps_struct_atol', defaultVal = 1.0e-10_pREAL)
num%eps_struct_rtol = num_mesh%get_asReal('eps_struct_rtol', defaultVal = 1.0e-4_pReal) num%eps_struct_rtol = num_mesh%get_asReal('eps_struct_rtol', defaultVal = 1.0e-4_pREAL)
if (num%itmax <= 1) call IO_error(301,ext_msg='itmax') if (num%itmax <= 1) call IO_error(301,ext_msg='itmax')
if (num%eps_struct_rtol <= 0.0_pReal) call IO_error(301,ext_msg='eps_struct_rtol') if (num%eps_struct_rtol <= 0.0_pREAL) call IO_error(301,ext_msg='eps_struct_rtol')
if (num%eps_struct_atol <= 0.0_pReal) call IO_error(301,ext_msg='eps_struct_atol') if (num%eps_struct_atol <= 0.0_pREAL) call IO_error(301,ext_msg='eps_struct_atol')
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! Setup FEM mech mesh ! Setup FEM mech mesh
@ -264,16 +264,16 @@ subroutine FEM_mechanical_init(fieldBC)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call SNESSetConvergenceTest(mechanical_snes,FEM_mechanical_converged,PETSC_NULL_VEC,PETSC_NULL_FUNCTION,err_PETSc) call SNESSetConvergenceTest(mechanical_snes,FEM_mechanical_converged,PETSC_NULL_VEC,PETSC_NULL_FUNCTION,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call SNESSetTolerances(mechanical_snes,1.0_pReal,0.0_pReal,0.0_pReal,num%itmax,num%itmax,err_PETSc) call SNESSetTolerances(mechanical_snes,1.0_pREAL,0.0_pREAL,0.0_pREAL,num%itmax,num%itmax,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call SNESSetFromOptions(mechanical_snes,err_PETSc) call SNESSetFromOptions(mechanical_snes,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! init fields ! init fields
call VecSet(solution ,0.0_pReal,err_PETSc) call VecSet(solution ,0.0_pREAL,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call VecSet(solution_rate,0.0_pReal,err_PETSc) call VecSet(solution_rate,0.0_pREAL,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
allocate(x_scal(cellDof)) allocate(x_scal(cellDof))
allocate(nodalWeightsP(1)) allocate(nodalWeightsP(1))
@ -289,7 +289,7 @@ subroutine FEM_mechanical_init(fieldBC)
call DMPlexGetHeightStratum(mechanical_mesh,0_pPETSCINT,cellStart,cellEnd,err_PETSc) call DMPlexGetHeightStratum(mechanical_mesh,0_pPETSCINT,cellStart,cellEnd,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
do cell = cellStart, cellEnd-1 !< loop over all elements do cell = cellStart, cellEnd-1 !< loop over all elements
x_scal = 0.0_pReal x_scal = 0.0_pREAL
call DMPlexComputeCellGeometryAffineFEM(mechanical_mesh,cell,pV0,pCellJ,pInvcellJ,detJ,err_PETSc) call DMPlexComputeCellGeometryAffineFEM(mechanical_mesh,cell,pV0,pCellJ,pInvcellJ,detJ,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
cellJMat = reshape(pCellJ,shape=[dimPlex,dimPlex]) cellJMat = reshape(pCellJ,shape=[dimPlex,dimPlex])
@ -298,13 +298,13 @@ subroutine FEM_mechanical_init(fieldBC)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call PetscQuadratureGetData(functional,dimPlex,nc,nNodalPoints,nodalPointsP,nodalWeightsP,err_PETSc) call PetscQuadratureGetData(functional,dimPlex,nc,nNodalPoints,nodalPointsP,nodalWeightsP,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
x_scal(basis+1:basis+dimPlex) = pV0 + matmul(transpose(cellJMat),nodalPointsP + 1.0_pReal) x_scal(basis+1:basis+dimPlex) = pV0 + matmul(transpose(cellJMat),nodalPointsP + 1.0_pREAL)
end do end do
px_scal => x_scal px_scal => x_scal
call DMPlexVecSetClosure(mechanical_mesh,section,solution_local,cell,px_scal,5,err_PETSc) call DMPlexVecSetClosure(mechanical_mesh,section,solution_local,cell,px_scal,5,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
end do end do
call utilities_constitutiveResponse(0.0_pReal,devNull,.true.) call utilities_constitutiveResponse(0.0_pREAL,devNull,.true.)
end subroutine FEM_mechanical_init end subroutine FEM_mechanical_init
@ -317,7 +317,7 @@ type(tSolutionState) function FEM_mechanical_solution( &
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! input data for solution ! input data for solution
real(pReal), intent(in) :: & real(pREAL), intent(in) :: &
timeinc, & !< increment in time for current solution timeinc, & !< increment in time for current solution
timeinc_old !< increment in time of last increment timeinc_old !< increment in time of last increment
type(tFieldBC), intent(in) :: & type(tFieldBC), intent(in) :: &
@ -369,8 +369,8 @@ subroutine FEM_mechanical_formResidual(dm_local,xx_local,f_local,dummy,err_PETSc
PetscDS :: prob PetscDS :: prob
Vec :: x_local, f_local, xx_local Vec :: x_local, f_local, xx_local
PetscSection :: section PetscSection :: section
real(pReal), dimension(:), pointer :: x_scal, pf_scal real(pREAL), dimension(:), pointer :: x_scal, pf_scal
real(pReal), dimension(cellDof), target :: f_scal real(pREAL), dimension(cellDof), target :: f_scal
PetscReal :: IcellJMat(dimPlex,dimPlex) PetscReal :: IcellJMat(dimPlex,dimPlex)
PetscReal, dimension(:),pointer :: pV0, pCellJ, pInvcellJ, basisField, basisFieldDer PetscReal, dimension(:),pointer :: pV0, pCellJ, pInvcellJ, basisField, basisFieldDer
PetscInt :: cellStart, cellEnd, cell, field, face, & PetscInt :: cellStart, cellEnd, cell, field, face, &
@ -397,7 +397,7 @@ subroutine FEM_mechanical_formResidual(dm_local,xx_local,f_local,dummy,err_PETSc
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call DMGetLocalVector(dm_local,x_local,err_PETSc) call DMGetLocalVector(dm_local,x_local,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call VecWAXPY(x_local,1.0_pReal,xx_local,solution_local,err_PETSc) call VecWAXPY(x_local,1.0_pREAL,xx_local,solution_local,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
do field = 1_pPETSCINT, dimPlex; do face = 1_pPETSCINT, mesh_Nboundaries do field = 1_pPETSCINT, dimPlex; do face = 1_pPETSCINT, mesh_Nboundaries
if (params%fieldBC%componentBC(field)%Mask(face)) then if (params%fieldBC%componentBC(field)%Mask(face)) then
@ -406,7 +406,7 @@ subroutine FEM_mechanical_formResidual(dm_local,xx_local,f_local,dummy,err_PETSc
call DMGetStratumIS(dm_local,'Face Sets',mesh_boundaries(face),bcPoints,err_PETSc) call DMGetStratumIS(dm_local,'Face Sets',mesh_boundaries(face),bcPoints,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call utilities_projectBCValues(x_local,section,0_pPETSCINT,field-1,bcPoints, & call utilities_projectBCValues(x_local,section,0_pPETSCINT,field-1,bcPoints, &
0.0_pReal,params%fieldBC%componentBC(field)%Value(face),params%timeinc) 0.0_pREAL,params%fieldBC%componentBC(field)%Value(face),params%timeinc)
call ISDestroy(bcPoints,err_PETSc) call ISDestroy(bcPoints,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
end if end if
@ -426,7 +426,7 @@ subroutine FEM_mechanical_formResidual(dm_local,xx_local,f_local,dummy,err_PETSc
IcellJMat = reshape(pInvcellJ,shape=[dimPlex,dimPlex]) IcellJMat = reshape(pInvcellJ,shape=[dimPlex,dimPlex])
do qPt = 0_pPETSCINT, nQuadrature-1_pPETSCINT do qPt = 0_pPETSCINT, nQuadrature-1_pPETSCINT
m = cell*nQuadrature + qPt+1_pPETSCINT m = cell*nQuadrature + qPt+1_pPETSCINT
BMat = 0.0_pReal BMat = 0.0_pREAL
do basis = 0_pPETSCINT, nBasis-1_pPETSCINT do basis = 0_pPETSCINT, nBasis-1_pPETSCINT
do comp = 0_pPETSCINT, dimPlex-1_pPETSCINT do comp = 0_pPETSCINT, dimPlex-1_pPETSCINT
cidx = basis*dimPlex+comp cidx = basis*dimPlex+comp
@ -438,11 +438,11 @@ subroutine FEM_mechanical_formResidual(dm_local,xx_local,f_local,dummy,err_PETSc
homogenization_F(1:dimPlex,1:dimPlex,m) = reshape(matmul(BMat,x_scal),shape=[dimPlex,dimPlex], order=[2,1]) homogenization_F(1:dimPlex,1:dimPlex,m) = reshape(matmul(BMat,x_scal),shape=[dimPlex,dimPlex], order=[2,1])
end do end do
if (num%BBarStabilisation) then if (num%BBarStabilisation) then
detFAvg = math_det33(sum(homogenization_F(1:3,1:3,cell*nQuadrature+1:(cell+1)*nQuadrature),dim=3)/real(nQuadrature,pReal)) detFAvg = math_det33(sum(homogenization_F(1:3,1:3,cell*nQuadrature+1:(cell+1)*nQuadrature),dim=3)/real(nQuadrature,pREAL))
do qPt = 0, nQuadrature-1 do qPt = 0, nQuadrature-1
m = cell*nQuadrature + qPt+1 m = cell*nQuadrature + qPt+1
homogenization_F(1:dimPlex,1:dimPlex,m) = homogenization_F(1:dimPlex,1:dimPlex,m) & homogenization_F(1:dimPlex,1:dimPlex,m) = homogenization_F(1:dimPlex,1:dimPlex,m) &
* (detFAvg/math_det33(homogenization_F(1:3,1:3,m)))**(1.0_pReal/real(dimPlex,pReal)) * (detFAvg/math_det33(homogenization_F(1:3,1:3,m)))**(1.0_pREAL/real(dimPlex,pREAL))
end do end do
end if end if
@ -465,10 +465,10 @@ subroutine FEM_mechanical_formResidual(dm_local,xx_local,f_local,dummy,err_PETSc
call DMPlexComputeCellGeometryAffineFEM(dm_local,cell,pV0,pCellJ,pInvcellJ,detJ,err_PETSc) call DMPlexComputeCellGeometryAffineFEM(dm_local,cell,pV0,pCellJ,pInvcellJ,detJ,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
IcellJMat = reshape(pInvcellJ,shape=[dimPlex,dimPlex]) IcellJMat = reshape(pInvcellJ,shape=[dimPlex,dimPlex])
f_scal = 0.0_pReal f_scal = 0.0_pREAL
do qPt = 0_pPETSCINT, nQuadrature-1_pPETSCINT do qPt = 0_pPETSCINT, nQuadrature-1_pPETSCINT
m = cell*nQuadrature + qPt+1_pPETSCINT m = cell*nQuadrature + qPt+1_pPETSCINT
BMat = 0.0_pReal BMat = 0.0_pREAL
do basis = 0_pPETSCINT, nBasis-1_pPETSCINT do basis = 0_pPETSCINT, nBasis-1_pPETSCINT
do comp = 0_pPETSCINT, dimPlex-1_pPETSCINT do comp = 0_pPETSCINT, dimPlex-1_pPETSCINT
cidx = basis*dimPlex+comp cidx = basis*dimPlex+comp
@ -517,10 +517,10 @@ subroutine FEM_mechanical_formJacobian(dm_local,xx_local,Jac_pre,Jac,dummy,err_P
PetscReal, dimension(:), pointer :: basisField, basisFieldDer, & PetscReal, dimension(:), pointer :: basisField, basisFieldDer, &
pV0, pCellJ, pInvcellJ pV0, pCellJ, pInvcellJ
real(pReal), dimension(:), pointer :: pK_e, x_scal real(pREAL), dimension(:), pointer :: pK_e, x_scal
real(pReal),dimension(cellDOF,cellDOF), target :: K_e real(pREAL),dimension(cellDOF,cellDOF), target :: K_e
real(pReal),dimension(cellDOF,cellDOF) :: K_eA, K_eB real(pREAL),dimension(cellDOF,cellDOF) :: K_eA, K_eB
PetscInt :: cellStart, cellEnd, cell, field, face, & PetscInt :: cellStart, cellEnd, cell, field, face, &
qPt, basis, comp, cidx,bcSize, m, i qPt, basis, comp, cidx,bcSize, m, i
@ -547,7 +547,7 @@ subroutine FEM_mechanical_formJacobian(dm_local,xx_local,Jac_pre,Jac,dummy,err_P
call DMGetLocalVector(dm_local,x_local,err_PETSc) call DMGetLocalVector(dm_local,x_local,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call VecWAXPY(x_local,1.0_pReal,xx_local,solution_local,err_PETSc) call VecWAXPY(x_local,1.0_pREAL,xx_local,solution_local,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
do field = 1, dimPlex; do face = 1, mesh_Nboundaries do field = 1, dimPlex; do face = 1, mesh_Nboundaries
if (params%fieldBC%componentBC(field)%Mask(face)) then if (params%fieldBC%componentBC(field)%Mask(face)) then
@ -556,7 +556,7 @@ subroutine FEM_mechanical_formJacobian(dm_local,xx_local,Jac_pre,Jac,dummy,err_P
call DMGetStratumIS(dm_local,'Face Sets',mesh_boundaries(face),bcPoints,err_PETSc) call DMGetStratumIS(dm_local,'Face Sets',mesh_boundaries(face),bcPoints,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call utilities_projectBCValues(x_local,section,0_pPETSCINT,field-1,bcPoints, & call utilities_projectBCValues(x_local,section,0_pPETSCINT,field-1,bcPoints, &
0.0_pReal,params%fieldBC%componentBC(field)%Value(face),params%timeinc) 0.0_pREAL,params%fieldBC%componentBC(field)%Value(face),params%timeinc)
call ISDestroy(bcPoints,err_PETSc) call ISDestroy(bcPoints,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
end if end if
@ -569,14 +569,14 @@ subroutine FEM_mechanical_formJacobian(dm_local,xx_local,Jac_pre,Jac,dummy,err_P
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call DMPlexComputeCellGeometryAffineFEM(dm_local,cell,pV0,pCellJ,pInvcellJ,detJ,err_PETSc) call DMPlexComputeCellGeometryAffineFEM(dm_local,cell,pV0,pCellJ,pInvcellJ,detJ,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
K_eA = 0.0_pReal K_eA = 0.0_pREAL
K_eB = 0.0_pReal K_eB = 0.0_pREAL
MatB = 0.0_pReal MatB = 0.0_pREAL
FAvg = 0.0_pReal FAvg = 0.0_pREAL
BMatAvg = 0.0_pReal BMatAvg = 0.0_pREAL
do qPt = 0_pPETSCINT, nQuadrature-1_pPETSCINT do qPt = 0_pPETSCINT, nQuadrature-1_pPETSCINT
m = cell*nQuadrature + qPt + 1_pPETSCINT m = cell*nQuadrature + qPt + 1_pPETSCINT
BMat = 0.0_pReal BMat = 0.0_pREAL
do basis = 0_pPETSCINT, nBasis-1_pPETSCINT do basis = 0_pPETSCINT, nBasis-1_pPETSCINT
do comp = 0_pPETSCINT, dimPlex-1_pPETSCINT do comp = 0_pPETSCINT, dimPlex-1_pPETSCINT
cidx = basis*dimPlex+comp cidx = basis*dimPlex+comp
@ -591,7 +591,7 @@ subroutine FEM_mechanical_formJacobian(dm_local,xx_local,Jac_pre,Jac,dummy,err_P
if (num%BBarStabilisation) then if (num%BBarStabilisation) then
F(1:dimPlex,1:dimPlex) = reshape(matmul(BMat,x_scal),shape=[dimPlex,dimPlex]) F(1:dimPlex,1:dimPlex) = reshape(matmul(BMat,x_scal),shape=[dimPlex,dimPlex])
FInv = math_inv33(F) FInv = math_inv33(F)
K_eA = K_eA + matmul(transpose(BMat),MatA)*math_det33(FInv)**(1.0_pReal/real(dimPlex,pReal)) K_eA = K_eA + matmul(transpose(BMat),MatA)*math_det33(FInv)**(1.0_pREAL/real(dimPlex,pREAL))
K_eB = K_eB - & K_eB = K_eB - &
matmul(transpose(matmul(reshape(homogenization_F(1:dimPlex,1:dimPlex,m),shape=[dimPlex**2,1_pPETSCINT]), & matmul(transpose(matmul(reshape(homogenization_F(1:dimPlex,1:dimPlex,m),shape=[dimPlex**2,1_pPETSCINT]), &
matmul(reshape(FInv(1:dimPlex,1:dimPlex), & matmul(reshape(FInv(1:dimPlex,1:dimPlex), &
@ -606,10 +606,10 @@ subroutine FEM_mechanical_formJacobian(dm_local,xx_local,Jac_pre,Jac,dummy,err_P
end do end do
if (num%BBarStabilisation) then if (num%BBarStabilisation) then
FInv = math_inv33(FAvg) FInv = math_inv33(FAvg)
K_e = K_eA*math_det33(FAvg/real(nQuadrature,pReal))**(1.0_pReal/real(dimPlex,pReal)) + & K_e = K_eA*math_det33(FAvg/real(nQuadrature,pREAL))**(1.0_pREAL/real(dimPlex,pREAL)) + &
(matmul(matmul(transpose(BMatAvg), & (matmul(matmul(transpose(BMatAvg), &
reshape(FInv(1:dimPlex,1:dimPlex),shape=[dimPlex**2,1_pPETSCINT],order=[2,1])),MatB) + & reshape(FInv(1:dimPlex,1:dimPlex),shape=[dimPlex**2,1_pPETSCINT],order=[2,1])),MatB) + &
K_eB)/real(dimPlex,pReal) K_eB)/real(dimPlex,pREAL)
else else
K_e = K_eA K_e = K_eA
end if end if
@ -662,7 +662,7 @@ subroutine FEM_mechanical_forward(guess,timeinc,timeinc_old,fieldBC)
type(tFieldBC), intent(in) :: & type(tFieldBC), intent(in) :: &
fieldBC fieldBC
real(pReal), intent(in) :: & real(pREAL), intent(in) :: &
timeinc_old, & timeinc_old, &
timeinc timeinc
logical, intent(in) :: & logical, intent(in) :: &
@ -686,13 +686,13 @@ subroutine FEM_mechanical_forward(guess,timeinc,timeinc_old,fieldBC)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call DMGetLocalVector(dm_local,x_local,err_PETSc) call DMGetLocalVector(dm_local,x_local,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call VecSet(x_local,0.0_pReal,err_PETSc) call VecSet(x_local,0.0_pREAL,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call DMGlobalToLocalBegin(dm_local,solution,INSERT_VALUES,x_local,err_PETSc) !< retrieve my partition of global solution vector call DMGlobalToLocalBegin(dm_local,solution,INSERT_VALUES,x_local,err_PETSc) !< retrieve my partition of global solution vector
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call DMGlobalToLocalEnd(dm_local,solution,INSERT_VALUES,x_local,err_PETSc) call DMGlobalToLocalEnd(dm_local,solution,INSERT_VALUES,x_local,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call VecAXPY(solution_local,1.0_pReal,x_local,err_PETSc) call VecAXPY(solution_local,1.0_pREAL,x_local,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
do field = 1, dimPlex; do face = 1, mesh_Nboundaries do field = 1, dimPlex; do face = 1, mesh_Nboundaries
if (fieldBC%componentBC(field)%Mask(face)) then if (fieldBC%componentBC(field)%Mask(face)) then
@ -701,7 +701,7 @@ subroutine FEM_mechanical_forward(guess,timeinc,timeinc_old,fieldBC)
call DMGetStratumIS(dm_local,'Face Sets',mesh_boundaries(face),bcPoints,err_PETSc) call DMGetStratumIS(dm_local,'Face Sets',mesh_boundaries(face),bcPoints,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call utilities_projectBCValues(solution_local,section,0_pPETSCINT,field-1,bcPoints, & call utilities_projectBCValues(solution_local,section,0_pPETSCINT,field-1,bcPoints, &
0.0_pReal,fieldBC%componentBC(field)%Value(face),timeinc_old) 0.0_pREAL,fieldBC%componentBC(field)%Value(face),timeinc_old)
call ISDestroy(bcPoints,err_PETSc) call ISDestroy(bcPoints,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
end if end if
@ -746,7 +746,7 @@ subroutine FEM_mechanical_converged(snes_local,PETScIter,xnorm,snorm,fnorm,reaso
print'(/,1x,a,a,i0,a,f0.3)', trim(incInfo), & print'(/,1x,a,a,i0,a,f0.3)', trim(incInfo), &
' @ Iteration ',PETScIter,' mechanical residual norm = ',fnorm/divTol ' @ Iteration ',PETScIter,' mechanical residual norm = ',fnorm/divTol
print'(/,1x,a,/,2(3(2x,f12.4,1x)/),3(2x,f12.4,1x))', & print'(/,1x,a,/,2(3(2x,f12.4,1x)/),3(2x,f12.4,1x))', &
'Piola--Kirchhoff stress / MPa =',transpose(P_av)*1.e-6_pReal 'Piola--Kirchhoff stress / MPa =',transpose(P_av)*1.e-6_pREAL
flush(IO_STDOUT) flush(IO_STDOUT)
end subroutine FEM_mechanical_converged end subroutine FEM_mechanical_converged
@ -759,7 +759,7 @@ subroutine FEM_mechanical_updateCoords()
PetscReal, pointer, dimension(:,:) :: & PetscReal, pointer, dimension(:,:) :: &
nodeCoords !< nodal coordinates (3,Nnodes) nodeCoords !< nodal coordinates (3,Nnodes)
real(pReal), pointer, dimension(:,:,:) :: & real(pREAL), pointer, dimension(:,:,:) :: &
ipCoords !< ip coordinates (3,nQuadrature,mesh_NcpElems) ipCoords !< ip coordinates (3,nQuadrature,mesh_NcpElems)
integer :: & integer :: &
@ -777,7 +777,7 @@ subroutine FEM_mechanical_updateCoords()
PetscQuadrature :: mechQuad PetscQuadrature :: mechQuad
PetscReal, dimension(:), pointer :: basisField, basisFieldDer, & PetscReal, dimension(:), pointer :: basisField, basisFieldDer, &
nodeCoords_linear !< nodal coordinates (dimPlex*Nnodes) nodeCoords_linear !< nodal coordinates (dimPlex*Nnodes)
real(pReal), dimension(:), pointer :: x_scal real(pREAL), dimension(:), pointer :: x_scal
call SNESGetDM(mechanical_snes,dm_local,err_PETSc) call SNESGetDM(mechanical_snes,dm_local,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
@ -793,7 +793,7 @@ subroutine FEM_mechanical_updateCoords()
! write cell vertex displacements ! write cell vertex displacements
call DMPlexGetDepthStratum(dm_local,0_pPETSCINT,pStart,pEnd,err_PETSc) call DMPlexGetDepthStratum(dm_local,0_pPETSCINT,pStart,pEnd,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
allocate(nodeCoords(3,pStart:pEnd-1),source=0.0_pReal) allocate(nodeCoords(3,pStart:pEnd-1),source=0.0_pREAL)
call VecGetArrayF90(x_local,nodeCoords_linear,err_PETSc) call VecGetArrayF90(x_local,nodeCoords_linear,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
do p=pStart, pEnd-1 do p=pStart, pEnd-1
@ -811,7 +811,7 @@ subroutine FEM_mechanical_updateCoords()
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call PetscDSGetTabulation(mechQuad,0_pPETSCINT,basisField,basisFieldDer,err_PETSc) call PetscDSGetTabulation(mechQuad,0_pPETSCINT,basisField,basisFieldDer,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
allocate(ipCoords(3,nQuadrature,mesh_NcpElems),source=0.0_pReal) allocate(ipCoords(3,nQuadrature,mesh_NcpElems),source=0.0_pREAL)
do c=cellStart,cellEnd-1_pPETSCINT do c=cellStart,cellEnd-1_pPETSCINT
qOffset=0 qOffset=0
call DMPlexVecGetClosure(dm_local,section,x_local,c,x_scal,err_PETSc) !< get nodal coordinates of each element call DMPlexVecGetClosure(dm_local,section,x_local,c,x_scal,err_PETSc) !< get nodal coordinates of each element

20
src/misc.f90
View File

@ -78,9 +78,9 @@ end function misc_optional_int
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function misc_optional_real(given,default) result(var) pure function misc_optional_real(given,default) result(var)
real(pReal), intent(in), optional :: given real(pREAL), intent(in), optional :: given
real(pReal), intent(in) :: default real(pREAL), intent(in) :: default
real(pReal) :: var real(pREAL) :: var
if (present(given)) then if (present(given)) then
@ -116,7 +116,7 @@ end function misc_optional_str
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine misc_selfTest() subroutine misc_selfTest()
real(pReal) :: r real(pREAL) :: r
call random_number(r) call random_number(r)
if (test_str('DAMASK') /= 'DAMASK') error stop 'optional_str, present' if (test_str('DAMASK') /= 'DAMASK') error stop 'optional_str, present'
@ -126,11 +126,11 @@ subroutine misc_selfTest()
if (test_int() /= 42) error stop 'optional_int, not present' if (test_int() /= 42) error stop 'optional_int, not present'
if (misc_optional(default=20191102) /= 20191102) error stop 'optional_int, default only' if (misc_optional(default=20191102) /= 20191102) error stop 'optional_int, default only'
if (dNeq(test_real(r),r)) error stop 'optional_real, present' if (dNeq(test_real(r),r)) error stop 'optional_real, present'
if (dNeq(test_real(),0.0_pReal)) error stop 'optional_real, not present' if (dNeq(test_real(),0.0_pREAL)) error stop 'optional_real, not present'
if (dNeq(misc_optional(default=r),r)) error stop 'optional_real, default only' if (dNeq(misc_optional(default=r),r)) error stop 'optional_real, default only'
if (test_bool(r<0.5_pReal) .neqv. r<0.5_pReal) error stop 'optional_bool, present' if (test_bool(r<0.5_pREAL) .neqv. r<0.5_pREAL) error stop 'optional_bool, present'
if (.not. test_bool()) error stop 'optional_bool, not present' if (.not. test_bool()) error stop 'optional_bool, not present'
if (misc_optional(default=r>0.5_pReal) .neqv. r>0.5_pReal) error stop 'optional_bool, default only' if (misc_optional(default=r>0.5_pREAL) .neqv. r>0.5_pREAL) error stop 'optional_bool, default only'
contains contains
@ -158,11 +158,11 @@ contains
function test_real(real_in) result(real_out) function test_real(real_in) result(real_out)
real(pReal) :: real_out real(pREAL) :: real_out
real(pReal), intent(in), optional :: real_in real(pREAL), intent(in), optional :: real_in
real_out = misc_optional_real(real_in,0.0_pReal) real_out = misc_optional_real(real_in,0.0_pREAL)
end function test_real end function test_real

4
src/parallelization.f90
View File

@ -135,8 +135,8 @@ subroutine parallelization_init()
call MPI_Type_size(MPI_DOUBLE,typeSize,err_MPI) call MPI_Type_size(MPI_DOUBLE,typeSize,err_MPI)
if (err_MPI /= 0_MPI_INTEGER_KIND) & if (err_MPI /= 0_MPI_INTEGER_KIND) &
error stop 'Could not determine size of MPI_DOUBLE' error stop 'Could not determine size of MPI_DOUBLE'
if (typeSize*8_MPI_INTEGER_KIND /= int(storage_size(0.0_pReal),MPI_INTEGER_KIND)) & if (typeSize*8_MPI_INTEGER_KIND /= int(storage_size(0.0_pREAL),MPI_INTEGER_KIND)) &
error stop 'Mismatch between MPI_DOUBLE and DAMASK pReal' error stop 'Mismatch between MPI_DOUBLE and DAMASK pREAL'
!$ call get_environment_variable(name='OMP_NUM_THREADS',value=NumThreadsString,STATUS=got_env) !$ call get_environment_variable(name='OMP_NUM_THREADS',value=NumThreadsString,STATUS=got_env)
!$ if (got_env /= 0) then !$ if (got_env /= 0) then

128
src/phase.f90
View File

@ -29,15 +29,15 @@ module phase
sizeDotState = 0, & !< size of dot state, i.e. state(1:sizeDot) follows time evolution by dotState rates sizeDotState = 0, & !< size of dot state, i.e. state(1:sizeDot) follows time evolution by dotState rates
offsetDeltaState = 0, & !< index offset of delta state offsetDeltaState = 0, & !< index offset of delta state
sizeDeltaState = 0 !< size of delta state, i.e. state(offset+1:offset+sizeDelta) follows time evolution by deltaState increments sizeDeltaState = 0 !< size of delta state, i.e. state(offset+1:offset+sizeDelta) follows time evolution by deltaState increments
real(pReal), allocatable, dimension(:) :: & real(pREAL), allocatable, dimension(:) :: &
atol atol
! http://stackoverflow.com/questions/3948210 ! http://stackoverflow.com/questions/3948210
real(pReal), pointer, dimension(:,:), contiguous :: & !< is basically an allocatable+target, but in a type needs to be pointer real(pREAL), pointer, dimension(:,:), contiguous :: & !< is basically an allocatable+target, but in a type needs to be pointer
state0, & state0, &
state, & !< state state, & !< state
dotState, & !< rate of state change dotState, & !< rate of state change
deltaState !< increment of state change deltaState !< increment of state change
real(pReal), pointer, dimension(:,:) :: & real(pREAL), pointer, dimension(:,:) :: &
deltaState2 deltaState2
end type end type
@ -51,8 +51,8 @@ module phase
character(len=2), allocatable, dimension(:) :: phase_lattice character(len=2), allocatable, dimension(:) :: phase_lattice
real(pReal), allocatable, dimension(:) :: phase_cOverA real(pREAL), allocatable, dimension(:) :: phase_cOverA
real(pReal), allocatable, dimension(:) :: phase_rho real(pREAL), allocatable, dimension(:) :: phase_rho
type(tRotationContainer), dimension(:), allocatable :: & type(tRotationContainer), dimension(:), allocatable :: &
phase_O_0, & phase_O_0, &
@ -63,7 +63,7 @@ module phase
iJacoLpresiduum, & !< frequency of Jacobian update of residuum in Lp iJacoLpresiduum, & !< frequency of Jacobian update of residuum in Lp
nState, & !< state loop limit nState, & !< state loop limit
nStress !< stress loop limit nStress !< stress loop limit
real(pReal) :: & real(pREAL) :: &
subStepMinCryst, & !< minimum (relative) size of sub-step allowed during cutback subStepMinCryst, & !< minimum (relative) size of sub-step allowed during cutback
subStepSizeCryst, & !< size of first substep when cutback subStepSizeCryst, & !< size of first substep when cutback
subStepSizeLp, & !< size of first substep when cutback in Lp calculation subStepSizeLp, & !< size of first substep when cutback in Lp calculation
@ -133,11 +133,11 @@ module phase
module function phase_mechanical_dPdF(Delta_t,co,ce) result(dPdF) module function phase_mechanical_dPdF(Delta_t,co,ce) result(dPdF)
real(pReal), intent(in) :: Delta_t real(pREAL), intent(in) :: Delta_t
integer, intent(in) :: & integer, intent(in) :: &
co, & !< counter in constituent loop co, & !< counter in constituent loop
ce ce
real(pReal), dimension(3,3,3,3) :: dPdF real(pREAL), dimension(3,3,3,3) :: dPdF
end function phase_mechanical_dPdF end function phase_mechanical_dPdF
module subroutine mechanical_restartWrite(groupHandle,ph) module subroutine mechanical_restartWrite(groupHandle,ph)
@ -172,105 +172,105 @@ module phase
module function mechanical_S(ph,en) result(S) module function mechanical_S(ph,en) result(S)
integer, intent(in) :: ph,en integer, intent(in) :: ph,en
real(pReal), dimension(3,3) :: S real(pREAL), dimension(3,3) :: S
end function mechanical_S end function mechanical_S
module function mechanical_L_p(ph,en) result(L_p) module function mechanical_L_p(ph,en) result(L_p)
integer, intent(in) :: ph,en integer, intent(in) :: ph,en
real(pReal), dimension(3,3) :: L_p real(pREAL), dimension(3,3) :: L_p
end function mechanical_L_p end function mechanical_L_p
module function mechanical_F_e(ph,en) result(F_e) module function mechanical_F_e(ph,en) result(F_e)
integer, intent(in) :: ph,en integer, intent(in) :: ph,en
real(pReal), dimension(3,3) :: F_e real(pREAL), dimension(3,3) :: F_e
end function mechanical_F_e end function mechanical_F_e
module function mechanical_F_i(ph,en) result(F_i) module function mechanical_F_i(ph,en) result(F_i)
integer, intent(in) :: ph,en integer, intent(in) :: ph,en
real(pReal), dimension(3,3) :: F_i real(pREAL), dimension(3,3) :: F_i
end function mechanical_F_i end function mechanical_F_i
module function phase_F(co,ce) result(F) module function phase_F(co,ce) result(F)
integer, intent(in) :: co, ce integer, intent(in) :: co, ce
real(pReal), dimension(3,3) :: F real(pREAL), dimension(3,3) :: F
end function phase_F end function phase_F
module function phase_P(co,ce) result(P) module function phase_P(co,ce) result(P)
integer, intent(in) :: co, ce integer, intent(in) :: co, ce
real(pReal), dimension(3,3) :: P real(pREAL), dimension(3,3) :: P
end function phase_P end function phase_P
pure module function thermal_T(ph,en) result(T) pure module function thermal_T(ph,en) result(T)
integer, intent(in) :: ph,en integer, intent(in) :: ph,en
real(pReal) :: T real(pREAL) :: T
end function thermal_T end function thermal_T
module function thermal_dot_T(ph,en) result(dot_T) module function thermal_dot_T(ph,en) result(dot_T)
integer, intent(in) :: ph,en integer, intent(in) :: ph,en
real(pReal) :: dot_T real(pREAL) :: dot_T
end function thermal_dot_T end function thermal_dot_T
module function damage_phi(ph,en) result(phi) module function damage_phi(ph,en) result(phi)
integer, intent(in) :: ph,en integer, intent(in) :: ph,en
real(pReal) :: phi real(pREAL) :: phi
end function damage_phi end function damage_phi
module subroutine phase_set_F(F,co,ce) module subroutine phase_set_F(F,co,ce)
real(pReal), dimension(3,3), intent(in) :: F real(pREAL), dimension(3,3), intent(in) :: F
integer, intent(in) :: co, ce integer, intent(in) :: co, ce
end subroutine phase_set_F end subroutine phase_set_F
module subroutine phase_thermal_setField(T,dot_T, co,ce) module subroutine phase_thermal_setField(T,dot_T, co,ce)
real(pReal), intent(in) :: T, dot_T real(pREAL), intent(in) :: T, dot_T
integer, intent(in) :: co, ce integer, intent(in) :: co, ce
end subroutine phase_thermal_setField end subroutine phase_thermal_setField
module subroutine phase_set_phi(phi,co,ce) module subroutine phase_set_phi(phi,co,ce)
real(pReal), intent(in) :: phi real(pREAL), intent(in) :: phi
integer, intent(in) :: co, ce integer, intent(in) :: co, ce
end subroutine phase_set_phi end subroutine phase_set_phi
module function phase_mu_phi(co,ce) result(mu) module function phase_mu_phi(co,ce) result(mu)
integer, intent(in) :: co, ce integer, intent(in) :: co, ce
real(pReal) :: mu real(pREAL) :: mu
end function phase_mu_phi end function phase_mu_phi
module function phase_K_phi(co,ce) result(K) module function phase_K_phi(co,ce) result(K)
integer, intent(in) :: co, ce integer, intent(in) :: co, ce
real(pReal), dimension(3,3) :: K real(pREAL), dimension(3,3) :: K
end function phase_K_phi end function phase_K_phi
module function phase_mu_T(co,ce) result(mu) module function phase_mu_T(co,ce) result(mu)
integer, intent(in) :: co, ce integer, intent(in) :: co, ce
real(pReal) :: mu real(pREAL) :: mu
end function phase_mu_T end function phase_mu_T
module function phase_K_T(co,ce) result(K) module function phase_K_T(co,ce) result(K)
integer, intent(in) :: co, ce integer, intent(in) :: co, ce
real(pReal), dimension(3,3) :: K real(pREAL), dimension(3,3) :: K
end function phase_K_T end function phase_K_T
! == cleaned:end =================================================================================== ! == cleaned:end ===================================================================================
module function phase_thermal_constitutive(Delta_t,ph,en) result(converged_) module function phase_thermal_constitutive(Delta_t,ph,en) result(converged_)
real(pReal), intent(in) :: Delta_t real(pREAL), intent(in) :: Delta_t
integer, intent(in) :: ph, en integer, intent(in) :: ph, en
logical :: converged_ logical :: converged_
end function phase_thermal_constitutive end function phase_thermal_constitutive
module function phase_damage_constitutive(Delta_t,co,ce) result(converged_) module function phase_damage_constitutive(Delta_t,co,ce) result(converged_)
real(pReal), intent(in) :: Delta_t real(pREAL), intent(in) :: Delta_t
integer, intent(in) :: co, ce integer, intent(in) :: co, ce
logical :: converged_ logical :: converged_
end function phase_damage_constitutive end function phase_damage_constitutive
module function phase_mechanical_constitutive(Delta_t,co,ce) result(converged_) module function phase_mechanical_constitutive(Delta_t,co,ce) result(converged_)
real(pReal), intent(in) :: Delta_t real(pREAL), intent(in) :: Delta_t
integer, intent(in) :: co, ce integer, intent(in) :: co, ce
logical :: converged_ logical :: converged_
end function phase_mechanical_constitutive end function phase_mechanical_constitutive
@ -278,25 +278,25 @@ module phase
!ToDo: Merge all the stiffness functions !ToDo: Merge all the stiffness functions
module function phase_homogenizedC66(ph,en) result(C) module function phase_homogenizedC66(ph,en) result(C)
integer, intent(in) :: ph, en integer, intent(in) :: ph, en
real(pReal), dimension(6,6) :: C real(pREAL), dimension(6,6) :: C
end function phase_homogenizedC66 end function phase_homogenizedC66
module function phase_damage_C66(C66,ph,en) result(C66_degraded) module function phase_damage_C66(C66,ph,en) result(C66_degraded)
real(pReal), dimension(6,6), intent(in) :: C66 real(pREAL), dimension(6,6), intent(in) :: C66
integer, intent(in) :: ph,en integer, intent(in) :: ph,en
real(pReal), dimension(6,6) :: C66_degraded real(pREAL), dimension(6,6) :: C66_degraded
end function phase_damage_C66 end function phase_damage_C66
module function phase_f_phi(phi,co,ce) result(f) module function phase_f_phi(phi,co,ce) result(f)
integer, intent(in) :: ce,co integer, intent(in) :: ce,co
real(pReal), intent(in) :: & real(pREAL), intent(in) :: &
phi !< damage parameter phi !< damage parameter
real(pReal) :: & real(pREAL) :: &
f f
end function phase_f_phi end function phase_f_phi
module function phase_f_T(ph,en) result(f) module function phase_f_T(ph,en) result(f)
integer, intent(in) :: ph, en integer, intent(in) :: ph, en
real(pReal) :: f real(pREAL) :: f
end function phase_f_T end function phase_f_T
module subroutine plastic_nonlocal_updateCompatibility(orientation,ph,ip,el) module subroutine plastic_nonlocal_updateCompatibility(orientation,ph,ip,el)
@ -316,11 +316,11 @@ module phase
module subroutine damage_anisobrittle_LiAndItsTangent(L_i, dL_i_dM_i, M_i, ph,en) module subroutine damage_anisobrittle_LiAndItsTangent(L_i, dL_i_dM_i, M_i, ph,en)
integer, intent(in) :: ph, en integer, intent(in) :: ph, en
real(pReal), intent(in), dimension(3,3) :: & real(pREAL), intent(in), dimension(3,3) :: &
M_i M_i
real(pReal), intent(out), dimension(3,3) :: & real(pREAL), intent(out), dimension(3,3) :: &
L_i !< damage velocity gradient L_i !< damage velocity gradient
real(pReal), intent(out), dimension(3,3,3,3) :: & real(pREAL), intent(out), dimension(3,3,3,3) :: &
dL_i_dM_i !< derivative of L_i with respect to M_i dL_i_dM_i !< derivative of L_i with respect to M_i
end subroutine damage_anisobrittle_LiAndItsTangent end subroutine damage_anisobrittle_LiAndItsTangent
@ -389,7 +389,7 @@ subroutine phase_init
phases => config_material%get_dict('phase') phases => config_material%get_dict('phase')
allocate(phase_lattice(phases%length)) allocate(phase_lattice(phases%length))
allocate(phase_cOverA(phases%length),source=-1.0_pReal) allocate(phase_cOverA(phases%length),source=-1.0_pREAL)
allocate(phase_rho(phases%length)) allocate(phase_rho(phases%length))
allocate(phase_O_0(phases%length)) allocate(phase_O_0(phases%length))
@ -403,7 +403,7 @@ subroutine phase_init
call IO_error(130,ext_msg='phase_init: '//phase%get_asStr('lattice')) call IO_error(130,ext_msg='phase_init: '//phase%get_asStr('lattice'))
if (any(phase_lattice(ph) == ['hP','tI'])) & if (any(phase_lattice(ph) == ['hP','tI'])) &
phase_cOverA(ph) = phase%get_asReal('c/a') phase_cOverA(ph) = phase%get_asReal('c/a')
phase_rho(ph) = phase%get_asReal('rho',defaultVal=0.0_pReal) phase_rho(ph) = phase%get_asReal('rho',defaultVal=0.0_pREAL)
allocate(phase_O_0(ph)%data(count(material_ID_phase==ph))) allocate(phase_O_0(ph)%data(count(material_ID_phase==ph)))
end do end do
@ -454,13 +454,13 @@ subroutine phase_allocateState(state, &
state%offsetDeltaState = sizeState-sizeDeltaState ! deltaState occupies latter part of state by definition state%offsetDeltaState = sizeState-sizeDeltaState ! deltaState occupies latter part of state by definition
end if end if
allocate(state%atol (sizeState), source=0.0_pReal) allocate(state%atol (sizeState), source=0.0_pREAL)
allocate(state%state0 (sizeState,NEntries), source=0.0_pReal) allocate(state%state0 (sizeState,NEntries), source=0.0_pREAL)
allocate(state%state (sizeState,NEntries), source=0.0_pReal) allocate(state%state (sizeState,NEntries), source=0.0_pREAL)
allocate(state%dotState (sizeDotState,NEntries), source=0.0_pReal) allocate(state%dotState (sizeDotState,NEntries), source=0.0_pREAL)
allocate(state%deltaState (sizeDeltaState,NEntries), source=0.0_pReal) allocate(state%deltaState (sizeDeltaState,NEntries), source=0.0_pREAL)
state%deltaState2 => state%state(state%offsetDeltaState+1: & state%deltaState2 => state%state(state%offsetDeltaState+1: &
state%offsetDeltaState+state%sizeDeltaState,:) state%offsetDeltaState+state%sizeDeltaState,:)
@ -538,27 +538,27 @@ subroutine crystallite_init()
num_crystallite => config_numerics%get_dict('crystallite',defaultVal=emptyDict) num_crystallite => config_numerics%get_dict('crystallite',defaultVal=emptyDict)
num%subStepMinCryst = num_crystallite%get_asReal ('subStepMin', defaultVal=1.0e-3_pReal) num%subStepMinCryst = num_crystallite%get_asReal ('subStepMin', defaultVal=1.0e-3_pREAL)
num%subStepSizeCryst = num_crystallite%get_asReal ('subStepSize', defaultVal=0.25_pReal) num%subStepSizeCryst = num_crystallite%get_asReal ('subStepSize', defaultVal=0.25_pREAL)
num%stepIncreaseCryst = num_crystallite%get_asReal ('stepIncrease', defaultVal=1.5_pReal) num%stepIncreaseCryst = num_crystallite%get_asReal ('stepIncrease', defaultVal=1.5_pREAL)
num%subStepSizeLp = num_crystallite%get_asReal ('subStepSizeLp', defaultVal=0.5_pReal) num%subStepSizeLp = num_crystallite%get_asReal ('subStepSizeLp', defaultVal=0.5_pREAL)
num%subStepSizeLi = num_crystallite%get_asReal ('subStepSizeLi', defaultVal=0.5_pReal) num%subStepSizeLi = num_crystallite%get_asReal ('subStepSizeLi', defaultVal=0.5_pREAL)
num%rtol_crystalliteState = num_crystallite%get_asReal ('rtol_State', defaultVal=1.0e-6_pReal) num%rtol_crystalliteState = num_crystallite%get_asReal ('rtol_State', defaultVal=1.0e-6_pREAL)
num%rtol_crystalliteStress = num_crystallite%get_asReal ('rtol_Stress', defaultVal=1.0e-6_pReal) num%rtol_crystalliteStress = num_crystallite%get_asReal ('rtol_Stress', defaultVal=1.0e-6_pREAL)
num%atol_crystalliteStress = num_crystallite%get_asReal ('atol_Stress', defaultVal=1.0e-8_pReal) num%atol_crystalliteStress = num_crystallite%get_asReal ('atol_Stress', defaultVal=1.0e-8_pREAL)
num%iJacoLpresiduum = num_crystallite%get_asInt ('iJacoLpresiduum', defaultVal=1) num%iJacoLpresiduum = num_crystallite%get_asInt ('iJacoLpresiduum', defaultVal=1)
num%nState = num_crystallite%get_asInt ('nState', defaultVal=20) num%nState = num_crystallite%get_asInt ('nState', defaultVal=20)
num%nStress = num_crystallite%get_asInt ('nStress', defaultVal=40) num%nStress = num_crystallite%get_asInt ('nStress', defaultVal=40)
extmsg = '' extmsg = ''
if (num%subStepMinCryst <= 0.0_pReal) extmsg = trim(extmsg)//' subStepMinCryst' if (num%subStepMinCryst <= 0.0_pREAL) extmsg = trim(extmsg)//' subStepMinCryst'
if (num%subStepSizeCryst <= 0.0_pReal) extmsg = trim(extmsg)//' subStepSizeCryst' if (num%subStepSizeCryst <= 0.0_pREAL) extmsg = trim(extmsg)//' subStepSizeCryst'
if (num%stepIncreaseCryst <= 0.0_pReal) extmsg = trim(extmsg)//' stepIncreaseCryst' if (num%stepIncreaseCryst <= 0.0_pREAL) extmsg = trim(extmsg)//' stepIncreaseCryst'
if (num%subStepSizeLp <= 0.0_pReal) extmsg = trim(extmsg)//' subStepSizeLp' if (num%subStepSizeLp <= 0.0_pREAL) extmsg = trim(extmsg)//' subStepSizeLp'
if (num%subStepSizeLi <= 0.0_pReal) extmsg = trim(extmsg)//' subStepSizeLi' if (num%subStepSizeLi <= 0.0_pREAL) extmsg = trim(extmsg)//' subStepSizeLi'
if (num%rtol_crystalliteState <= 0.0_pReal) extmsg = trim(extmsg)//' rtol_crystalliteState' if (num%rtol_crystalliteState <= 0.0_pREAL) extmsg = trim(extmsg)//' rtol_crystalliteState'
if (num%rtol_crystalliteStress <= 0.0_pReal) extmsg = trim(extmsg)//' rtol_crystalliteStress' if (num%rtol_crystalliteStress <= 0.0_pREAL) extmsg = trim(extmsg)//' rtol_crystalliteStress'
if (num%atol_crystalliteStress <= 0.0_pReal) extmsg = trim(extmsg)//' atol_crystalliteStress' if (num%atol_crystalliteStress <= 0.0_pREAL) extmsg = trim(extmsg)//' atol_crystalliteStress'
if (num%iJacoLpresiduum < 1) extmsg = trim(extmsg)//' iJacoLpresiduum' if (num%iJacoLpresiduum < 1) extmsg = trim(extmsg)//' iJacoLpresiduum'
if (num%nState < 1) extmsg = trim(extmsg)//' nState' if (num%nState < 1) extmsg = trim(extmsg)//' nState'
if (num%nStress < 1) extmsg = trim(extmsg)//' nStress' if (num%nStress < 1) extmsg = trim(extmsg)//' nStress'
@ -615,13 +615,13 @@ end subroutine crystallite_orientations
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
function crystallite_push33ToRef(co,ce, tensor33) function crystallite_push33ToRef(co,ce, tensor33)
real(pReal), dimension(3,3), intent(in) :: tensor33 real(pREAL), dimension(3,3), intent(in) :: tensor33
integer, intent(in):: & integer, intent(in):: &
co, & co, &
ce ce
real(pReal), dimension(3,3) :: crystallite_push33ToRef real(pREAL), dimension(3,3) :: crystallite_push33ToRef
real(pReal), dimension(3,3) :: T real(pREAL), dimension(3,3) :: T
integer :: ph, en integer :: ph, en
@ -639,9 +639,9 @@ end function crystallite_push33ToRef
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
logical pure function converged(residuum,state,atol) logical pure function converged(residuum,state,atol)
real(pReal), intent(in), dimension(:) ::& real(pREAL), intent(in), dimension(:) ::&
residuum, state, atol residuum, state, atol
real(pReal) :: & real(pREAL) :: &
rTol rTol
rTol = num%rTol_crystalliteState rTol = num%rTol_crystalliteState

64
src/phase_damage.f90
View File

@ -4,9 +4,9 @@
submodule(phase) damage submodule(phase) damage
type :: tDamageParameters type :: tDamageParameters
real(pReal) :: & real(pREAL) :: &
mu = 0.0_pReal, & !< viscosity mu = 0.0_pREAL, & !< viscosity
l_c = 0.0_pReal !< characteristic length l_c = 0.0_pREAL !< characteristic length
end type tDamageParameters end type tDamageParameters
enum, bind(c); enumerator :: & enum, bind(c); enumerator :: &
@ -19,7 +19,7 @@ submodule(phase) damage
type :: tDataContainer type :: tDataContainer
real(pReal), dimension(:), allocatable :: phi real(pREAL), dimension(:), allocatable :: phi
end type tDataContainer end type tDataContainer
integer(kind(DAMAGE_UNDEFINED_ID)), dimension(:), allocatable :: & integer(kind(DAMAGE_UNDEFINED_ID)), dimension(:), allocatable :: &
@ -42,16 +42,16 @@ submodule(phase) damage
module subroutine isobrittle_deltaState(C, Fe, ph, en) module subroutine isobrittle_deltaState(C, Fe, ph, en)
integer, intent(in) :: ph,en integer, intent(in) :: ph,en
real(pReal), intent(in), dimension(3,3) :: & real(pREAL), intent(in), dimension(3,3) :: &
Fe Fe
real(pReal), intent(in), dimension(6,6) :: & real(pREAL), intent(in), dimension(6,6) :: &
C C
end subroutine isobrittle_deltaState end subroutine isobrittle_deltaState
module subroutine anisobrittle_dotState(M_i, ph, en) module subroutine anisobrittle_dotState(M_i, ph, en)
integer, intent(in) :: ph,en integer, intent(in) :: ph,en
real(pReal), intent(in), dimension(3,3) :: & real(pREAL), intent(in), dimension(3,3) :: &
M_i M_i
end subroutine anisobrittle_dotState end subroutine anisobrittle_dotState
@ -99,7 +99,7 @@ module subroutine damage_init()
Nmembers = count(material_ID_phase == ph) Nmembers = count(material_ID_phase == ph)
allocate(current(ph)%phi(Nmembers),source=1.0_pReal) allocate(current(ph)%phi(Nmembers),source=1.0_pREAL)
phase => phases%get_dict(ph) phase => phases%get_dict(ph)
source => phase%get_dict('damage',defaultVal=emptyDict) source => phase%get_dict('damage',defaultVal=emptyDict)
@ -131,7 +131,7 @@ end subroutine damage_init
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
module function phase_damage_constitutive(Delta_t,co,ce) result(converged_) module function phase_damage_constitutive(Delta_t,co,ce) result(converged_)
real(pReal), intent(in) :: Delta_t real(pREAL), intent(in) :: Delta_t
integer, intent(in) :: & integer, intent(in) :: &
co, & co, &
ce ce
@ -154,9 +154,9 @@ end function phase_damage_constitutive
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
module function phase_damage_C66(C66,ph,en) result(C66_degraded) module function phase_damage_C66(C66,ph,en) result(C66_degraded)
real(pReal), dimension(6,6), intent(in) :: C66 real(pREAL), dimension(6,6), intent(in) :: C66
integer, intent(in) :: ph,en integer, intent(in) :: ph,en
real(pReal), dimension(6,6) :: C66_degraded real(pREAL), dimension(6,6) :: C66_degraded
damageType: select case (phase_damage(ph)) damageType: select case (phase_damage(ph))
@ -195,9 +195,9 @@ end subroutine damage_restore
module function phase_f_phi(phi,co,ce) result(f) module function phase_f_phi(phi,co,ce) result(f)
integer, intent(in) :: ce,co integer, intent(in) :: ce,co
real(pReal), intent(in) :: & real(pREAL), intent(in) :: &
phi !< damage parameter phi !< damage parameter
real(pReal) :: & real(pREAL) :: &
f f
integer :: & integer :: &
@ -209,10 +209,10 @@ module function phase_f_phi(phi,co,ce) result(f)
select case(phase_damage(ph)) select case(phase_damage(ph))
case(DAMAGE_ISOBRITTLE_ID,DAMAGE_ANISOBRITTLE_ID) case(DAMAGE_ISOBRITTLE_ID,DAMAGE_ANISOBRITTLE_ID)
f = 1.0_pReal & f = 1.0_pREAL &
- phi*damageState(ph)%state(1,en) - phi*damageState(ph)%state(1,en)
case default case default
f = 0.0_pReal f = 0.0_pREAL
end select end select
end function phase_f_phi end function phase_f_phi
@ -224,7 +224,7 @@ end function phase_f_phi
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
function integrateDamageState(Delta_t,ph,en) result(broken) function integrateDamageState(Delta_t,ph,en) result(broken)
real(pReal), intent(in) :: Delta_t real(pREAL), intent(in) :: Delta_t
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
@ -233,11 +233,11 @@ function integrateDamageState(Delta_t,ph,en) result(broken)
integer :: & integer :: &
NiterationState, & !< number of iterations in state loop NiterationState, & !< number of iterations in state loop
size_so size_so
real(pReal) :: & real(pREAL) :: &
zeta zeta
real(pReal), dimension(phase_damage_maxSizeDotState) :: & real(pREAL), dimension(phase_damage_maxSizeDotState) :: &
r ! state residuum r ! state residuum
real(pReal), dimension(phase_damage_maxSizeDotState,2) :: source_dotState real(pREAL), dimension(phase_damage_maxSizeDotState,2) :: source_dotState
logical :: & logical :: &
converged_ converged_
@ -254,7 +254,7 @@ function integrateDamageState(Delta_t,ph,en) result(broken)
size_so = damageState(ph)%sizeDotState size_so = damageState(ph)%sizeDotState
damageState(ph)%state(1:size_so,en) = damageState(ph)%state0 (1:size_so,en) & damageState(ph)%state(1:size_so,en) = damageState(ph)%state0 (1:size_so,en) &
+ damageState(ph)%dotState(1:size_so,en) * Delta_t + damageState(ph)%dotState(1:size_so,en) * Delta_t
source_dotState(1:size_so,2) = 0.0_pReal source_dotState(1:size_so,2) = 0.0_pREAL
iteration: do NiterationState = 1, num%nState iteration: do NiterationState = 1, num%nState
@ -267,7 +267,7 @@ function integrateDamageState(Delta_t,ph,en) result(broken)
zeta = damper(damageState(ph)%dotState(:,en),source_dotState(1:size_so,1),source_dotState(1:size_so,2)) zeta = damper(damageState(ph)%dotState(:,en),source_dotState(1:size_so,1),source_dotState(1:size_so,2))
damageState(ph)%dotState(:,en) = damageState(ph)%dotState(:,en) * zeta & damageState(ph)%dotState(:,en) = damageState(ph)%dotState(:,en) * zeta &
+ source_dotState(1:size_so,1)* (1.0_pReal - zeta) + source_dotState(1:size_so,1)* (1.0_pREAL - zeta)
r(1:size_so) = damageState(ph)%state (1:size_so,en) & r(1:size_so) = damageState(ph)%state (1:size_so,en) &
- damageState(ph)%State0 (1:size_so,en) & - damageState(ph)%State0 (1:size_so,en) &
- damageState(ph)%dotState(1:size_so,en) * Delta_t - damageState(ph)%dotState(1:size_so,en) * Delta_t
@ -291,20 +291,20 @@ function integrateDamageState(Delta_t,ph,en) result(broken)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Calculate the damping for correction of state and dot state. !> @brief Calculate the damping for correction of state and dot state.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
real(pReal) pure function damper(omega_0,omega_1,omega_2) real(pREAL) pure function damper(omega_0,omega_1,omega_2)
real(pReal), dimension(:), intent(in) :: & real(pREAL), dimension(:), intent(in) :: &
omega_0, omega_1, omega_2 omega_0, omega_1, omega_2
real(pReal) :: dot_prod12, dot_prod22 real(pREAL) :: dot_prod12, dot_prod22
dot_prod12 = dot_product(omega_0-omega_1, omega_1-omega_2) dot_prod12 = dot_product(omega_0-omega_1, omega_1-omega_2)
dot_prod22 = dot_product(omega_1-omega_2, omega_1-omega_2) dot_prod22 = dot_product(omega_1-omega_2, omega_1-omega_2)
if (min(dot_product(omega_0,omega_1),dot_prod12) < 0.0_pReal .and. dot_prod22 > 0.0_pReal) then if (min(dot_product(omega_0,omega_1),dot_prod12) < 0.0_pREAL .and. dot_prod22 > 0.0_pREAL) then
damper = 0.75_pReal + 0.25_pReal * tanh(2.0_pReal + 4.0_pReal * dot_prod12 / dot_prod22) damper = 0.75_pREAL + 0.25_pREAL * tanh(2.0_pREAL + 4.0_pREAL * dot_prod12 / dot_prod22)
else else
damper = 1.0_pReal damper = 1.0_pREAL
end if end if
end function damper end function damper
@ -401,7 +401,7 @@ end function phase_damage_collectDotState
module function phase_mu_phi(co,ce) result(mu) module function phase_mu_phi(co,ce) result(mu)
integer, intent(in) :: co, ce integer, intent(in) :: co, ce
real(pReal) :: mu real(pREAL) :: mu
mu = param(material_ID_phase(co,ce))%mu mu = param(material_ID_phase(co,ce))%mu
@ -415,7 +415,7 @@ end function phase_mu_phi
module function phase_K_phi(co,ce) result(K) module function phase_K_phi(co,ce) result(K)
integer, intent(in) :: co, ce integer, intent(in) :: co, ce
real(pReal), dimension(3,3) :: K real(pREAL), dimension(3,3) :: K
K = crystallite_push33ToRef(co,ce,param(material_ID_phase(co,ce))%l_c**2*math_I3) K = crystallite_push33ToRef(co,ce,param(material_ID_phase(co,ce))%l_c**2*math_I3)
@ -432,7 +432,7 @@ function phase_damage_deltaState(Fe, ph, en) result(broken)
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
real(pReal), intent(in), dimension(3,3) :: & real(pREAL), intent(in), dimension(3,3) :: &
Fe !< elastic deformation gradient Fe !< elastic deformation gradient
integer :: & integer :: &
@ -496,7 +496,7 @@ end function source_active
!---------------------------------------------------------------------------------------------- !----------------------------------------------------------------------------------------------
module subroutine phase_set_phi(phi,co,ce) module subroutine phase_set_phi(phi,co,ce)
real(pReal), intent(in) :: phi real(pREAL), intent(in) :: phi
integer, intent(in) :: ce, co integer, intent(in) :: ce, co
@ -508,7 +508,7 @@ end subroutine phase_set_phi
module function damage_phi(ph,en) result(phi) module function damage_phi(ph,en) result(phi)
integer, intent(in) :: ph, en integer, intent(in) :: ph, en
real(pReal) :: phi real(pREAL) :: phi
phi = current(ph)%phi(en) phi = current(ph)%phi(en)

42
src/phase_damage_anisobrittle.f90
View File

@ -7,13 +7,13 @@
submodule (phase:damage) anisobrittle submodule (phase:damage) anisobrittle
type :: tParameters !< container type for internal constitutive parameters type :: tParameters !< container type for internal constitutive parameters
real(pReal) :: & real(pREAL) :: &
dot_o_0, & !< opening rate of cleavage planes dot_o_0, & !< opening rate of cleavage planes
p !< damage rate sensitivity p !< damage rate sensitivity
real(pReal), dimension(:), allocatable :: & real(pREAL), dimension(:), allocatable :: &
s_crit, & !< critical displacement s_crit, & !< critical displacement
g_crit !< critical load g_crit !< critical load
real(pReal), dimension(:,:,:,:), allocatable :: & real(pREAL), dimension(:,:,:,:), allocatable :: &
cleavage_systems cleavage_systems
integer :: & integer :: &
sum_N_cl !< total number of cleavage planes sum_N_cl !< total number of cleavage planes
@ -90,15 +90,15 @@ module function anisobrittle_init() result(mySources)
#endif #endif
! sanity checks ! sanity checks
if (prm%p <= 0.0_pReal) extmsg = trim(extmsg)//' p' if (prm%p <= 0.0_pREAL) extmsg = trim(extmsg)//' p'
if (prm%dot_o_0 <= 0.0_pReal) extmsg = trim(extmsg)//' dot_o_0' if (prm%dot_o_0 <= 0.0_pREAL) extmsg = trim(extmsg)//' dot_o_0'
if (any(prm%g_crit < 0.0_pReal)) extmsg = trim(extmsg)//' g_crit' if (any(prm%g_crit < 0.0_pREAL)) extmsg = trim(extmsg)//' g_crit'
if (any(prm%s_crit < 0.0_pReal)) extmsg = trim(extmsg)//' s_crit' if (any(prm%s_crit < 0.0_pREAL)) extmsg = trim(extmsg)//' s_crit'
Nmembers = count(material_ID_phase==ph) Nmembers = count(material_ID_phase==ph)
call phase_allocateState(damageState(ph),Nmembers,1,1,0) call phase_allocateState(damageState(ph),Nmembers,1,1,0)
damageState(ph)%atol = src%get_asReal('atol_phi',defaultVal=1.0e-9_pReal) damageState(ph)%atol = src%get_asReal('atol_phi',defaultVal=1.0e-9_pREAL)
if (any(damageState(ph)%atol < 0.0_pReal)) extmsg = trim(extmsg)//' atol_phi' if (any(damageState(ph)%atol < 0.0_pREAL)) extmsg = trim(extmsg)//' atol_phi'
end associate end associate
@ -117,17 +117,17 @@ module subroutine anisobrittle_dotState(M_i, ph,en)
integer, intent(in) :: & integer, intent(in) :: &
ph,en ph,en
real(pReal), intent(in), dimension(3,3) :: & real(pREAL), intent(in), dimension(3,3) :: &
M_i M_i
integer :: & integer :: &
a, i a, i
real(pReal) :: & real(pREAL) :: &
traction, traction_crit traction, traction_crit
associate(prm => param(ph)) associate(prm => param(ph))
damageState(ph)%dotState(1,en) = 0.0_pReal damageState(ph)%dotState(1,en) = 0.0_pREAL
do a = 1, prm%sum_N_cl do a = 1, prm%sum_N_cl
traction_crit = damage_phi(ph,en)**2 * prm%g_crit(a) traction_crit = damage_phi(ph,en)**2 * prm%g_crit(a)
do i = 1,3 do i = 1,3
@ -135,7 +135,7 @@ module subroutine anisobrittle_dotState(M_i, ph,en)
damageState(ph)%dotState(1,en) = damageState(ph)%dotState(1,en) & damageState(ph)%dotState(1,en) = damageState(ph)%dotState(1,en) &
+ prm%dot_o_0 / prm%s_crit(a) & + prm%dot_o_0 / prm%s_crit(a) &
* (max(0.0_pReal, abs(traction) - traction_crit)/traction_crit)**prm%p * (max(0.0_pREAL, abs(traction) - traction_crit)/traction_crit)**prm%p
end do end do
end do end do
end associate end associate
@ -173,22 +173,22 @@ module subroutine damage_anisobrittle_LiAndItsTangent(L_i, dL_i_dM_i, M_i, ph,en
integer, intent(in) :: & integer, intent(in) :: &
ph,en ph,en
real(pReal), intent(in), dimension(3,3) :: & real(pREAL), intent(in), dimension(3,3) :: &
M_i M_i
real(pReal), intent(out), dimension(3,3) :: & real(pREAL), intent(out), dimension(3,3) :: &
L_i !< damage velocity gradient L_i !< damage velocity gradient
real(pReal), intent(out), dimension(3,3,3,3) :: & real(pREAL), intent(out), dimension(3,3,3,3) :: &
dL_i_dM_i !< derivative of L_i with respect to M_i dL_i_dM_i !< derivative of L_i with respect to M_i
integer :: & integer :: &
a, k, l, m, n, i a, k, l, m, n, i
real(pReal) :: & real(pREAL) :: &
traction, traction_crit, & traction, traction_crit, &
udot, dudot_dt udot, dudot_dt
L_i = 0.0_pReal L_i = 0.0_pREAL
dL_i_dM_i = 0.0_pReal dL_i_dM_i = 0.0_pREAL
associate(prm => param(ph)) associate(prm => param(ph))
do a = 1,prm%sum_N_cl do a = 1,prm%sum_N_cl
traction_crit = damage_phi(ph,en)**2 * prm%g_crit(a) traction_crit = damage_phi(ph,en)**2 * prm%g_crit(a)
@ -196,9 +196,9 @@ module subroutine damage_anisobrittle_LiAndItsTangent(L_i, dL_i_dM_i, M_i, ph,en
do i = 1, 3 do i = 1, 3
traction = math_tensordot(M_i,prm%cleavage_systems(1:3,1:3,i,a)) traction = math_tensordot(M_i,prm%cleavage_systems(1:3,1:3,i,a))
if (abs(traction) > traction_crit + tol_math_check) then if (abs(traction) > traction_crit + tol_math_check) then
udot = sign(1.0_pReal,traction)* prm%dot_o_0 * ((abs(traction) - traction_crit)/traction_crit)**prm%p udot = sign(1.0_pREAL,traction)* prm%dot_o_0 * ((abs(traction) - traction_crit)/traction_crit)**prm%p
L_i = L_i + udot*prm%cleavage_systems(1:3,1:3,i,a) L_i = L_i + udot*prm%cleavage_systems(1:3,1:3,i,a)
dudot_dt = sign(1.0_pReal,traction)*udot*prm%p / (abs(traction) - traction_crit) dudot_dt = sign(1.0_pREAL,traction)*udot*prm%p / (abs(traction) - traction_crit)
forall (k=1:3,l=1:3,m=1:3,n=1:3) & forall (k=1:3,l=1:3,m=1:3,n=1:3) &
dL_i_dM_i(k,l,m,n) = dL_i_dM_i(k,l,m,n) & dL_i_dM_i(k,l,m,n) = dL_i_dM_i(k,l,m,n) &
+ dudot_dt*prm%cleavage_systems(k,l,i,a) * prm%cleavage_systems(m,n,i,a) + dudot_dt*prm%cleavage_systems(k,l,i,a) * prm%cleavage_systems(m,n,i,a)

24
src/phase_damage_isobrittle.f90
View File

@ -7,14 +7,14 @@
submodule(phase:damage) isobrittle submodule(phase:damage) isobrittle
type :: tParameters !< container type for internal constitutive parameters type :: tParameters !< container type for internal constitutive parameters
real(pReal) :: & real(pREAL) :: &
W_crit !< critical elastic strain energy W_crit !< critical elastic strain energy
character(len=pSTRLEN), allocatable, dimension(:) :: & character(len=pSTRLEN), allocatable, dimension(:) :: &
output output
end type tParameters end type tParameters
type :: tIsobrittleState type :: tIsobrittleState
real(pReal), pointer, dimension(:) :: & !< vectors along Nmembers real(pREAL), pointer, dimension(:) :: & !< vectors along Nmembers
r_W !< ratio between actual and critical strain energy density r_W !< ratio between actual and critical strain energy density
end type tIsobrittleState end type tIsobrittleState
@ -77,12 +77,12 @@ module function isobrittle_init() result(mySources)
#endif #endif
! sanity checks ! sanity checks
if (prm%W_crit <= 0.0_pReal) extmsg = trim(extmsg)//' W_crit' if (prm%W_crit <= 0.0_pREAL) extmsg = trim(extmsg)//' W_crit'
Nmembers = count(material_ID_phase==ph) Nmembers = count(material_ID_phase==ph)
call phase_allocateState(damageState(ph),Nmembers,1,0,1) call phase_allocateState(damageState(ph),Nmembers,1,0,1)
damageState(ph)%atol = src%get_asReal('atol_phi',defaultVal=1.0e-9_pReal) damageState(ph)%atol = src%get_asReal('atol_phi',defaultVal=1.0e-9_pREAL)
if (any(damageState(ph)%atol < 0.0_pReal)) extmsg = trim(extmsg)//' atol_phi' if (any(damageState(ph)%atol < 0.0_pREAL)) extmsg = trim(extmsg)//' atol_phi'
stt%r_W => damageState(ph)%state(1,:) stt%r_W => damageState(ph)%state(1,:)
dlt%r_W => damageState(ph)%deltaState(1,:) dlt%r_W => damageState(ph)%deltaState(1,:)
@ -105,23 +105,23 @@ end function isobrittle_init
module subroutine isobrittle_deltaState(C, Fe, ph,en) module subroutine isobrittle_deltaState(C, Fe, ph,en)
integer, intent(in) :: ph,en integer, intent(in) :: ph,en
real(pReal), intent(in), dimension(3,3) :: & real(pREAL), intent(in), dimension(3,3) :: &
Fe Fe
real(pReal), intent(in), dimension(6,6) :: & real(pREAL), intent(in), dimension(6,6) :: &
C C
real(pReal), dimension(6) :: & real(pREAL), dimension(6) :: &
epsilon epsilon
real(pReal) :: & real(pREAL) :: &
r_W r_W
epsilon = math_33toVoigt6_strain(0.5_pReal*(matmul(transpose(Fe),Fe)-math_I3)) epsilon = math_33toVoigt6_strain(0.5_pREAL*(matmul(transpose(Fe),Fe)-math_I3))
associate(prm => param(ph), stt => state(ph), dlt => deltaState(ph)) associate(prm => param(ph), stt => state(ph), dlt => deltaState(ph))
r_W = (0.5_pReal*dot_product(epsilon,matmul(C,epsilon)))/prm%W_crit r_W = (0.5_pREAL*dot_product(epsilon,matmul(C,epsilon)))/prm%W_crit
dlt%r_W(en) = merge(r_W - stt%r_W(en), 0.0_pReal, r_W > stt%r_W(en)) dlt%r_W(en) = merge(r_W - stt%r_W(en), 0.0_pREAL, r_W > stt%r_W(en))
end associate end associate

252
src/phase_mechanical.f90
View File

@ -57,22 +57,22 @@ submodule(phase) mechanical
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
real(pReal), intent(in), dimension(3,3) :: & real(pREAL), intent(in), dimension(3,3) :: &
Fe, & !< elastic deformation gradient Fe, & !< elastic deformation gradient
Fi !< intermediate deformation gradient Fi !< intermediate deformation gradient
real(pReal), intent(out), dimension(3,3) :: & real(pREAL), intent(out), dimension(3,3) :: &
S !< 2nd Piola-Kirchhoff stress tensor in lattice configuration S !< 2nd Piola-Kirchhoff stress tensor in lattice configuration
real(pReal), intent(out), dimension(3,3,3,3) :: & real(pREAL), intent(out), dimension(3,3,3,3) :: &
dS_dFe, & !< derivative of 2nd P-K stress with respect to elastic deformation gradient dS_dFe, & !< derivative of 2nd P-K stress with respect to elastic deformation gradient
dS_dFi !< derivative of 2nd P-K stress with respect to intermediate deformation gradient dS_dFi !< derivative of 2nd P-K stress with respect to intermediate deformation gradient
end subroutine phase_hooke_SandItsTangents end subroutine phase_hooke_SandItsTangents
module subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dMi,Mi,ph,en) module subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dMi,Mi,ph,en)
real(pReal), dimension(3,3), intent(out) :: & real(pREAL), dimension(3,3), intent(out) :: &
Li !< inleastic velocity gradient Li !< inleastic velocity gradient
real(pReal), dimension(3,3,3,3), intent(out) :: & real(pREAL), dimension(3,3,3,3), intent(out) :: &
dLi_dMi !< derivative of Li with respect to Mandel stress dLi_dMi !< derivative of Li with respect to Mandel stress
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mi !< Mandel stress Mi !< Mandel stress
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
@ -83,9 +83,9 @@ submodule(phase) mechanical
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
real(pReal), intent(in) :: & real(pREAL), intent(in) :: &
subdt !< timestep subdt !< timestep
real(pReal), dimension(plasticState(ph)%sizeDotState) :: & real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
dotState dotState
end function plastic_dotState end function plastic_dotState
@ -101,13 +101,13 @@ submodule(phase) mechanical
S, Fi, ph,en) S, Fi, ph,en)
integer, intent(in) :: & integer, intent(in) :: &
ph,en ph,en
real(pReal), intent(in), dimension(3,3) :: & real(pREAL), intent(in), dimension(3,3) :: &
S !< 2nd Piola-Kirchhoff stress S !< 2nd Piola-Kirchhoff stress
real(pReal), intent(in), dimension(3,3) :: & real(pREAL), intent(in), dimension(3,3) :: &
Fi !< intermediate deformation gradient Fi !< intermediate deformation gradient
real(pReal), intent(out), dimension(3,3) :: & real(pREAL), intent(out), dimension(3,3) :: &
Li !< intermediate velocity gradient Li !< intermediate velocity gradient
real(pReal), intent(out), dimension(3,3,3,3) :: & real(pREAL), intent(out), dimension(3,3,3,3) :: &
dLi_dS, & !< derivative of Li with respect to S dLi_dS, & !< derivative of Li with respect to S
dLi_dFi dLi_dFi
@ -118,12 +118,12 @@ submodule(phase) mechanical
S, Fi, ph,en) S, Fi, ph,en)
integer, intent(in) :: & integer, intent(in) :: &
ph,en ph,en
real(pReal), intent(in), dimension(3,3) :: & real(pREAL), intent(in), dimension(3,3) :: &
S, & !< 2nd Piola-Kirchhoff stress S, & !< 2nd Piola-Kirchhoff stress
Fi !< intermediate deformation gradient Fi !< intermediate deformation gradient
real(pReal), intent(out), dimension(3,3) :: & real(pREAL), intent(out), dimension(3,3) :: &
Lp !< plastic velocity gradient Lp !< plastic velocity gradient
real(pReal), intent(out), dimension(3,3,3,3) :: & real(pREAL), intent(out), dimension(3,3,3,3) :: &
dLp_dS, & dLp_dS, &
dLp_dFi !< derivative of Lp with respect to Fi dLp_dFi !< derivative of Lp with respect to Fi
end subroutine plastic_LpAndItsTangents end subroutine plastic_LpAndItsTangents
@ -160,23 +160,23 @@ submodule(phase) mechanical
end subroutine plastic_nonlocal_result end subroutine plastic_nonlocal_result
module function plastic_dislotwin_homogenizedC(ph,en) result(homogenizedC) module function plastic_dislotwin_homogenizedC(ph,en) result(homogenizedC)
real(pReal), dimension(6,6) :: homogenizedC real(pREAL), dimension(6,6) :: homogenizedC
integer, intent(in) :: ph,en integer, intent(in) :: ph,en
end function plastic_dislotwin_homogenizedC end function plastic_dislotwin_homogenizedC
pure module function elastic_C66(ph,en) result(C66) pure module function elastic_C66(ph,en) result(C66)
real(pReal), dimension(6,6) :: C66 real(pREAL), dimension(6,6) :: C66
integer, intent(in) :: ph, en integer, intent(in) :: ph, en
end function elastic_C66 end function elastic_C66
pure module function elastic_mu(ph,en,isotropic_bound) result(mu) pure module function elastic_mu(ph,en,isotropic_bound) result(mu)
real(pReal) :: mu real(pREAL) :: mu
integer, intent(in) :: ph, en integer, intent(in) :: ph, en
character(len=*), intent(in) :: isotropic_bound character(len=*), intent(in) :: isotropic_bound
end function elastic_mu end function elastic_mu
pure module function elastic_nu(ph,en,isotropic_bound) result(nu) pure module function elastic_nu(ph,en,isotropic_bound) result(nu)
real(pReal) :: nu real(pREAL) :: nu
integer, intent(in) :: ph, en integer, intent(in) :: ph, en
character(len=*), intent(in) :: isotropic_bound character(len=*), intent(in) :: isotropic_bound
end function elastic_nu end function elastic_nu
@ -243,13 +243,13 @@ module subroutine mechanical_init(phases)
allocate(phase_mechanical_Fi(ph)%data(3,3,Nmembers)) allocate(phase_mechanical_Fi(ph)%data(3,3,Nmembers))
allocate(phase_mechanical_Fp(ph)%data(3,3,Nmembers)) allocate(phase_mechanical_Fp(ph)%data(3,3,Nmembers))
allocate(phase_mechanical_F(ph)%data(3,3,Nmembers)) allocate(phase_mechanical_F(ph)%data(3,3,Nmembers))
allocate(phase_mechanical_Li(ph)%data(3,3,Nmembers),source=0.0_pReal) allocate(phase_mechanical_Li(ph)%data(3,3,Nmembers),source=0.0_pREAL)
allocate(phase_mechanical_Li0(ph)%data(3,3,Nmembers),source=0.0_pReal) allocate(phase_mechanical_Li0(ph)%data(3,3,Nmembers),source=0.0_pREAL)
allocate(phase_mechanical_Lp(ph)%data(3,3,Nmembers),source=0.0_pReal) allocate(phase_mechanical_Lp(ph)%data(3,3,Nmembers),source=0.0_pREAL)
allocate(phase_mechanical_Lp0(ph)%data(3,3,Nmembers),source=0.0_pReal) allocate(phase_mechanical_Lp0(ph)%data(3,3,Nmembers),source=0.0_pREAL)
allocate(phase_mechanical_S(ph)%data(3,3,Nmembers),source=0.0_pReal) allocate(phase_mechanical_S(ph)%data(3,3,Nmembers),source=0.0_pREAL)
allocate(phase_mechanical_P(ph)%data(3,3,Nmembers),source=0.0_pReal) allocate(phase_mechanical_P(ph)%data(3,3,Nmembers),source=0.0_pREAL)
allocate(phase_mechanical_S0(ph)%data(3,3,Nmembers),source=0.0_pReal) allocate(phase_mechanical_S0(ph)%data(3,3,Nmembers),source=0.0_pREAL)
phase => phases%get_dict(ph) phase => phases%get_dict(ph)
mech => phase%get_dict('mechanical') mech => phase%get_dict('mechanical')
@ -359,11 +359,11 @@ end subroutine mechanical_result
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
function integrateStress(F,subFp0,subFi0,Delta_t,ph,en) result(broken) function integrateStress(F,subFp0,subFi0,Delta_t,ph,en) result(broken)
real(pReal), dimension(3,3), intent(in) :: F,subFp0,subFi0 real(pREAL), dimension(3,3), intent(in) :: F,subFp0,subFi0
real(pReal), intent(in) :: Delta_t real(pREAL), intent(in) :: Delta_t
integer, intent(in) :: ph, en integer, intent(in) :: ph, en
real(pReal), dimension(3,3):: Fp_new, & ! plastic deformation gradient at end of timestep real(pREAL), dimension(3,3):: Fp_new, & ! plastic deformation gradient at end of timestep
invFp_new, & ! inverse of Fp_new invFp_new, & ! inverse of Fp_new
invFp_current, & ! inverse of Fp_current invFp_current, & ! inverse of Fp_current
Lpguess, & ! current guess for plastic velocity gradient Lpguess, & ! current guess for plastic velocity gradient
@ -386,11 +386,11 @@ function integrateStress(F,subFp0,subFi0,Delta_t,ph,en) result(broken)
A, & A, &
B, & B, &
temp_33 temp_33
real(pReal), dimension(9) :: temp_9 ! needed for matrix inversion by LAPACK real(pREAL), dimension(9) :: temp_9 ! needed for matrix inversion by LAPACK
integer, dimension(9) :: devNull_9 ! needed for matrix inversion by LAPACK integer, dimension(9) :: devNull_9 ! needed for matrix inversion by LAPACK
real(pReal), dimension(9,9) :: dRLp_dLp, & ! partial derivative of residuum (Jacobian for Newton-Raphson scheme) real(pREAL), dimension(9,9) :: dRLp_dLp, & ! partial derivative of residuum (Jacobian for Newton-Raphson scheme)
dRLi_dLi ! partial derivative of residuumI (Jacobian for Newton-Raphson scheme) dRLi_dLi ! partial derivative of residuumI (Jacobian for Newton-Raphson scheme)
real(pReal), dimension(3,3,3,3):: dS_dFe, & ! partial derivative of 2nd Piola-Kirchhoff stress real(pREAL), dimension(3,3,3,3):: dS_dFe, & ! partial derivative of 2nd Piola-Kirchhoff stress
dS_dFi, & dS_dFi, &
dFe_dLp, & ! partial derivative of elastic deformation gradient dFe_dLp, & ! partial derivative of elastic deformation gradient
dFe_dLi, & dFe_dLi, &
@ -399,7 +399,7 @@ function integrateStress(F,subFp0,subFi0,Delta_t,ph,en) result(broken)
dLi_dFi, & dLi_dFi, &
dLp_dS, & dLp_dS, &
dLi_dS dLi_dS
real(pReal) steplengthLp, & real(pREAL) steplengthLp, &
steplengthLi, & steplengthLi, &
atol_Lp, & atol_Lp, &
atol_Li atol_Li
@ -427,8 +427,8 @@ function integrateStress(F,subFp0,subFi0,Delta_t,ph,en) result(broken)
A = matmul(F,invFp_current) ! intermediate tensor needed later to calculate dFe_dLp A = matmul(F,invFp_current) ! intermediate tensor needed later to calculate dFe_dLp
jacoCounterLi = 0 jacoCounterLi = 0
steplengthLi = 1.0_pReal steplengthLi = 1.0_pREAL
residuumLi_old = 0.0_pReal residuumLi_old = 0.0_pREAL
Liguess_old = Liguess Liguess_old = Liguess
NiterationStressLi = 0 NiterationStressLi = 0
@ -440,8 +440,8 @@ function integrateStress(F,subFp0,subFi0,Delta_t,ph,en) result(broken)
Fi_new = math_inv33(invFi_new) Fi_new = math_inv33(invFi_new)
jacoCounterLp = 0 jacoCounterLp = 0
steplengthLp = 1.0_pReal steplengthLp = 1.0_pREAL
residuumLp_old = 0.0_pReal residuumLp_old = 0.0_pREAL
Lpguess_old = Lpguess Lpguess_old = Lpguess
NiterationStressLp = 0 NiterationStressLp = 0
@ -469,7 +469,7 @@ function integrateStress(F,subFp0,subFi0,Delta_t,ph,en) result(broken)
elseif (NiterationStressLp == 1 .or. norm2(residuumLp) < norm2(residuumLp_old)) then ! not converged, but improved norm of residuum (always proceed in first iteration)... elseif (NiterationStressLp == 1 .or. norm2(residuumLp) < norm2(residuumLp_old)) then ! not converged, but improved norm of residuum (always proceed in first iteration)...
residuumLp_old = residuumLp ! ...remember old values and... residuumLp_old = residuumLp ! ...remember old values and...
Lpguess_old = Lpguess Lpguess_old = Lpguess
steplengthLp = 1.0_pReal ! ...proceed with normal step length (calculate new search direction) steplengthLp = 1.0_pREAL ! ...proceed with normal step length (calculate new search direction)
else ! not converged and residuum not improved... else ! not converged and residuum not improved...
steplengthLp = num%subStepSizeLp * steplengthLp ! ...try with smaller step length in same direction steplengthLp = num%subStepSizeLp * steplengthLp ! ...try with smaller step length in same direction
Lpguess = Lpguess_old & Lpguess = Lpguess_old &
@ -509,7 +509,7 @@ function integrateStress(F,subFp0,subFi0,Delta_t,ph,en) result(broken)
elseif (NiterationStressLi == 1 .or. norm2(residuumLi) < norm2(residuumLi_old)) then ! not converged, but improved norm of residuum (always proceed in first iteration)... elseif (NiterationStressLi == 1 .or. norm2(residuumLi) < norm2(residuumLi_old)) then ! not converged, but improved norm of residuum (always proceed in first iteration)...
residuumLi_old = residuumLi ! ...remember old values and... residuumLi_old = residuumLi ! ...remember old values and...
Liguess_old = Liguess Liguess_old = Liguess
steplengthLi = 1.0_pReal ! ...proceed with normal step length (calculate new search direction) steplengthLi = 1.0_pREAL ! ...proceed with normal step length (calculate new search direction)
else ! not converged and residuum not improved... else ! not converged and residuum not improved...
steplengthLi = num%subStepSizeLi * steplengthLi ! ...try with smaller step length in same direction steplengthLi = num%subStepSizeLi * steplengthLi ! ...try with smaller step length in same direction
Liguess = Liguess_old & Liguess = Liguess_old &
@ -550,7 +550,7 @@ function integrateStress(F,subFp0,subFi0,Delta_t,ph,en) result(broken)
phase_mechanical_S(ph)%data(1:3,1:3,en) = S phase_mechanical_S(ph)%data(1:3,1:3,en) = S
phase_mechanical_Lp(ph)%data(1:3,1:3,en) = Lpguess phase_mechanical_Lp(ph)%data(1:3,1:3,en) = Lpguess
phase_mechanical_Li(ph)%data(1:3,1:3,en) = Liguess phase_mechanical_Li(ph)%data(1:3,1:3,en) = Liguess
phase_mechanical_Fp(ph)%data(1:3,1:3,en) = Fp_new / math_det33(Fp_new)**(1.0_pReal/3.0_pReal) ! regularize phase_mechanical_Fp(ph)%data(1:3,1:3,en) = Fp_new / math_det33(Fp_new)**(1.0_pREAL/3.0_pREAL) ! regularize
phase_mechanical_Fi(ph)%data(1:3,1:3,en) = Fi_new phase_mechanical_Fi(ph)%data(1:3,1:3,en) = Fi_new
phase_mechanical_Fe(ph)%data(1:3,1:3,en) = matmul(matmul(F,invFp_new),invFi_new) phase_mechanical_Fe(ph)%data(1:3,1:3,en) = matmul(matmul(F,invFp_new),invFi_new)
broken = .false. broken = .false.
@ -564,9 +564,9 @@ end function integrateStress
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
function integrateStateFPI(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(broken) function integrateStateFPI(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(broken)
real(pReal), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0 real(pREAL), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0
real(pReal), intent(in),dimension(:) :: subState0 real(pREAL), intent(in),dimension(:) :: subState0
real(pReal), intent(in) :: Delta_t real(pREAL), intent(in) :: Delta_t
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
@ -576,12 +576,12 @@ function integrateStateFPI(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(b
integer :: & integer :: &
NiterationState, & !< number of iterations in state loop NiterationState, & !< number of iterations in state loop
sizeDotState sizeDotState
real(pReal) :: & real(pREAL) :: &
zeta zeta
real(pReal), dimension(plasticState(ph)%sizeDotState) :: & real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
r, & ! state residuum r, & ! state residuum
dotState dotState
real(pReal), dimension(plasticState(ph)%sizeDotState,2) :: & real(pREAL), dimension(plasticState(ph)%sizeDotState,2) :: &
dotState_last dotState_last
@ -595,7 +595,7 @@ function integrateStateFPI(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(b
iteration: do NiterationState = 1, num%nState iteration: do NiterationState = 1, num%nState
dotState_last(1:sizeDotState,2) = merge(dotState_last(1:sizeDotState,1),0.0_pReal, nIterationState > 1) dotState_last(1:sizeDotState,2) = merge(dotState_last(1:sizeDotState,1),0.0_pREAL, nIterationState > 1)
dotState_last(1:sizeDotState,1) = dotState dotState_last(1:sizeDotState,1) = dotState
broken = integrateStress(F,subFp0,subFi0,Delta_t,ph,en) broken = integrateStress(F,subFp0,subFi0,Delta_t,ph,en)
@ -606,7 +606,7 @@ function integrateStateFPI(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(b
zeta = damper(dotState,dotState_last(1:sizeDotState,1),dotState_last(1:sizeDotState,2)) zeta = damper(dotState,dotState_last(1:sizeDotState,1),dotState_last(1:sizeDotState,2))
dotState = dotState * zeta & dotState = dotState * zeta &
+ dotState_last(1:sizeDotState,1) * (1.0_pReal - zeta) + dotState_last(1:sizeDotState,1) * (1.0_pREAL - zeta)
r = plasticState(ph)%state(1:sizeDotState,en) & r = plasticState(ph)%state(1:sizeDotState,en) &
- subState0 & - subState0 &
- dotState * Delta_t - dotState * Delta_t
@ -625,21 +625,21 @@ function integrateStateFPI(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(b
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief calculate the damping for correction of state and dot state !> @brief calculate the damping for correction of state and dot state
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
real(pReal) pure function damper(omega_0,omega_1,omega_2) real(pREAL) pure function damper(omega_0,omega_1,omega_2)
real(pReal), dimension(:), intent(in) :: & real(pREAL), dimension(:), intent(in) :: &
omega_0, omega_1, omega_2 omega_0, omega_1, omega_2
real(pReal) :: dot_prod12, dot_prod22 real(pREAL) :: dot_prod12, dot_prod22
dot_prod12 = dot_product(omega_0-omega_1, omega_1-omega_2) dot_prod12 = dot_product(omega_0-omega_1, omega_1-omega_2)
dot_prod22 = dot_product(omega_1-omega_2, omega_1-omega_2) dot_prod22 = dot_product(omega_1-omega_2, omega_1-omega_2)
if (min(dot_product(omega_0,omega_1),dot_prod12) < 0.0_pReal .and. dot_prod22 > 0.0_pReal) then if (min(dot_product(omega_0,omega_1),dot_prod12) < 0.0_pREAL .and. dot_prod22 > 0.0_pREAL) then
damper = 0.75_pReal + 0.25_pReal * tanh(2.0_pReal + 4.0_pReal * dot_prod12 / dot_prod22) damper = 0.75_pREAL + 0.25_pREAL * tanh(2.0_pREAL + 4.0_pREAL * dot_prod12 / dot_prod22)
else else
damper = 1.0_pReal damper = 1.0_pREAL
end if end if
end function damper end function damper
@ -652,16 +652,16 @@ end function integrateStateFPI
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
function integrateStateEuler(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(broken) function integrateStateEuler(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(broken)
real(pReal), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0 real(pREAL), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0
real(pReal), intent(in),dimension(:) :: subState0 real(pREAL), intent(in),dimension(:) :: subState0
real(pReal), intent(in) :: Delta_t real(pREAL), intent(in) :: Delta_t
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en !< grain index in grain loop en !< grain index in grain loop
logical :: & logical :: &
broken broken
real(pReal), dimension(plasticState(ph)%sizeDotState) :: & real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
dotState dotState
integer :: & integer :: &
sizeDotState sizeDotState
@ -692,9 +692,9 @@ end function integrateStateEuler
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
function integrateStateAdaptiveEuler(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(broken) function integrateStateAdaptiveEuler(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(broken)
real(pReal), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0 real(pREAL), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0
real(pReal), intent(in),dimension(:) :: subState0 real(pREAL), intent(in),dimension(:) :: subState0
real(pReal), intent(in) :: Delta_t real(pREAL), intent(in) :: Delta_t
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
@ -703,7 +703,7 @@ function integrateStateAdaptiveEuler(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en
integer :: & integer :: &
sizeDotState sizeDotState
real(pReal), dimension(plasticState(ph)%sizeDotState) :: & real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
r, & r, &
dotState dotState
@ -715,7 +715,7 @@ function integrateStateAdaptiveEuler(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en
sizeDotState = plasticState(ph)%sizeDotState sizeDotState = plasticState(ph)%sizeDotState
r = - dotState * 0.5_pReal * Delta_t r = - dotState * 0.5_pREAL * Delta_t
#ifndef __INTEL_LLVM_COMPILER #ifndef __INTEL_LLVM_COMPILER
plasticState(ph)%state(1:sizeDotState,en) = subState0 + dotState*Delta_t plasticState(ph)%state(1:sizeDotState,en) = subState0 + dotState*Delta_t
#else #else
@ -731,7 +731,7 @@ function integrateStateAdaptiveEuler(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en
dotState = plastic_dotState(Delta_t,ph,en) dotState = plastic_dotState(Delta_t,ph,en)
if (any(IEEE_is_NaN(dotState))) return if (any(IEEE_is_NaN(dotState))) return
broken = .not. converged(r + 0.5_pReal * dotState * Delta_t, & broken = .not. converged(r + 0.5_pREAL * dotState * Delta_t, &
plasticState(ph)%state(1:sizeDotState,en), & plasticState(ph)%state(1:sizeDotState,en), &
plasticState(ph)%atol(1:sizeDotState)) plasticState(ph)%atol(1:sizeDotState))
@ -743,22 +743,22 @@ end function integrateStateAdaptiveEuler
!--------------------------------------------------------------------------------------------------- !---------------------------------------------------------------------------------------------------
function integrateStateRK4(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(broken) function integrateStateRK4(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(broken)
real(pReal), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0 real(pREAL), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0
real(pReal), intent(in),dimension(:) :: subState0 real(pREAL), intent(in),dimension(:) :: subState0
real(pReal), intent(in) :: Delta_t real(pREAL), intent(in) :: Delta_t
integer, intent(in) :: ph, en integer, intent(in) :: ph, en
logical :: broken logical :: broken
real(pReal), dimension(3,3), parameter :: & real(pREAL), dimension(3,3), parameter :: &
A = reshape([& A = reshape([&
0.5_pReal, 0.0_pReal, 0.0_pReal, & 0.5_pREAL, 0.0_pREAL, 0.0_pREAL, &
0.0_pReal, 0.5_pReal, 0.0_pReal, & 0.0_pREAL, 0.5_pREAL, 0.0_pREAL, &
0.0_pReal, 0.0_pReal, 1.0_pReal],& 0.0_pREAL, 0.0_pREAL, 1.0_pREAL],&
shape(A)) shape(A))
real(pReal), dimension(3), parameter :: & real(pREAL), dimension(3), parameter :: &
C = [0.5_pReal, 0.5_pReal, 1.0_pReal] C = [0.5_pREAL, 0.5_pREAL, 1.0_pREAL]
real(pReal), dimension(4), parameter :: & real(pREAL), dimension(4), parameter :: &
B = [6.0_pReal, 3.0_pReal, 3.0_pReal, 6.0_pReal]**(-1) B = [6.0_pREAL, 3.0_pREAL, 3.0_pREAL, 6.0_pREAL]**(-1)
broken = integrateStateRK(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en,A,B,C) broken = integrateStateRK(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en,A,B,C)
@ -771,29 +771,29 @@ end function integrateStateRK4
!--------------------------------------------------------------------------------------------------- !---------------------------------------------------------------------------------------------------
function integrateStateRKCK45(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(broken) function integrateStateRKCK45(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(broken)
real(pReal), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0 real(pREAL), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0
real(pReal), intent(in),dimension(:) :: subState0 real(pREAL), intent(in),dimension(:) :: subState0
real(pReal), intent(in) :: Delta_t real(pREAL), intent(in) :: Delta_t
integer, intent(in) :: ph, en integer, intent(in) :: ph, en
logical :: broken logical :: broken
real(pReal), dimension(5,5), parameter :: & real(pREAL), dimension(5,5), parameter :: &
A = reshape([& A = reshape([&
1._pReal/5._pReal, .0_pReal, .0_pReal, .0_pReal, .0_pReal, & 1._pREAL/5._pREAL, .0_pREAL, .0_pREAL, .0_pREAL, .0_pREAL, &
3._pReal/40._pReal, 9._pReal/40._pReal, .0_pReal, .0_pReal, .0_pReal, & 3._pREAL/40._pREAL, 9._pREAL/40._pREAL, .0_pREAL, .0_pREAL, .0_pREAL, &
3_pReal/10._pReal, -9._pReal/10._pReal, 6._pReal/5._pReal, .0_pReal, .0_pReal, & 3_pREAL/10._pREAL, -9._pREAL/10._pREAL, 6._pREAL/5._pREAL, .0_pREAL, .0_pREAL, &
-11._pReal/54._pReal, 5._pReal/2._pReal, -70.0_pReal/27.0_pReal, 35.0_pReal/27.0_pReal, .0_pReal, & -11._pREAL/54._pREAL, 5._pREAL/2._pREAL, -70.0_pREAL/27.0_pREAL, 35.0_pREAL/27.0_pREAL, .0_pREAL, &
1631._pReal/55296._pReal,175._pReal/512._pReal,575._pReal/13824._pReal,44275._pReal/110592._pReal,253._pReal/4096._pReal],& 1631._pREAL/55296._pREAL,175._pREAL/512._pREAL,575._pREAL/13824._pREAL,44275._pREAL/110592._pREAL,253._pREAL/4096._pREAL],&
shape(A)) shape(A))
real(pReal), dimension(5), parameter :: & real(pREAL), dimension(5), parameter :: &
C = [0.2_pReal, 0.3_pReal, 0.6_pReal, 1.0_pReal, 0.875_pReal] C = [0.2_pREAL, 0.3_pREAL, 0.6_pREAL, 1.0_pREAL, 0.875_pREAL]
real(pReal), dimension(6), parameter :: & real(pREAL), dimension(6), parameter :: &
B = & B = &
[37.0_pReal/378.0_pReal, .0_pReal, 250.0_pReal/621.0_pReal, & [37.0_pREAL/378.0_pREAL, .0_pREAL, 250.0_pREAL/621.0_pREAL, &
125.0_pReal/594.0_pReal, .0_pReal, 512.0_pReal/1771.0_pReal], & 125.0_pREAL/594.0_pREAL, .0_pREAL, 512.0_pREAL/1771.0_pREAL], &
DB = B - & DB = B - &
[2825.0_pReal/27648.0_pReal, .0_pReal, 18575.0_pReal/48384.0_pReal,& [2825.0_pREAL/27648.0_pREAL, .0_pREAL, 18575.0_pREAL/48384.0_pREAL,&
13525.0_pReal/55296.0_pReal, 277.0_pReal/14336.0_pReal, 1._pReal/4._pReal] 13525.0_pREAL/55296.0_pREAL, 277.0_pREAL/14336.0_pREAL, 1._pREAL/4._pREAL]
broken = integrateStateRK(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en,A,B,C,DB) broken = integrateStateRK(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en,A,B,C,DB)
@ -807,12 +807,12 @@ end function integrateStateRKCK45
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
function integrateStateRK(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en,A,B,C,DB) result(broken) function integrateStateRK(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en,A,B,C,DB) result(broken)
real(pReal), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0 real(pREAL), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0
real(pReal), intent(in),dimension(:) :: subState0 real(pREAL), intent(in),dimension(:) :: subState0
real(pReal), intent(in) :: Delta_t real(pREAL), intent(in) :: Delta_t
real(pReal), dimension(:,:), intent(in) :: A real(pREAL), dimension(:,:), intent(in) :: A
real(pReal), dimension(:), intent(in) :: B, C real(pREAL), dimension(:), intent(in) :: B, C
real(pReal), dimension(:), intent(in), optional :: DB real(pREAL), dimension(:), intent(in), optional :: DB
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
@ -822,9 +822,9 @@ function integrateStateRK(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en,A,B,C,DB)
stage, & ! stage index in integration stage loop stage, & ! stage index in integration stage loop
n, & n, &
sizeDotState sizeDotState
real(pReal), dimension(plasticState(ph)%sizeDotState) :: & real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
dotState dotState
real(pReal), dimension(plasticState(ph)%sizeDotState,size(B)) :: & real(pREAL), dimension(plasticState(ph)%sizeDotState,size(B)) :: &
plastic_RKdotState plastic_RKdotState
@ -945,7 +945,7 @@ subroutine results(group,ph)
function to_quaternion(dataset) function to_quaternion(dataset)
type(tRotation), dimension(:), intent(in) :: dataset type(tRotation), dimension(:), intent(in) :: dataset
real(pReal), dimension(4,size(dataset,1)) :: to_quaternion real(pREAL), dimension(4,size(dataset,1)) :: to_quaternion
integer :: i integer :: i
@ -986,26 +986,26 @@ end subroutine mechanical_forward
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
module function phase_mechanical_constitutive(Delta_t,co,ce) result(converged_) module function phase_mechanical_constitutive(Delta_t,co,ce) result(converged_)
real(pReal), intent(in) :: Delta_t real(pREAL), intent(in) :: Delta_t
integer, intent(in) :: & integer, intent(in) :: &
co, & co, &
ce ce
logical :: converged_ logical :: converged_
real(pReal) :: & real(pREAL) :: &
formerSubStep formerSubStep
integer :: & integer :: &
ph, en, sizeDotState ph, en, sizeDotState
logical :: todo logical :: todo
real(pReal) :: subFrac,subStep real(pREAL) :: subFrac,subStep
real(pReal), dimension(3,3) :: & real(pREAL), dimension(3,3) :: &
subFp0, & subFp0, &
subFi0, & subFi0, &
subLp0, & subLp0, &
subLi0, & subLi0, &
subF0, & subF0, &
subF subF
real(pReal), dimension(plasticState(material_ID_phase(co,ce))%sizeState) :: subState0 real(pREAL), dimension(plasticState(material_ID_phase(co,ce))%sizeState) :: subState0
ph = material_ID_phase(co,ce) ph = material_ID_phase(co,ce)
@ -1017,9 +1017,9 @@ module function phase_mechanical_constitutive(Delta_t,co,ce) result(converged_)
subFp0 = phase_mechanical_Fp0(ph)%data(1:3,1:3,en) subFp0 = phase_mechanical_Fp0(ph)%data(1:3,1:3,en)
subFi0 = phase_mechanical_Fi0(ph)%data(1:3,1:3,en) subFi0 = phase_mechanical_Fi0(ph)%data(1:3,1:3,en)
subF0 = phase_mechanical_F0(ph)%data(1:3,1:3,en) subF0 = phase_mechanical_F0(ph)%data(1:3,1:3,en)
subFrac = 0.0_pReal subFrac = 0.0_pREAL
todo = .true. todo = .true.
subStep = 1.0_pReal/num%subStepSizeCryst subStep = 1.0_pREAL/num%subStepSizeCryst
converged_ = .false. ! pretend failed step of 1/subStepSizeCryst converged_ = .false. ! pretend failed step of 1/subStepSizeCryst
todo = .true. todo = .true.
@ -1028,9 +1028,9 @@ module function phase_mechanical_constitutive(Delta_t,co,ce) result(converged_)
if (converged_) then if (converged_) then
formerSubStep = subStep formerSubStep = subStep
subFrac = subFrac + subStep subFrac = subFrac + subStep
subStep = min(1.0_pReal - subFrac, num%stepIncreaseCryst * subStep) subStep = min(1.0_pREAL - subFrac, num%stepIncreaseCryst * subStep)
todo = subStep > 0.0_pReal ! still time left to integrate on? todo = subStep > 0.0_pREAL ! still time left to integrate on?
if (todo) then if (todo) then
subF0 = subF subF0 = subF
@ -1047,7 +1047,7 @@ module function phase_mechanical_constitutive(Delta_t,co,ce) result(converged_)
phase_mechanical_Fp(ph)%data(1:3,1:3,en) = subFp0 phase_mechanical_Fp(ph)%data(1:3,1:3,en) = subFp0
phase_mechanical_Fi(ph)%data(1:3,1:3,en) = subFi0 phase_mechanical_Fi(ph)%data(1:3,1:3,en) = subFi0
phase_mechanical_S(ph)%data(1:3,1:3,en) = phase_mechanical_S0(ph)%data(1:3,1:3,en) phase_mechanical_S(ph)%data(1:3,1:3,en) = phase_mechanical_S0(ph)%data(1:3,1:3,en)
if (subStep < 1.0_pReal) then ! actual (not initial) cutback if (subStep < 1.0_pREAL) then ! actual (not initial) cutback
phase_mechanical_Lp(ph)%data(1:3,1:3,en) = subLp0 phase_mechanical_Lp(ph)%data(1:3,1:3,en) = subLp0
phase_mechanical_Li(ph)%data(1:3,1:3,en) = subLi0 phase_mechanical_Li(ph)%data(1:3,1:3,en) = subLi0
end if end if
@ -1105,19 +1105,19 @@ end subroutine mechanical_restore
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
module function phase_mechanical_dPdF(Delta_t,co,ce) result(dPdF) module function phase_mechanical_dPdF(Delta_t,co,ce) result(dPdF)
real(pReal), intent(in) :: Delta_t real(pREAL), intent(in) :: Delta_t
integer, intent(in) :: & integer, intent(in) :: &
co, & !< counter in constituent loop co, & !< counter in constituent loop
ce ce
real(pReal), dimension(3,3,3,3) :: dPdF real(pREAL), dimension(3,3,3,3) :: dPdF
integer :: & integer :: &
o, & o, &
p, ph, en p, ph, en
real(pReal), dimension(3,3) :: devNull, & real(pREAL), dimension(3,3) :: devNull, &
invSubFp0,invSubFi0,invFp,invFi, & invSubFp0,invSubFi0,invFp,invFi, &
temp_33_1, temp_33_2, temp_33_3 temp_33_1, temp_33_2, temp_33_3
real(pReal), dimension(3,3,3,3) :: dSdFe, & real(pREAL), dimension(3,3,3,3) :: dSdFe, &
dSdF, & dSdF, &
dSdFi, & dSdFi, &
dLidS, & ! tangent in lattice configuration dLidS, & ! tangent in lattice configuration
@ -1129,7 +1129,7 @@ module function phase_mechanical_dPdF(Delta_t,co,ce) result(dPdF)
rhs_3333, & rhs_3333, &
lhs_3333, & lhs_3333, &
temp_3333 temp_3333
real(pReal), dimension(9,9):: temp_99 real(pREAL), dimension(9,9):: temp_99
logical :: error logical :: error
@ -1150,9 +1150,9 @@ module function phase_mechanical_dPdF(Delta_t,co,ce) result(dPdF)
invSubFi0 = math_inv33(phase_mechanical_Fi0(ph)%data(1:3,1:3,en)) invSubFi0 = math_inv33(phase_mechanical_Fi0(ph)%data(1:3,1:3,en))
if (sum(abs(dLidS)) < tol_math_check) then if (sum(abs(dLidS)) < tol_math_check) then
dFidS = 0.0_pReal dFidS = 0.0_pREAL
else else
lhs_3333 = 0.0_pReal; rhs_3333 = 0.0_pReal lhs_3333 = 0.0_pREAL; rhs_3333 = 0.0_pREAL
do o=1,3; do p=1,3 do o=1,3; do p=1,3
#ifndef __INTEL_LLVM_COMPILER #ifndef __INTEL_LLVM_COMPILER
lhs_3333(1:3,1:3,o,p) = lhs_3333(1:3,1:3,o,p) & lhs_3333(1:3,1:3,o,p) = lhs_3333(1:3,1:3,o,p) &
@ -1171,7 +1171,7 @@ module function phase_mechanical_dPdF(Delta_t,co,ce) result(dPdF)
if (error) then if (error) then
call IO_warning(600,'inversion error in analytic tangent calculation', & call IO_warning(600,'inversion error in analytic tangent calculation', &
label1='phase',ID1=ph,label2='entry',ID2=en) label1='phase',ID1=ph,label2='entry',ID2=en)
dFidS = 0.0_pReal dFidS = 0.0_pREAL
else else
dFidS = math_mul3333xx3333(math_99to3333(temp_99),rhs_3333) dFidS = math_mul3333xx3333(math_99to3333(temp_99),rhs_3333)
end if end if
@ -1223,7 +1223,7 @@ module function phase_mechanical_dPdF(Delta_t,co,ce) result(dPdF)
temp_33_2 = matmul(phase_mechanical_F(ph)%data(1:3,1:3,en),invFp) temp_33_2 = matmul(phase_mechanical_F(ph)%data(1:3,1:3,en),invFp)
temp_33_3 = matmul(temp_33_2,phase_mechanical_S(ph)%data(1:3,1:3,en)) temp_33_3 = matmul(temp_33_2,phase_mechanical_S(ph)%data(1:3,1:3,en))
dPdF = 0.0_pReal dPdF = 0.0_pREAL
do p=1,3 do p=1,3
dPdF(p,1:3,p,1:3) = transpose(matmul(invFp,temp_33_1)) dPdF(p,1:3,p,1:3) = transpose(matmul(invFp,temp_33_1))
end do end do
@ -1283,7 +1283,7 @@ end subroutine mechanical_restartRead
module function mechanical_S(ph,en) result(S) module function mechanical_S(ph,en) result(S)
integer, intent(in) :: ph,en integer, intent(in) :: ph,en
real(pReal), dimension(3,3) :: S real(pREAL), dimension(3,3) :: S
S = phase_mechanical_S(ph)%data(1:3,1:3,en) S = phase_mechanical_S(ph)%data(1:3,1:3,en)
@ -1297,7 +1297,7 @@ end function mechanical_S
module function mechanical_L_p(ph,en) result(L_p) module function mechanical_L_p(ph,en) result(L_p)
integer, intent(in) :: ph,en integer, intent(in) :: ph,en
real(pReal), dimension(3,3) :: L_p real(pREAL), dimension(3,3) :: L_p
L_p = phase_mechanical_Lp(ph)%data(1:3,1:3,en) L_p = phase_mechanical_Lp(ph)%data(1:3,1:3,en)
@ -1311,7 +1311,7 @@ end function mechanical_L_p
module function mechanical_F_e(ph,en) result(F_e) module function mechanical_F_e(ph,en) result(F_e)
integer, intent(in) :: ph,en integer, intent(in) :: ph,en
real(pReal), dimension(3,3) :: F_e real(pREAL), dimension(3,3) :: F_e
F_e = phase_mechanical_Fe(ph)%data(1:3,1:3,en) F_e = phase_mechanical_Fe(ph)%data(1:3,1:3,en)
@ -1325,7 +1325,7 @@ end function mechanical_F_e
module function mechanical_F_i(ph,en) result(F_i) module function mechanical_F_i(ph,en) result(F_i)
integer, intent(in) :: ph,en integer, intent(in) :: ph,en
real(pReal), dimension(3,3) :: F_i real(pREAL), dimension(3,3) :: F_i
F_i = phase_mechanical_Fi(ph)%data(1:3,1:3,en) F_i = phase_mechanical_Fi(ph)%data(1:3,1:3,en)
@ -1339,7 +1339,7 @@ end function mechanical_F_i
module function phase_P(co,ce) result(P) module function phase_P(co,ce) result(P)
integer, intent(in) :: co, ce integer, intent(in) :: co, ce
real(pReal), dimension(3,3) :: P real(pREAL), dimension(3,3) :: P
P = phase_mechanical_P(material_ID_phase(co,ce))%data(1:3,1:3,material_entry_phase(co,ce)) P = phase_mechanical_P(material_ID_phase(co,ce))%data(1:3,1:3,material_entry_phase(co,ce))
@ -1353,7 +1353,7 @@ end function phase_P
module function phase_F(co,ce) result(F) module function phase_F(co,ce) result(F)
integer, intent(in) :: co, ce integer, intent(in) :: co, ce
real(pReal), dimension(3,3) :: F real(pREAL), dimension(3,3) :: F
F = phase_mechanical_F(material_ID_phase(co,ce))%data(1:3,1:3,material_entry_phase(co,ce)) F = phase_mechanical_F(material_ID_phase(co,ce))%data(1:3,1:3,material_entry_phase(co,ce))
@ -1366,7 +1366,7 @@ end function phase_F
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
module subroutine phase_set_F(F,co,ce) module subroutine phase_set_F(F,co,ce)
real(pReal), dimension(3,3), intent(in) :: F real(pREAL), dimension(3,3), intent(in) :: F
integer, intent(in) :: co, ce integer, intent(in) :: co, ce

24
src/phase_mechanical_eigen.f90
View File

@ -20,9 +20,9 @@ submodule(phase:mechanical) eigen
module subroutine thermalexpansion_LiAndItsTangent(Li, dLi_dTstar, ph,me) module subroutine thermalexpansion_LiAndItsTangent(Li, dLi_dTstar, ph,me)
integer, intent(in) :: ph, me integer, intent(in) :: ph, me
real(pReal), intent(out), dimension(3,3) :: & real(pREAL), intent(out), dimension(3,3) :: &
Li !< thermal velocity gradient Li !< thermal velocity gradient
real(pReal), intent(out), dimension(3,3,3,3) :: & real(pREAL), intent(out), dimension(3,3,3,3) :: &
dLi_dTstar !< derivative of Li with respect to Tstar (4th-order tensor defined to be zero) dLi_dTstar !< derivative of Li with respect to Tstar (4th-order tensor defined to be zero)
end subroutine thermalexpansion_LiAndItsTangent end subroutine thermalexpansion_LiAndItsTangent
@ -145,32 +145,32 @@ module subroutine phase_LiAndItsTangents(Li, dLi_dS, dLi_dFi, &
integer, intent(in) :: & integer, intent(in) :: &
ph,en ph,en
real(pReal), intent(in), dimension(3,3) :: & real(pREAL), intent(in), dimension(3,3) :: &
S !< 2nd Piola-Kirchhoff stress S !< 2nd Piola-Kirchhoff stress
real(pReal), intent(in), dimension(3,3) :: & real(pREAL), intent(in), dimension(3,3) :: &
Fi !< intermediate deformation gradient Fi !< intermediate deformation gradient
real(pReal), intent(out), dimension(3,3) :: & real(pREAL), intent(out), dimension(3,3) :: &
Li !< intermediate velocity gradient Li !< intermediate velocity gradient
real(pReal), intent(out), dimension(3,3,3,3) :: & real(pREAL), intent(out), dimension(3,3,3,3) :: &
dLi_dS, & !< derivative of Li with respect to S dLi_dS, & !< derivative of Li with respect to S
dLi_dFi dLi_dFi
real(pReal), dimension(3,3) :: & real(pREAL), dimension(3,3) :: &
my_Li, & !< intermediate velocity gradient my_Li, & !< intermediate velocity gradient
FiInv, & FiInv, &
temp_33 temp_33
real(pReal), dimension(3,3,3,3) :: & real(pREAL), dimension(3,3,3,3) :: &
my_dLi_dS my_dLi_dS
real(pReal) :: & real(pREAL) :: &
detFi detFi
integer :: & integer :: &
k, i, j k, i, j
logical :: active logical :: active
active = .false. active = .false.
Li = 0.0_pReal Li = 0.0_pREAL
dLi_dS = 0.0_pReal dLi_dS = 0.0_pREAL
dLi_dFi = 0.0_pReal dLi_dFi = 0.0_pREAL
plasticType: select case (phase_plasticity(ph)) plasticType: select case (phase_plasticity(ph))

12
src/phase_mechanical_eigen_thermalexpansion.f90
View File

@ -75,13 +75,13 @@ end function thermalexpansion_init
module subroutine thermalexpansion_LiAndItsTangent(Li, dLi_dTstar, ph,me) module subroutine thermalexpansion_LiAndItsTangent(Li, dLi_dTstar, ph,me)
integer, intent(in) :: ph, me integer, intent(in) :: ph, me
real(pReal), intent(out), dimension(3,3) :: & real(pREAL), intent(out), dimension(3,3) :: &
Li !< thermal velocity gradient Li !< thermal velocity gradient
real(pReal), intent(out), dimension(3,3,3,3) :: & real(pREAL), intent(out), dimension(3,3,3,3) :: &
dLi_dTstar !< derivative of Li with respect to Tstar (4th-order tensor defined to be zero) dLi_dTstar !< derivative of Li with respect to Tstar (4th-order tensor defined to be zero)
real(pReal) :: T, dot_T real(pREAL) :: T, dot_T
real(pReal), dimension(3,3) :: Alpha real(pREAL), dimension(3,3) :: Alpha
T = thermal_T(ph,me) T = thermal_T(ph,me)
@ -89,14 +89,14 @@ module subroutine thermalexpansion_LiAndItsTangent(Li, dLi_dTstar, ph,me)
associate(prm => param(kinematics_thermal_expansion_instance(ph))) associate(prm => param(kinematics_thermal_expansion_instance(ph)))
Alpha = 0.0_pReal Alpha = 0.0_pREAL
Alpha(1,1) = prm%Alpha_11%at(T) Alpha(1,1) = prm%Alpha_11%at(T)
if (any(phase_lattice(ph) == ['hP','tI'])) Alpha(3,3) = prm%Alpha_33%at(T) if (any(phase_lattice(ph) == ['hP','tI'])) Alpha(3,3) = prm%Alpha_33%at(T)
Alpha = lattice_symmetrize_33(Alpha,phase_lattice(ph)) Alpha = lattice_symmetrize_33(Alpha,phase_lattice(ph))
Li = dot_T * Alpha Li = dot_T * Alpha
end associate end associate
dLi_dTstar = 0.0_pReal dLi_dTstar = 0.0_pREAL
end subroutine thermalexpansion_LiAndItsTangent end subroutine thermalexpansion_LiAndItsTangent

28
src/phase_mechanical_elastic.f90
View File

@ -77,13 +77,13 @@ pure module function elastic_C66(ph,en) result(C66)
ph, & ph, &
en en
real(pReal), dimension(6,6) :: C66 real(pREAL), dimension(6,6) :: C66
real(pReal) :: T real(pREAL) :: T
associate(prm => param(ph)) associate(prm => param(ph))
C66 = 0.0_pReal C66 = 0.0_pREAL
T = thermal_T(ph,en) T = thermal_T(ph,en)
C66(1,1) = prm%C_11%at(T) C66(1,1) = prm%C_11%at(T)
@ -113,7 +113,7 @@ pure module function elastic_mu(ph,en,isotropic_bound) result(mu)
ph, & ph, &
en en
character(len=*), intent(in) :: isotropic_bound character(len=*), intent(in) :: isotropic_bound
real(pReal) :: & real(pREAL) :: &
mu mu
@ -135,7 +135,7 @@ pure module function elastic_nu(ph,en,isotropic_bound) result(nu)
ph, & ph, &
en en
character(len=*), intent(in) :: isotropic_bound character(len=*), intent(in) :: isotropic_bound
real(pReal) :: & real(pREAL) :: &
nu nu
@ -160,18 +160,18 @@ module subroutine phase_hooke_SandItsTangents(S, dS_dFe, dS_dFi, &
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
real(pReal), intent(in), dimension(3,3) :: & real(pREAL), intent(in), dimension(3,3) :: &
Fe, & !< elastic deformation gradient Fe, & !< elastic deformation gradient
Fi !< intermediate deformation gradient Fi !< intermediate deformation gradient
real(pReal), intent(out), dimension(3,3) :: & real(pREAL), intent(out), dimension(3,3) :: &
S !< 2nd Piola-Kirchhoff stress tensor in lattice configuration S !< 2nd Piola-Kirchhoff stress tensor in lattice configuration
real(pReal), intent(out), dimension(3,3,3,3) :: & real(pREAL), intent(out), dimension(3,3,3,3) :: &
dS_dFe, & !< derivative of 2nd P-K stress with respect to elastic deformation gradient dS_dFe, & !< derivative of 2nd P-K stress with respect to elastic deformation gradient
dS_dFi !< derivative of 2nd P-K stress with respect to intermediate deformation gradient dS_dFi !< derivative of 2nd P-K stress with respect to intermediate deformation gradient
real(pReal), dimension(3,3) :: E real(pREAL), dimension(3,3) :: E
real(pReal), dimension(6,6) :: C66 real(pREAL), dimension(6,6) :: C66
real(pReal), dimension(3,3,3,3) :: C real(pREAL), dimension(3,3,3,3) :: C
integer :: & integer :: &
i, j i, j
@ -179,12 +179,12 @@ module subroutine phase_hooke_SandItsTangents(S, dS_dFe, dS_dFi, &
C66 = phase_damage_C66(phase_homogenizedC66(ph,en),ph,en) C66 = phase_damage_C66(phase_homogenizedC66(ph,en),ph,en)
C = math_Voigt66to3333_stiffness(C66) C = math_Voigt66to3333_stiffness(C66)
E = 0.5_pReal*(matmul(transpose(Fe),Fe)-math_I3) !< Green-Lagrange strain in unloaded configuration E = 0.5_pREAL*(matmul(transpose(Fe),Fe)-math_I3) !< Green-Lagrange strain in unloaded configuration
S = math_Voigt6to33_stress(matmul(C66,math_33toVoigt6_strain(matmul(matmul(transpose(Fi),E),Fi))))!< 2PK stress in lattice configuration in work conjugate with GL strain pulled back to lattice configuration S = math_Voigt6to33_stress(matmul(C66,math_33toVoigt6_strain(matmul(matmul(transpose(Fi),E),Fi))))!< 2PK stress in lattice configuration in work conjugate with GL strain pulled back to lattice configuration
do i =1,3; do j=1,3 do i =1,3; do j=1,3
dS_dFe(i,j,1:3,1:3) = matmul(Fe,matmul(matmul(Fi,C(i,j,1:3,1:3)),transpose(Fi))) !< dS_ij/dFe_kl = C_ijmn * Fi_lm * Fi_on * Fe_ko dS_dFe(i,j,1:3,1:3) = matmul(Fe,matmul(matmul(Fi,C(i,j,1:3,1:3)),transpose(Fi))) !< dS_ij/dFe_kl = C_ijmn * Fi_lm * Fi_on * Fe_ko
dS_dFi(i,j,1:3,1:3) = 2.0_pReal*matmul(matmul(E,Fi),C(i,j,1:3,1:3)) !< dS_ij/dFi_kl = C_ijln * E_km * Fe_mn dS_dFi(i,j,1:3,1:3) = 2.0_pREAL*matmul(matmul(E,Fi),C(i,j,1:3,1:3)) !< dS_ij/dFi_kl = C_ijln * E_km * Fe_mn
end do; end do end do; end do
end subroutine phase_hooke_SandItsTangents end subroutine phase_hooke_SandItsTangents
@ -195,7 +195,7 @@ end subroutine phase_hooke_SandItsTangents
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
module function phase_homogenizedC66(ph,en) result(C) module function phase_homogenizedC66(ph,en) result(C)
real(pReal), dimension(6,6) :: C real(pREAL), dimension(6,6) :: C
integer, intent(in) :: ph, en integer, intent(in) :: ph, en

88
src/phase_mechanical_plastic.f90
View File

@ -38,11 +38,11 @@ submodule(phase:mechanical) plastic
end function plastic_nonlocal_init end function plastic_nonlocal_init
module subroutine isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en) module subroutine isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en)
real(pReal), dimension(3,3), intent(out) :: & real(pREAL), dimension(3,3), intent(out) :: &
Lp Lp
real(pReal), dimension(3,3,3,3), intent(out) :: & real(pREAL), dimension(3,3,3,3), intent(out) :: &
dLp_dMp dLp_dMp
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp Mp
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
@ -50,11 +50,11 @@ submodule(phase:mechanical) plastic
end subroutine isotropic_LpAndItsTangent end subroutine isotropic_LpAndItsTangent
pure module subroutine phenopowerlaw_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en) pure module subroutine phenopowerlaw_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en)
real(pReal), dimension(3,3), intent(out) :: & real(pREAL), dimension(3,3), intent(out) :: &
Lp Lp
real(pReal), dimension(3,3,3,3), intent(out) :: & real(pREAL), dimension(3,3,3,3), intent(out) :: &
dLp_dMp dLp_dMp
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp Mp
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
@ -62,11 +62,11 @@ submodule(phase:mechanical) plastic
end subroutine phenopowerlaw_LpAndItsTangent end subroutine phenopowerlaw_LpAndItsTangent
pure module subroutine kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en) pure module subroutine kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en)
real(pReal), dimension(3,3), intent(out) :: & real(pREAL), dimension(3,3), intent(out) :: &
Lp Lp
real(pReal), dimension(3,3,3,3), intent(out) :: & real(pREAL), dimension(3,3,3,3), intent(out) :: &
dLp_dMp dLp_dMp
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp Mp
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
@ -74,11 +74,11 @@ submodule(phase:mechanical) plastic
end subroutine kinehardening_LpAndItsTangent end subroutine kinehardening_LpAndItsTangent
module subroutine dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en) module subroutine dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en)
real(pReal), dimension(3,3), intent(out) :: & real(pREAL), dimension(3,3), intent(out) :: &
Lp Lp
real(pReal), dimension(3,3,3,3), intent(out) :: & real(pREAL), dimension(3,3,3,3), intent(out) :: &
dLp_dMp dLp_dMp
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp Mp
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
@ -86,11 +86,11 @@ submodule(phase:mechanical) plastic
end subroutine dislotwin_LpAndItsTangent end subroutine dislotwin_LpAndItsTangent
pure module subroutine dislotungsten_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en) pure module subroutine dislotungsten_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en)
real(pReal), dimension(3,3), intent(out) :: & real(pREAL), dimension(3,3), intent(out) :: &
Lp Lp
real(pReal), dimension(3,3,3,3), intent(out) :: & real(pREAL), dimension(3,3,3,3), intent(out) :: &
dLp_dMp dLp_dMp
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp Mp
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
@ -98,11 +98,11 @@ submodule(phase:mechanical) plastic
end subroutine dislotungsten_LpAndItsTangent end subroutine dislotungsten_LpAndItsTangent
module subroutine nonlocal_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en) module subroutine nonlocal_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en)
real(pReal), dimension(3,3), intent(out) :: & real(pREAL), dimension(3,3), intent(out) :: &
Lp Lp
real(pReal), dimension(3,3,3,3), intent(out) :: & real(pREAL), dimension(3,3,3,3), intent(out) :: &
dLp_dMp dLp_dMp
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress Mp !< Mandel stress
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
@ -111,59 +111,59 @@ submodule(phase:mechanical) plastic
module function isotropic_dotState(Mp,ph,en) result(dotState) module function isotropic_dotState(Mp,ph,en) result(dotState)
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress Mp !< Mandel stress
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
real(pReal), dimension(plasticState(ph)%sizeDotState) :: & real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
dotState dotState
end function isotropic_dotState end function isotropic_dotState
module function phenopowerlaw_dotState(Mp,ph,en) result(dotState) module function phenopowerlaw_dotState(Mp,ph,en) result(dotState)
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress Mp !< Mandel stress
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
real(pReal), dimension(plasticState(ph)%sizeDotState) :: & real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
dotState dotState
end function phenopowerlaw_dotState end function phenopowerlaw_dotState
module function plastic_kinehardening_dotState(Mp,ph,en) result(dotState) module function plastic_kinehardening_dotState(Mp,ph,en) result(dotState)
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress Mp !< Mandel stress
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
real(pReal), dimension(plasticState(ph)%sizeDotState) :: & real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
dotState dotState
end function plastic_kinehardening_dotState end function plastic_kinehardening_dotState
module function dislotwin_dotState(Mp,ph,en) result(dotState) module function dislotwin_dotState(Mp,ph,en) result(dotState)
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress Mp !< Mandel stress
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
real(pReal), dimension(plasticState(ph)%sizeDotState) :: & real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
dotState dotState
end function dislotwin_dotState end function dislotwin_dotState
module function dislotungsten_dotState(Mp,ph,en) result(dotState) module function dislotungsten_dotState(Mp,ph,en) result(dotState)
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress Mp !< Mandel stress
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
real(pReal), dimension(plasticState(ph)%sizeDotState) :: & real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
dotState dotState
end function dislotungsten_dotState end function dislotungsten_dotState
module subroutine nonlocal_dotState(Mp,timestep,ph,en) module subroutine nonlocal_dotState(Mp,timestep,ph,en)
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp !< MandelStress Mp !< MandelStress
real(pReal), intent(in) :: & real(pREAL), intent(in) :: &
timestep !< substepped crystallite time increment timestep !< substepped crystallite time increment
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
@ -189,7 +189,7 @@ submodule(phase:mechanical) plastic
end subroutine nonlocal_dependentState end subroutine nonlocal_dependentState
module subroutine plastic_kinehardening_deltaState(Mp,ph,en) module subroutine plastic_kinehardening_deltaState(Mp,ph,en)
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress Mp !< Mandel stress
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
@ -197,7 +197,7 @@ submodule(phase:mechanical) plastic
end subroutine plastic_kinehardening_deltaState end subroutine plastic_kinehardening_deltaState
module subroutine plastic_nonlocal_deltaState(Mp,ph,en) module subroutine plastic_nonlocal_deltaState(Mp,ph,en)
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp Mp
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
@ -234,27 +234,27 @@ module subroutine plastic_LpAndItsTangents(Lp, dLp_dS, dLp_dFi, &
S, Fi, ph,en) S, Fi, ph,en)
integer, intent(in) :: & integer, intent(in) :: &
ph,en ph,en
real(pReal), intent(in), dimension(3,3) :: & real(pREAL), intent(in), dimension(3,3) :: &
S, & !< 2nd Piola-Kirchhoff stress S, & !< 2nd Piola-Kirchhoff stress
Fi !< intermediate deformation gradient Fi !< intermediate deformation gradient
real(pReal), intent(out), dimension(3,3) :: & real(pREAL), intent(out), dimension(3,3) :: &
Lp !< plastic velocity gradient Lp !< plastic velocity gradient
real(pReal), intent(out), dimension(3,3,3,3) :: & real(pREAL), intent(out), dimension(3,3,3,3) :: &
dLp_dS, & dLp_dS, &
dLp_dFi !< derivative en Lp with respect to Fi dLp_dFi !< derivative en Lp with respect to Fi
real(pReal), dimension(3,3,3,3) :: & real(pREAL), dimension(3,3,3,3) :: &
dLp_dMp !< derivative of Lp with respect to Mandel stress dLp_dMp !< derivative of Lp with respect to Mandel stress
real(pReal), dimension(3,3) :: & real(pREAL), dimension(3,3) :: &
Mp !< Mandel stress work conjugate with Lp Mp !< Mandel stress work conjugate with Lp
integer :: & integer :: &
i, j i, j
if (phase_plasticity(ph) == PLASTIC_NONE_ID) then if (phase_plasticity(ph) == PLASTIC_NONE_ID) then
Lp = 0.0_pReal Lp = 0.0_pREAL
dLp_dFi = 0.0_pReal dLp_dFi = 0.0_pREAL
dLp_dS = 0.0_pReal dLp_dS = 0.0_pREAL
else else
Mp = matmul(matmul(transpose(Fi),Fi),S) Mp = matmul(matmul(transpose(Fi),Fi),S)
@ -300,11 +300,11 @@ module function plastic_dotState(subdt,ph,en) result(dotState)
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
real(pReal), intent(in) :: & real(pREAL), intent(in) :: &
subdt !< timestep subdt !< timestep
real(pReal), dimension(3,3) :: & real(pREAL), dimension(3,3) :: &
Mp Mp
real(pReal), dimension(plasticState(ph)%sizeDotState) :: & real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
dotState dotState
@ -376,7 +376,7 @@ module function plastic_deltaState(ph, en) result(broken)
en en
logical :: broken logical :: broken
real(pReal), dimension(3,3) :: & real(pREAL), dimension(3,3) :: &
Mp Mp
integer :: & integer :: &
mySize mySize

148
src/phase_mechanical_plastic_dislotungsten.f90
View File

@ -8,11 +8,11 @@
submodule(phase:plastic) dislotungsten submodule(phase:plastic) dislotungsten
type :: tParameters type :: tParameters
real(pReal) :: & real(pREAL) :: &
D = 1.0_pReal, & !< grain size D = 1.0_pREAL, & !< grain size
D_0 = 1.0_pReal, & !< prefactor for self-diffusion coefficient D_0 = 1.0_pREAL, & !< prefactor for self-diffusion coefficient
Q_cl = 1.0_pReal !< activation energy for dislocation climb Q_cl = 1.0_pREAL !< activation energy for dislocation climb
real(pReal), allocatable, dimension(:) :: & real(pREAL), allocatable, dimension(:) :: &
b_sl, & !< magnitude of Burgers vector [m] b_sl, & !< magnitude of Burgers vector [m]
d_caron, & !< distance of spontaneous annhihilation d_caron, & !< distance of spontaneous annhihilation
i_sl, & !< Adj. parameter for distance between 2 forest dislocations i_sl, & !< Adj. parameter for distance between 2 forest dislocations
@ -26,10 +26,10 @@ submodule(phase:plastic) dislotungsten
h, & !< height of the kink pair h, & !< height of the kink pair
w, & !< width of the kink pair w, & !< width of the kink pair
omega !< attempt frequency for kink pair nucleation omega !< attempt frequency for kink pair nucleation
real(pReal), allocatable, dimension(:,:) :: & real(pREAL), allocatable, dimension(:,:) :: &
h_sl_sl, & !< slip resistance from slip activity h_sl_sl, & !< slip resistance from slip activity
forestProjection forestProjection
real(pReal), allocatable, dimension(:,:,:) :: & real(pREAL), allocatable, dimension(:,:,:) :: &
P_sl, & P_sl, &
P_nS_pos, & P_nS_pos, &
P_nS_neg P_nS_neg
@ -53,14 +53,14 @@ submodule(phase:plastic) dislotungsten
end type tIndexDotState end type tIndexDotState
type :: tDislotungstenState type :: tDislotungstenState
real(pReal), dimension(:,:), pointer :: & real(pREAL), dimension(:,:), pointer :: &
rho_mob, & rho_mob, &
rho_dip, & rho_dip, &
gamma_sl gamma_sl
end type tDislotungstenState end type tDislotungstenState
type :: tDislotungstenDependentState type :: tDislotungstenDependentState
real(pReal), dimension(:,:), allocatable :: & real(pREAL), dimension(:,:), allocatable :: &
Lambda_sl, & Lambda_sl, &
tau_pass tau_pass
end type tDislotungstenDependentState end type tDislotungstenDependentState
@ -89,7 +89,7 @@ module function plastic_dislotungsten_init() result(myPlasticity)
startIndex, endIndex startIndex, endIndex
integer, dimension(:), allocatable :: & integer, dimension(:), allocatable :: &
N_sl N_sl
real(pReal),dimension(:), allocatable :: & real(pREAL),dimension(:), allocatable :: &
rho_mob_0, & !< initial dislocation density rho_mob_0, & !< initial dislocation density
rho_dip_0, & !< initial dipole density rho_dip_0, & !< initial dipole density
a !< non-Schmid coefficients a !< non-Schmid coefficients
@ -203,16 +203,16 @@ module function plastic_dislotungsten_init() result(myPlasticity)
prm%d_caron = pl%get_asReal('D_a') * prm%b_sl prm%d_caron = pl%get_asReal('D_a') * prm%b_sl
! sanity checks ! sanity checks
if ( prm%D_0 < 0.0_pReal) extmsg = trim(extmsg)//' D_0' if ( prm%D_0 < 0.0_pREAL) extmsg = trim(extmsg)//' D_0'
if ( prm%Q_cl <= 0.0_pReal) extmsg = trim(extmsg)//' Q_cl' if ( prm%Q_cl <= 0.0_pREAL) extmsg = trim(extmsg)//' Q_cl'
if (any(rho_mob_0 < 0.0_pReal)) extmsg = trim(extmsg)//' rho_mob_0' if (any(rho_mob_0 < 0.0_pREAL)) extmsg = trim(extmsg)//' rho_mob_0'
if (any(rho_dip_0 < 0.0_pReal)) extmsg = trim(extmsg)//' rho_dip_0' if (any(rho_dip_0 < 0.0_pREAL)) extmsg = trim(extmsg)//' rho_dip_0'
if (any(prm%b_sl <= 0.0_pReal)) extmsg = trim(extmsg)//' b_sl' if (any(prm%b_sl <= 0.0_pREAL)) extmsg = trim(extmsg)//' b_sl'
if (any(prm%Q_s <= 0.0_pReal)) extmsg = trim(extmsg)//' Q_s' if (any(prm%Q_s <= 0.0_pREAL)) extmsg = trim(extmsg)//' Q_s'
if (any(prm%tau_Peierls < 0.0_pReal)) extmsg = trim(extmsg)//' tau_Peierls' if (any(prm%tau_Peierls < 0.0_pREAL)) extmsg = trim(extmsg)//' tau_Peierls'
if (any(prm%B < 0.0_pReal)) extmsg = trim(extmsg)//' B' if (any(prm%B < 0.0_pREAL)) extmsg = trim(extmsg)//' B'
if (any(prm%d_caron < 0.0_pReal)) extmsg = trim(extmsg)//' d_caron(D_a,b_sl)' if (any(prm%d_caron < 0.0_pREAL)) extmsg = trim(extmsg)//' d_caron(D_a,b_sl)'
if (any(prm%f_at <= 0.0_pReal)) extmsg = trim(extmsg)//' f_at or b_sl' if (any(prm%f_at <= 0.0_pREAL)) extmsg = trim(extmsg)//' f_at or b_sl'
else slipActive else slipActive
rho_mob_0 = emptyRealArray; rho_dip_0 = emptyRealArray rho_mob_0 = emptyRealArray; rho_dip_0 = emptyRealArray
@ -239,25 +239,25 @@ module function plastic_dislotungsten_init() result(myPlasticity)
idx_dot%rho_mob = [startIndex,endIndex] idx_dot%rho_mob = [startIndex,endIndex]
stt%rho_mob => plasticState(ph)%state(startIndex:endIndex,:) stt%rho_mob => plasticState(ph)%state(startIndex:endIndex,:)
stt%rho_mob = spread(rho_mob_0,2,Nmembers) stt%rho_mob = spread(rho_mob_0,2,Nmembers)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_rho',defaultVal=1.0_pReal) plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_rho',defaultVal=1.0_pREAL)
if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_rho' if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pREAL)) extmsg = trim(extmsg)//' atol_rho'
startIndex = endIndex + 1 startIndex = endIndex + 1
endIndex = endIndex + prm%sum_N_sl endIndex = endIndex + prm%sum_N_sl
idx_dot%rho_dip = [startIndex,endIndex] idx_dot%rho_dip = [startIndex,endIndex]
stt%rho_dip => plasticState(ph)%state(startIndex:endIndex,:) stt%rho_dip => plasticState(ph)%state(startIndex:endIndex,:)
stt%rho_dip = spread(rho_dip_0,2,Nmembers) stt%rho_dip = spread(rho_dip_0,2,Nmembers)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_rho',defaultVal=1.0_pReal) plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_rho',defaultVal=1.0_pREAL)
startIndex = endIndex + 1 startIndex = endIndex + 1
endIndex = endIndex + prm%sum_N_sl endIndex = endIndex + prm%sum_N_sl
idx_dot%gamma_sl = [startIndex,endIndex] idx_dot%gamma_sl = [startIndex,endIndex]
stt%gamma_sl => plasticState(ph)%state(startIndex:endIndex,:) stt%gamma_sl => plasticState(ph)%state(startIndex:endIndex,:)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_gamma',defaultVal=1.0e-6_pReal) plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_gamma',defaultVal=1.0e-6_pREAL)
if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_gamma' if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pREAL)) extmsg = trim(extmsg)//' atol_gamma'
allocate(dst%Lambda_sl(prm%sum_N_sl,Nmembers), source=0.0_pReal) allocate(dst%Lambda_sl(prm%sum_N_sl,Nmembers), source=0.0_pREAL)
allocate(dst%tau_pass(prm%sum_N_sl,Nmembers), source=0.0_pReal) allocate(dst%tau_pass(prm%sum_N_sl,Nmembers), source=0.0_pREAL)
end associate end associate
@ -275,11 +275,11 @@ end function plastic_dislotungsten_init
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure module subroutine dislotungsten_LpAndItsTangent(Lp,dLp_dMp, & pure module subroutine dislotungsten_LpAndItsTangent(Lp,dLp_dMp, &
Mp,ph,en) Mp,ph,en)
real(pReal), dimension(3,3), intent(out) :: & real(pREAL), dimension(3,3), intent(out) :: &
Lp !< plastic velocity gradient Lp !< plastic velocity gradient
real(pReal), dimension(3,3,3,3), intent(out) :: & real(pREAL), dimension(3,3,3,3), intent(out) :: &
dLp_dMp !< derivative of Lp with respect to the Mandel stress dLp_dMp !< derivative of Lp with respect to the Mandel stress
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress Mp !< Mandel stress
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
@ -287,16 +287,16 @@ pure module subroutine dislotungsten_LpAndItsTangent(Lp,dLp_dMp, &
integer :: & integer :: &
i,k,l,m,n i,k,l,m,n
real(pReal) :: & real(pREAL) :: &
T !< temperature T !< temperature
real(pReal), dimension(param(ph)%sum_N_sl) :: & real(pREAL), dimension(param(ph)%sum_N_sl) :: &
dot_gamma_pos,dot_gamma_neg, & dot_gamma_pos,dot_gamma_neg, &
ddot_gamma_dtau_pos,ddot_gamma_dtau_neg ddot_gamma_dtau_pos,ddot_gamma_dtau_neg
T = thermal_T(ph,en) T = thermal_T(ph,en)
Lp = 0.0_pReal Lp = 0.0_pREAL
dLp_dMp = 0.0_pReal dLp_dMp = 0.0_pREAL
associate(prm => param(ph)) associate(prm => param(ph))
@ -319,15 +319,15 @@ end subroutine dislotungsten_LpAndItsTangent
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
module function dislotungsten_dotState(Mp,ph,en) result(dotState) module function dislotungsten_dotState(Mp,ph,en) result(dotState)
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress Mp !< Mandel stress
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
real(pReal), dimension(plasticState(ph)%sizeDotState) :: & real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
dotState dotState
real(pReal), dimension(param(ph)%sum_N_sl) :: & real(pREAL), dimension(param(ph)%sum_N_sl) :: &
dot_gamma_pos, dot_gamma_neg,& dot_gamma_pos, dot_gamma_neg,&
tau_pos,& tau_pos,&
tau_neg, & tau_neg, &
@ -335,7 +335,7 @@ module function dislotungsten_dotState(Mp,ph,en) result(dotState)
dot_rho_dip_formation, & dot_rho_dip_formation, &
dot_rho_dip_climb, & dot_rho_dip_climb, &
d_hat d_hat
real(pReal) :: & real(pREAL) :: &
mu, T mu, T
@ -353,26 +353,26 @@ module function dislotungsten_dotState(Mp,ph,en) result(dotState)
dot_gamma_sl = abs(dot_gamma_pos+dot_gamma_neg) dot_gamma_sl = abs(dot_gamma_pos+dot_gamma_neg)
where(dEq0((tau_pos+tau_neg)*0.5_pReal)) where(dEq0((tau_pos+tau_neg)*0.5_pREAL))
dot_rho_dip_formation = 0.0_pReal dot_rho_dip_formation = 0.0_pREAL
dot_rho_dip_climb = 0.0_pReal dot_rho_dip_climb = 0.0_pREAL
else where else where
d_hat = math_clip(3.0_pReal*mu*prm%b_sl/(16.0_pReal*PI*abs(tau_pos+tau_neg)*0.5_pReal), & d_hat = math_clip(3.0_pREAL*mu*prm%b_sl/(16.0_pREAL*PI*abs(tau_pos+tau_neg)*0.5_pREAL), &
prm%d_caron, & ! lower limit prm%d_caron, & ! lower limit
dst%Lambda_sl(:,en)) ! upper limit dst%Lambda_sl(:,en)) ! upper limit
dot_rho_dip_formation = merge(2.0_pReal*(d_hat-prm%d_caron)*stt%rho_mob(:,en)*dot_gamma_sl/prm%b_sl, & dot_rho_dip_formation = merge(2.0_pREAL*(d_hat-prm%d_caron)*stt%rho_mob(:,en)*dot_gamma_sl/prm%b_sl, &
0.0_pReal, & 0.0_pREAL, &
prm%dipoleformation) prm%dipoleformation)
v_cl = (3.0_pReal*mu*prm%D_0*exp(-prm%Q_cl/(K_B*T))*prm%f_at/(TAU*K_B*T)) & v_cl = (3.0_pREAL*mu*prm%D_0*exp(-prm%Q_cl/(K_B*T))*prm%f_at/(TAU*K_B*T)) &
* (1.0_pReal/(d_hat+prm%d_caron)) * (1.0_pREAL/(d_hat+prm%d_caron))
dot_rho_dip_climb = (4.0_pReal*v_cl*stt%rho_dip(:,en))/(d_hat-prm%d_caron) ! ToDo: Discuss with Franz: Stress dependency? dot_rho_dip_climb = (4.0_pREAL*v_cl*stt%rho_dip(:,en))/(d_hat-prm%d_caron) ! ToDo: Discuss with Franz: Stress dependency?
end where end where
dot_rho_mob = dot_gamma_sl/(prm%b_sl*dst%Lambda_sl(:,en)) & ! multiplication dot_rho_mob = dot_gamma_sl/(prm%b_sl*dst%Lambda_sl(:,en)) & ! multiplication
- dot_rho_dip_formation & - dot_rho_dip_formation &
- (2.0_pReal*prm%d_caron)/prm%b_sl*stt%rho_mob(:,en)*dot_gamma_sl ! Spontaneous annihilation of 2 edges - (2.0_pREAL*prm%d_caron)/prm%b_sl*stt%rho_mob(:,en)*dot_gamma_sl ! Spontaneous annihilation of 2 edges
dot_rho_dip = dot_rho_dip_formation & dot_rho_dip = dot_rho_dip_formation &
- (2.0_pReal*prm%d_caron)/prm%b_sl*stt%rho_dip(:,en)*dot_gamma_sl & ! Spontaneous annihilation of an edge with a dipole - (2.0_pREAL*prm%d_caron)/prm%b_sl*stt%rho_dip(:,en)*dot_gamma_sl & ! Spontaneous annihilation of an edge with a dipole
- dot_rho_dip_climb - dot_rho_dip_climb
end associate end associate
@ -389,7 +389,7 @@ module subroutine dislotungsten_dependentState(ph,en)
ph, & ph, &
en en
real(pReal), dimension(param(ph)%sum_N_sl) :: & real(pREAL), dimension(param(ph)%sum_N_sl) :: &
Lambda_sl_inv Lambda_sl_inv
@ -398,9 +398,9 @@ module subroutine dislotungsten_dependentState(ph,en)
dst%tau_pass(:,en) = elastic_mu(ph,en,prm%isotropic_bound)*prm%b_sl & dst%tau_pass(:,en) = elastic_mu(ph,en,prm%isotropic_bound)*prm%b_sl &
* sqrt(matmul(prm%h_sl_sl,stt%rho_mob(:,en)+stt%rho_dip(:,en))) * sqrt(matmul(prm%h_sl_sl,stt%rho_mob(:,en)+stt%rho_dip(:,en)))
Lambda_sl_inv = 1.0_pReal/prm%D & Lambda_sl_inv = 1.0_pREAL/prm%D &
+ sqrt(matmul(prm%forestProjection,stt%rho_mob(:,en)+stt%rho_dip(:,en)))/prm%i_sl + sqrt(matmul(prm%forestProjection,stt%rho_mob(:,en)+stt%rho_dip(:,en)))/prm%i_sl
dst%Lambda_sl(:,en) = Lambda_sl_inv**(-1.0_pReal) dst%Lambda_sl(:,en) = Lambda_sl_inv**(-1.0_pREAL)
end associate end associate
@ -458,24 +458,24 @@ end subroutine plastic_dislotungsten_result
pure subroutine kinetics(Mp,T,ph,en, & pure subroutine kinetics(Mp,T,ph,en, &
dot_gamma_pos,dot_gamma_neg,ddot_gamma_dtau_pos,ddot_gamma_dtau_neg,tau_pos_out,tau_neg_out) dot_gamma_pos,dot_gamma_neg,ddot_gamma_dtau_pos,ddot_gamma_dtau_neg,tau_pos_out,tau_neg_out)
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress Mp !< Mandel stress
real(pReal), intent(in) :: & real(pREAL), intent(in) :: &
T !< temperature T !< temperature
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
real(pReal), intent(out), dimension(param(ph)%sum_N_sl) :: & real(pREAL), intent(out), dimension(param(ph)%sum_N_sl) :: &
dot_gamma_pos, & dot_gamma_pos, &
dot_gamma_neg dot_gamma_neg
real(pReal), intent(out), optional, dimension(param(ph)%sum_N_sl) :: & real(pREAL), intent(out), optional, dimension(param(ph)%sum_N_sl) :: &
ddot_gamma_dtau_pos, & ddot_gamma_dtau_pos, &
ddot_gamma_dtau_neg, & ddot_gamma_dtau_neg, &
tau_pos_out, & tau_pos_out, &
tau_neg_out tau_neg_out
real(pReal), dimension(param(ph)%sum_N_sl) :: & real(pREAL), dimension(param(ph)%sum_N_sl) :: &
StressRatio, & StressRatio, &
StressRatio_p,StressRatio_pminus1, & StressRatio_p,StressRatio_pminus1, &
dvel, & dvel, &
@ -495,7 +495,7 @@ pure subroutine kinetics(Mp,T,ph,en, &
if (present(tau_neg_out)) tau_neg_out = tau_neg if (present(tau_neg_out)) tau_neg_out = tau_neg
associate(BoltzmannRatio => prm%Q_s/(K_B*T), & associate(BoltzmannRatio => prm%Q_s/(K_B*T), &
b_rho_half => stt%rho_mob(:,en) * prm%b_sl * 0.5_pReal, & b_rho_half => stt%rho_mob(:,en) * prm%b_sl * 0.5_pREAL, &
effectiveLength => dst%Lambda_sl(:,en) - prm%w) effectiveLength => dst%Lambda_sl(:,en) - prm%w)
tau_eff = abs(tau_pos)-dst%tau_pass(:,en) tau_eff = abs(tau_pos)-dst%tau_pass(:,en)
@ -503,28 +503,28 @@ pure subroutine kinetics(Mp,T,ph,en, &
significantPositiveTau: where(tau_eff > tol_math_check) significantPositiveTau: where(tau_eff > tol_math_check)
StressRatio = tau_eff/prm%tau_Peierls StressRatio = tau_eff/prm%tau_Peierls
StressRatio_p = StressRatio** prm%p StressRatio_p = StressRatio** prm%p
StressRatio_pminus1 = StressRatio**(prm%p-1.0_pReal) StressRatio_pminus1 = StressRatio**(prm%p-1.0_pREAL)
t_n = prm%b_sl*exp(BoltzmannRatio*(1.0_pReal-StressRatio_p) ** prm%q) & t_n = prm%b_sl*exp(BoltzmannRatio*(1.0_pREAL-StressRatio_p) ** prm%q) &
/ (prm%omega*effectiveLength) / (prm%omega*effectiveLength)
t_k = effectiveLength * prm%B /(2.0_pReal*prm%b_sl*tau_eff) ! corrected eq. (14) t_k = effectiveLength * prm%B /(2.0_pREAL*prm%b_sl*tau_eff) ! corrected eq. (14)
dot_gamma_pos = b_rho_half * sign(prm%h/(t_n + t_k),tau_pos) dot_gamma_pos = b_rho_half * sign(prm%h/(t_n + t_k),tau_pos)
else where significantPositiveTau else where significantPositiveTau
dot_gamma_pos = 0.0_pReal dot_gamma_pos = 0.0_pREAL
end where significantPositiveTau end where significantPositiveTau
if (present(ddot_gamma_dtau_pos)) then if (present(ddot_gamma_dtau_pos)) then
significantPositiveTau2: where(abs(tau_pos)-dst%tau_pass(:,en) > tol_math_check) significantPositiveTau2: where(abs(tau_pos)-dst%tau_pass(:,en) > tol_math_check)
dtn = -1.0_pReal * t_n * BoltzmannRatio * prm%p * prm%q * (1.0_pReal-StressRatio_p)**(prm%q - 1.0_pReal) & dtn = -1.0_pREAL * t_n * BoltzmannRatio * prm%p * prm%q * (1.0_pREAL-StressRatio_p)**(prm%q - 1.0_pREAL) &
* StressRatio_pminus1 / prm%tau_Peierls * StressRatio_pminus1 / prm%tau_Peierls
dtk = -1.0_pReal * t_k / tau_pos dtk = -1.0_pREAL * t_k / tau_pos
dvel = -1.0_pReal * prm%h * (dtk + dtn) / (t_n + t_k)**2 dvel = -1.0_pREAL * prm%h * (dtk + dtn) / (t_n + t_k)**2
ddot_gamma_dtau_pos = b_rho_half * dvel ddot_gamma_dtau_pos = b_rho_half * dvel
else where significantPositiveTau2 else where significantPositiveTau2
ddot_gamma_dtau_pos = 0.0_pReal ddot_gamma_dtau_pos = 0.0_pREAL
end where significantPositiveTau2 end where significantPositiveTau2
end if end if
@ -533,28 +533,28 @@ pure subroutine kinetics(Mp,T,ph,en, &
significantNegativeTau: where(tau_eff > tol_math_check) significantNegativeTau: where(tau_eff > tol_math_check)
StressRatio = tau_eff/prm%tau_Peierls StressRatio = tau_eff/prm%tau_Peierls
StressRatio_p = StressRatio** prm%p StressRatio_p = StressRatio** prm%p
StressRatio_pminus1 = StressRatio**(prm%p-1.0_pReal) StressRatio_pminus1 = StressRatio**(prm%p-1.0_pREAL)
t_n = prm%b_sl*exp(BoltzmannRatio*(1.0_pReal-StressRatio_p) ** prm%q) & t_n = prm%b_sl*exp(BoltzmannRatio*(1.0_pREAL-StressRatio_p) ** prm%q) &
/ (prm%omega*effectiveLength) / (prm%omega*effectiveLength)
t_k = effectiveLength * prm%B /(2.0_pReal*prm%b_sl*tau_eff) ! corrected eq. (14) t_k = effectiveLength * prm%B /(2.0_pREAL*prm%b_sl*tau_eff) ! corrected eq. (14)
dot_gamma_neg = b_rho_half * sign(prm%h/(t_n + t_k),tau_neg) dot_gamma_neg = b_rho_half * sign(prm%h/(t_n + t_k),tau_neg)
else where significantNegativeTau else where significantNegativeTau
dot_gamma_neg = 0.0_pReal dot_gamma_neg = 0.0_pREAL
end where significantNegativeTau end where significantNegativeTau
if (present(ddot_gamma_dtau_neg)) then if (present(ddot_gamma_dtau_neg)) then
significantNegativeTau2: where(abs(tau_neg)-dst%tau_pass(:,en) > tol_math_check) significantNegativeTau2: where(abs(tau_neg)-dst%tau_pass(:,en) > tol_math_check)
dtn = -1.0_pReal * t_n * BoltzmannRatio * prm%p * prm%q * (1.0_pReal-StressRatio_p)**(prm%q - 1.0_pReal) & dtn = -1.0_pREAL * t_n * BoltzmannRatio * prm%p * prm%q * (1.0_pREAL-StressRatio_p)**(prm%q - 1.0_pREAL) &
* StressRatio_pminus1 / prm%tau_Peierls * StressRatio_pminus1 / prm%tau_Peierls
dtk = -1.0_pReal * t_k / tau_neg dtk = -1.0_pREAL * t_k / tau_neg
dvel = -1.0_pReal * prm%h * (dtk + dtn) / (t_n + t_k)**2 dvel = -1.0_pREAL * prm%h * (dtk + dtn) / (t_n + t_k)**2
ddot_gamma_dtau_neg = b_rho_half * dvel ddot_gamma_dtau_neg = b_rho_half * dvel
else where significantNegativeTau2 else where significantNegativeTau2
ddot_gamma_dtau_neg = 0.0_pReal ddot_gamma_dtau_neg = 0.0_pREAL
end where significantNegativeTau2 end where significantNegativeTau2
end if end if

352
src/phase_mechanical_plastic_dislotwin.f90
View File

@ -9,31 +9,31 @@
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
submodule(phase:plastic) dislotwin submodule(phase:plastic) dislotwin
real(pReal), parameter :: gamma_char_tr = sqrt(0.125_pReal) !< Characteristic shear for transformation real(pREAL), parameter :: gamma_char_tr = sqrt(0.125_pREAL) !< Characteristic shear for transformation
type :: tParameters type :: tParameters
real(pReal) :: & real(pREAL) :: &
Q_cl = 1.0_pReal, & !< activation energy for dislocation climb Q_cl = 1.0_pREAL, & !< activation energy for dislocation climb
omega = 1.0_pReal, & !< frequency factor for dislocation climb omega = 1.0_pREAL, & !< frequency factor for dislocation climb
D = 1.0_pReal, & !< grain size D = 1.0_pREAL, & !< grain size
p_sb = 1.0_pReal, & !< p-exponent in shear band velocity p_sb = 1.0_pREAL, & !< p-exponent in shear band velocity
q_sb = 1.0_pReal, & !< q-exponent in shear band velocity q_sb = 1.0_pREAL, & !< q-exponent in shear band velocity
i_tw = 1.0_pReal, & !< adjustment parameter to calculate MFP for twinning i_tw = 1.0_pREAL, & !< adjustment parameter to calculate MFP for twinning
i_tr = 1.0_pReal, & !< adjustment parameter to calculate MFP for transformation i_tr = 1.0_pREAL, & !< adjustment parameter to calculate MFP for transformation
L_tw = 1.0_pReal, & !< length of twin nuclei L_tw = 1.0_pREAL, & !< length of twin nuclei
L_tr = 1.0_pReal, & !< length of trans nuclei L_tr = 1.0_pREAL, & !< length of trans nuclei
x_c = 1.0_pReal, & !< critical distance for formation of twin/trans nucleus x_c = 1.0_pREAL, & !< critical distance for formation of twin/trans nucleus
V_cs = 1.0_pReal, & !< cross slip volume V_cs = 1.0_pREAL, & !< cross slip volume
tau_sb = 1.0_pReal, & !< value for shearband resistance tau_sb = 1.0_pREAL, & !< value for shearband resistance
gamma_0_sb = 1.0_pReal, & !< value for shearband velocity_0 gamma_0_sb = 1.0_pREAL, & !< value for shearband velocity_0
E_sb = 1.0_pReal, & !< activation energy for shear bands E_sb = 1.0_pREAL, & !< activation energy for shear bands
h = 1.0_pReal, & !< stack height of hex nucleus h = 1.0_pREAL, & !< stack height of hex nucleus
cOverA_hP = 1.0_pReal, & cOverA_hP = 1.0_pREAL, &
V_mol = 1.0_pReal, & V_mol = 1.0_pREAL, &
rho = 1.0_pReal rho = 1.0_pREAL
type(tPolynomial) :: & type(tPolynomial) :: &
Gamma_sf, & !< stacking fault energy Gamma_sf, & !< stacking fault energy
Delta_G !< free energy difference between austensite and martensite Delta_G !< free energy difference between austensite and martensite
real(pReal), allocatable, dimension(:) :: & real(pREAL), allocatable, dimension(:) :: &
b_sl, & !< absolute length of Burgers vector [m] for each slip system b_sl, & !< absolute length of Burgers vector [m] for each slip system
b_tw, & !< absolute length of Burgers vector [m] for each twin system b_tw, & !< absolute length of Burgers vector [m] for each twin system
b_tr, & !< absolute length of Burgers vector [m] for each transformation system b_tr, & !< absolute length of Burgers vector [m] for each transformation system
@ -51,7 +51,7 @@ submodule(phase:plastic) dislotwin
gamma_char_tw, & !< characteristic shear for twins gamma_char_tw, & !< characteristic shear for twins
B, & !< drag coefficient B, & !< drag coefficient
d_caron !< distance of spontaneous annhihilation d_caron !< distance of spontaneous annhihilation
real(pReal), allocatable, dimension(:,:) :: & real(pREAL), allocatable, dimension(:,:) :: &
h_sl_sl, & !< components of slip-slip interaction matrix h_sl_sl, & !< components of slip-slip interaction matrix
h_sl_tw, & !< components of slip-twin interaction matrix h_sl_tw, & !< components of slip-twin interaction matrix
h_sl_tr, & !< components of slip-trans interaction matrix h_sl_tr, & !< components of slip-trans interaction matrix
@ -59,7 +59,7 @@ submodule(phase:plastic) dislotwin
h_tr_tr, & !< components of trans-trans interaction matrix h_tr_tr, & !< components of trans-trans interaction matrix
n0_sl, & !< slip system normal n0_sl, & !< slip system normal
forestProjection forestProjection
real(pReal), allocatable, dimension(:,:,:) :: & real(pREAL), allocatable, dimension(:,:,:) :: &
P_sl, & P_sl, &
P_tw, & P_tw, &
P_tr P_tr
@ -96,7 +96,7 @@ submodule(phase:plastic) dislotwin
end type tIndexDotState end type tIndexDotState
type :: tDislotwinState type :: tDislotwinState
real(pReal), dimension(:,:), pointer :: & real(pREAL), dimension(:,:), pointer :: &
rho_mob, & rho_mob, &
rho_dip, & rho_dip, &
gamma_sl, & gamma_sl, &
@ -105,7 +105,7 @@ submodule(phase:plastic) dislotwin
end type tDislotwinState end type tDislotwinState
type :: tDislotwinDependentState type :: tDislotwinDependentState
real(pReal), dimension(:,:), allocatable :: & real(pREAL), dimension(:,:), allocatable :: &
Lambda_sl, & !< mean free path between 2 obstacles seen by a moving dislocation Lambda_sl, & !< mean free path between 2 obstacles seen by a moving dislocation
Lambda_tw, & !< mean free path between 2 obstacles seen by a growing twin Lambda_tw, & !< mean free path between 2 obstacles seen by a growing twin
Lambda_tr, & !< mean free path between 2 obstacles seen by a growing martensite Lambda_tr, & !< mean free path between 2 obstacles seen by a growing martensite
@ -136,8 +136,8 @@ module function plastic_dislotwin_init() result(myPlasticity)
startIndex, endIndex startIndex, endIndex
integer, dimension(:), allocatable :: & integer, dimension(:), allocatable :: &
N_sl N_sl
real(pReal) :: a_cF real(pREAL) :: a_cF
real(pReal), allocatable, dimension(:) :: & real(pREAL), allocatable, dimension(:) :: &
rho_mob_0, & !< initial unipolar dislocation density per slip system rho_mob_0, & !< initial unipolar dislocation density per slip system
rho_dip_0 !< initial dipole dislocation density per slip system rho_dip_0 !< initial dipole dislocation density per slip system
character(len=:), allocatable :: & character(len=:), allocatable :: &
@ -220,7 +220,7 @@ module function plastic_dislotwin_init() result(myPlasticity)
prm%q = pl%get_as1dReal('q_sl', requiredSize=size(N_sl)) prm%q = pl%get_as1dReal('q_sl', requiredSize=size(N_sl))
prm%tau_0 = pl%get_as1dReal('tau_0', requiredSize=size(N_sl)) prm%tau_0 = pl%get_as1dReal('tau_0', requiredSize=size(N_sl))
prm%B = pl%get_as1dReal('B', requiredSize=size(N_sl), & prm%B = pl%get_as1dReal('B', requiredSize=size(N_sl), &
defaultVal=[(0.0_pReal, i=1,size(N_sl))]) defaultVal=[(0.0_pREAL, i=1,size(N_sl))])
prm%Q_cl = pl%get_asReal('Q_cl') prm%Q_cl = pl%get_asReal('Q_cl')
@ -229,8 +229,8 @@ module function plastic_dislotwin_init() result(myPlasticity)
! multiplication factor according to crystal structure (nearest neighbors bcc vs fcc/hex) ! multiplication factor according to crystal structure (nearest neighbors bcc vs fcc/hex)
! details: Argon & Moffat, Acta Metallurgica, Vol. 29, pg 293 to 299, 1981 ! details: Argon & Moffat, Acta Metallurgica, Vol. 29, pg 293 to 299, 1981
prm%omega = pl%get_asReal('omega', defaultVal = 1000.0_pReal) & prm%omega = pl%get_asReal('omega', defaultVal = 1000.0_pREAL) &
* merge(12.0_pReal,8.0_pReal,any(phase_lattice(ph) == ['cF','hP'])) * merge(12.0_pREAL,8.0_pREAL,any(phase_lattice(ph) == ['cF','hP']))
! expand: family => system ! expand: family => system
rho_mob_0 = math_expand(rho_mob_0, N_sl) rho_mob_0 = math_expand(rho_mob_0, N_sl)
@ -246,17 +246,17 @@ module function plastic_dislotwin_init() result(myPlasticity)
prm%d_caron = pl%get_asReal('D_a') * prm%b_sl prm%d_caron = pl%get_asReal('D_a') * prm%b_sl
! sanity checks ! sanity checks
if ( prm%Q_cl <= 0.0_pReal) extmsg = trim(extmsg)//' Q_cl' if ( prm%Q_cl <= 0.0_pREAL) extmsg = trim(extmsg)//' Q_cl'
if (any(rho_mob_0 < 0.0_pReal)) extmsg = trim(extmsg)//' rho_mob_0' if (any(rho_mob_0 < 0.0_pREAL)) extmsg = trim(extmsg)//' rho_mob_0'
if (any(rho_dip_0 < 0.0_pReal)) extmsg = trim(extmsg)//' rho_dip_0' if (any(rho_dip_0 < 0.0_pREAL)) extmsg = trim(extmsg)//' rho_dip_0'
if (any(prm%v_0 < 0.0_pReal)) extmsg = trim(extmsg)//' v_0' if (any(prm%v_0 < 0.0_pREAL)) extmsg = trim(extmsg)//' v_0'
if (any(prm%b_sl <= 0.0_pReal)) extmsg = trim(extmsg)//' b_sl' if (any(prm%b_sl <= 0.0_pREAL)) extmsg = trim(extmsg)//' b_sl'
if (any(prm%Q_sl <= 0.0_pReal)) extmsg = trim(extmsg)//' Q_sl' if (any(prm%Q_sl <= 0.0_pREAL)) extmsg = trim(extmsg)//' Q_sl'
if (any(prm%i_sl <= 0.0_pReal)) extmsg = trim(extmsg)//' i_sl' if (any(prm%i_sl <= 0.0_pREAL)) extmsg = trim(extmsg)//' i_sl'
if (any(prm%B < 0.0_pReal)) extmsg = trim(extmsg)//' B' if (any(prm%B < 0.0_pREAL)) extmsg = trim(extmsg)//' B'
if (any(prm%d_caron < 0.0_pReal)) extmsg = trim(extmsg)//' d_caron(D_a,b_sl)' if (any(prm%d_caron < 0.0_pREAL)) extmsg = trim(extmsg)//' d_caron(D_a,b_sl)'
if (any(prm%p<=0.0_pReal .or. prm%p>1.0_pReal)) extmsg = trim(extmsg)//' p_sl' if (any(prm%p<=0.0_pREAL .or. prm%p>1.0_pREAL)) extmsg = trim(extmsg)//' p_sl'
if (any(prm%q< 1.0_pReal .or. prm%q>2.0_pReal)) extmsg = trim(extmsg)//' q_sl' if (any(prm%q< 1.0_pREAL .or. prm%q>2.0_pREAL)) extmsg = trim(extmsg)//' q_sl'
else slipActive else slipActive
rho_mob_0 = emptyRealArray; rho_dip_0 = emptyRealArray rho_mob_0 = emptyRealArray; rho_dip_0 = emptyRealArray
allocate(prm%b_sl,prm%Q_sl,prm%v_0,prm%i_sl,prm%p,prm%q,prm%B,source=emptyRealArray) allocate(prm%b_sl,prm%Q_sl,prm%v_0,prm%i_sl,prm%p,prm%q,prm%B,source=emptyRealArray)
@ -289,11 +289,11 @@ module function plastic_dislotwin_init() result(myPlasticity)
! sanity checks ! sanity checks
if (.not. prm%fccTwinTransNucleation) extmsg = trim(extmsg)//' TWIP for non-fcc' if (.not. prm%fccTwinTransNucleation) extmsg = trim(extmsg)//' TWIP for non-fcc'
if ( prm%L_tw < 0.0_pReal) extmsg = trim(extmsg)//' L_tw' if ( prm%L_tw < 0.0_pREAL) extmsg = trim(extmsg)//' L_tw'
if ( prm%i_tw < 0.0_pReal) extmsg = trim(extmsg)//' i_tw' if ( prm%i_tw < 0.0_pREAL) extmsg = trim(extmsg)//' i_tw'
if (any(prm%b_tw < 0.0_pReal)) extmsg = trim(extmsg)//' b_tw' if (any(prm%b_tw < 0.0_pREAL)) extmsg = trim(extmsg)//' b_tw'
if (any(prm%t_tw < 0.0_pReal)) extmsg = trim(extmsg)//' t_tw' if (any(prm%t_tw < 0.0_pREAL)) extmsg = trim(extmsg)//' t_tw'
if (any(prm%r < 0.0_pReal)) extmsg = trim(extmsg)//' p_tw' if (any(prm%r < 0.0_pREAL)) extmsg = trim(extmsg)//' p_tw'
else twinActive else twinActive
allocate(prm%gamma_char_tw,prm%b_tw,prm%t_tw,prm%r,source=emptyRealArray) allocate(prm%gamma_char_tw,prm%b_tw,prm%t_tw,prm%r,source=emptyRealArray)
allocate(prm%h_tw_tw(0,0)) allocate(prm%h_tw_tw(0,0))
@ -310,10 +310,10 @@ module function plastic_dislotwin_init() result(myPlasticity)
prm%i_tr = pl%get_asReal('i_tr') prm%i_tr = pl%get_asReal('i_tr')
prm%Delta_G = polynomial(pl,'Delta_G','T') prm%Delta_G = polynomial(pl,'Delta_G','T')
prm%L_tr = pl%get_asReal('L_tr') prm%L_tr = pl%get_asReal('L_tr')
a_cF = prm%b_tr(1)*sqrt(6.0_pReal) ! b_tr is Shockley partial a_cF = prm%b_tr(1)*sqrt(6.0_pREAL) ! b_tr is Shockley partial
prm%h = 5.0_pReal * a_cF/sqrt(3.0_pReal) prm%h = 5.0_pREAL * a_cF/sqrt(3.0_pREAL)
prm%cOverA_hP = pl%get_asReal('c/a_hP') prm%cOverA_hP = pl%get_asReal('c/a_hP')
prm%rho = 4.0_pReal/(sqrt(3.0_pReal)*a_cF**2)/N_A prm%rho = 4.0_pREAL/(sqrt(3.0_pREAL)*a_cF**2)/N_A
prm%V_mol = pl%get_asReal('V_mol') prm%V_mol = pl%get_asReal('V_mol')
prm%h_tr_tr = lattice_interaction_TransByTrans(prm%N_tr,pl%get_as1dReal('h_tr-tr'),& prm%h_tr_tr = lattice_interaction_TransByTrans(prm%N_tr,pl%get_as1dReal('h_tr-tr'),&
phase_lattice(ph)) phase_lattice(ph))
@ -327,11 +327,11 @@ module function plastic_dislotwin_init() result(myPlasticity)
! sanity checks ! sanity checks
if (.not. prm%fccTwinTransNucleation) extmsg = trim(extmsg)//' TRIP for non-fcc' if (.not. prm%fccTwinTransNucleation) extmsg = trim(extmsg)//' TRIP for non-fcc'
if ( prm%L_tr < 0.0_pReal) extmsg = trim(extmsg)//' L_tr' if ( prm%L_tr < 0.0_pREAL) extmsg = trim(extmsg)//' L_tr'
if ( prm%V_mol < 0.0_pReal) extmsg = trim(extmsg)//' V_mol' if ( prm%V_mol < 0.0_pREAL) extmsg = trim(extmsg)//' V_mol'
if ( prm%i_tr < 0.0_pReal) extmsg = trim(extmsg)//' i_tr' if ( prm%i_tr < 0.0_pREAL) extmsg = trim(extmsg)//' i_tr'
if (any(prm%t_tr < 0.0_pReal)) extmsg = trim(extmsg)//' t_tr' if (any(prm%t_tr < 0.0_pREAL)) extmsg = trim(extmsg)//' t_tr'
if (any(prm%s < 0.0_pReal)) extmsg = trim(extmsg)//' p_tr' if (any(prm%s < 0.0_pREAL)) extmsg = trim(extmsg)//' p_tr'
else transActive else transActive
allocate(prm%s,prm%b_tr,prm%t_tr,source=emptyRealArray) allocate(prm%s,prm%b_tr,prm%t_tr,source=emptyRealArray)
allocate(prm%h_tr_tr(0,0)) allocate(prm%h_tr_tr(0,0))
@ -339,18 +339,18 @@ module function plastic_dislotwin_init() result(myPlasticity)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! shearband related parameters ! shearband related parameters
prm%gamma_0_sb = pl%get_asReal('gamma_0_sb',defaultVal=0.0_pReal) prm%gamma_0_sb = pl%get_asReal('gamma_0_sb',defaultVal=0.0_pREAL)
if (prm%gamma_0_sb > 0.0_pReal) then if (prm%gamma_0_sb > 0.0_pREAL) then
prm%tau_sb = pl%get_asReal('tau_sb') prm%tau_sb = pl%get_asReal('tau_sb')
prm%E_sb = pl%get_asReal('Q_sb') prm%E_sb = pl%get_asReal('Q_sb')
prm%p_sb = pl%get_asReal('p_sb') prm%p_sb = pl%get_asReal('p_sb')
prm%q_sb = pl%get_asReal('q_sb') prm%q_sb = pl%get_asReal('q_sb')
! sanity checks ! sanity checks
if (prm%tau_sb < 0.0_pReal) extmsg = trim(extmsg)//' tau_sb' if (prm%tau_sb < 0.0_pREAL) extmsg = trim(extmsg)//' tau_sb'
if (prm%E_sb < 0.0_pReal) extmsg = trim(extmsg)//' Q_sb' if (prm%E_sb < 0.0_pREAL) extmsg = trim(extmsg)//' Q_sb'
if (prm%p_sb <= 0.0_pReal) extmsg = trim(extmsg)//' p_sb' if (prm%p_sb <= 0.0_pREAL) extmsg = trim(extmsg)//' p_sb'
if (prm%q_sb <= 0.0_pReal) extmsg = trim(extmsg)//' q_sb' if (prm%q_sb <= 0.0_pREAL) extmsg = trim(extmsg)//' q_sb'
end if end if
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
@ -361,8 +361,8 @@ module function plastic_dislotwin_init() result(myPlasticity)
if (prm%sum_N_tw + prm%sum_N_tr > 0) then if (prm%sum_N_tw + prm%sum_N_tr > 0) then
prm%x_c = pl%get_asReal('x_c') prm%x_c = pl%get_asReal('x_c')
prm%V_cs = pl%get_asReal('V_cs') prm%V_cs = pl%get_asReal('V_cs')
if (prm%x_c < 0.0_pReal) extmsg = trim(extmsg)//' x_c' if (prm%x_c < 0.0_pREAL) extmsg = trim(extmsg)//' x_c'
if (prm%V_cs < 0.0_pReal) extmsg = trim(extmsg)//' V_cs' if (prm%V_cs < 0.0_pREAL) extmsg = trim(extmsg)//' V_cs'
end if end if
if (prm%sum_N_tw + prm%sum_N_tr > 0 .or. prm%extendedDislocations) & if (prm%sum_N_tw + prm%sum_N_tr > 0 .or. prm%extendedDislocations) &
@ -402,41 +402,41 @@ module function plastic_dislotwin_init() result(myPlasticity)
idx_dot%rho_mob = [startIndex,endIndex] idx_dot%rho_mob = [startIndex,endIndex]
stt%rho_mob=>plasticState(ph)%state(startIndex:endIndex,:) stt%rho_mob=>plasticState(ph)%state(startIndex:endIndex,:)
stt%rho_mob= spread(rho_mob_0,2,Nmembers) stt%rho_mob= spread(rho_mob_0,2,Nmembers)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_rho',defaultVal=1.0_pReal) plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_rho',defaultVal=1.0_pREAL)
if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_rho' if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pREAL)) extmsg = trim(extmsg)//' atol_rho'
startIndex = endIndex + 1 startIndex = endIndex + 1
endIndex = endIndex + prm%sum_N_sl endIndex = endIndex + prm%sum_N_sl
idx_dot%rho_dip = [startIndex,endIndex] idx_dot%rho_dip = [startIndex,endIndex]
stt%rho_dip=>plasticState(ph)%state(startIndex:endIndex,:) stt%rho_dip=>plasticState(ph)%state(startIndex:endIndex,:)
stt%rho_dip= spread(rho_dip_0,2,Nmembers) stt%rho_dip= spread(rho_dip_0,2,Nmembers)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_rho',defaultVal=1.0_pReal) plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_rho',defaultVal=1.0_pREAL)
startIndex = endIndex + 1 startIndex = endIndex + 1
endIndex = endIndex + prm%sum_N_sl endIndex = endIndex + prm%sum_N_sl
idx_dot%gamma_sl = [startIndex,endIndex] idx_dot%gamma_sl = [startIndex,endIndex]
stt%gamma_sl=>plasticState(ph)%state(startIndex:endIndex,:) stt%gamma_sl=>plasticState(ph)%state(startIndex:endIndex,:)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_gamma',defaultVal=1.0e-6_pReal) plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_gamma',defaultVal=1.0e-6_pREAL)
if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_gamma' if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pREAL)) extmsg = trim(extmsg)//' atol_gamma'
startIndex = endIndex + 1 startIndex = endIndex + 1
endIndex = endIndex + prm%sum_N_tw endIndex = endIndex + prm%sum_N_tw
idx_dot%f_tw = [startIndex,endIndex] idx_dot%f_tw = [startIndex,endIndex]
stt%f_tw=>plasticState(ph)%state(startIndex:endIndex,:) stt%f_tw=>plasticState(ph)%state(startIndex:endIndex,:)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_f_tw',defaultVal=1.0e-6_pReal) plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_f_tw',defaultVal=1.0e-6_pREAL)
if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_f_tw' if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pREAL)) extmsg = trim(extmsg)//' atol_f_tw'
startIndex = endIndex + 1 startIndex = endIndex + 1
endIndex = endIndex + prm%sum_N_tr endIndex = endIndex + prm%sum_N_tr
idx_dot%f_tr = [startIndex,endIndex] idx_dot%f_tr = [startIndex,endIndex]
stt%f_tr=>plasticState(ph)%state(startIndex:endIndex,:) stt%f_tr=>plasticState(ph)%state(startIndex:endIndex,:)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_f_tr',defaultVal=1.0e-6_pReal) plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_f_tr',defaultVal=1.0e-6_pREAL)
if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_f_tr' if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pREAL)) extmsg = trim(extmsg)//' atol_f_tr'
allocate(dst%tau_pass (prm%sum_N_sl,Nmembers),source=0.0_pReal) allocate(dst%tau_pass (prm%sum_N_sl,Nmembers),source=0.0_pREAL)
allocate(dst%Lambda_sl(prm%sum_N_sl,Nmembers),source=0.0_pReal) allocate(dst%Lambda_sl(prm%sum_N_sl,Nmembers),source=0.0_pREAL)
allocate(dst%Lambda_tw(prm%sum_N_tw,Nmembers),source=0.0_pReal) allocate(dst%Lambda_tw(prm%sum_N_tw,Nmembers),source=0.0_pREAL)
allocate(dst%Lambda_tr(prm%sum_N_tr,Nmembers),source=0.0_pReal) allocate(dst%Lambda_tr(prm%sum_N_tr,Nmembers),source=0.0_pREAL)
end associate end associate
@ -456,21 +456,21 @@ module function plastic_dislotwin_homogenizedC(ph,en) result(homogenizedC)
integer, intent(in) :: & integer, intent(in) :: &
ph, en ph, en
real(pReal), dimension(6,6) :: & real(pREAL), dimension(6,6) :: &
homogenizedC, & homogenizedC, &
C C
real(pReal), dimension(:,:,:), allocatable :: & real(pREAL), dimension(:,:,:), allocatable :: &
C66_tw, & C66_tw, &
C66_tr C66_tr
integer :: i integer :: i
real(pReal) :: f_matrix real(pREAL) :: f_matrix
C = elastic_C66(ph,en) C = elastic_C66(ph,en)
associate(prm => param(ph), stt => state(ph)) associate(prm => param(ph), stt => state(ph))
f_matrix = 1.0_pReal & f_matrix = 1.0_pREAL &
- sum(stt%f_tw(1:prm%sum_N_tw,en)) & - sum(stt%f_tw(1:prm%sum_N_tw,en)) &
- sum(stt%f_tr(1:prm%sum_N_tr,en)) - sum(stt%f_tr(1:prm%sum_N_tr,en))
@ -502,28 +502,28 @@ end function plastic_dislotwin_homogenizedC
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
module subroutine dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en) module subroutine dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en)
real(pReal), dimension(3,3), intent(out) :: Lp real(pREAL), dimension(3,3), intent(out) :: Lp
real(pReal), dimension(3,3,3,3), intent(out) :: dLp_dMp real(pREAL), dimension(3,3,3,3), intent(out) :: dLp_dMp
real(pReal), dimension(3,3), intent(in) :: Mp real(pREAL), dimension(3,3), intent(in) :: Mp
integer, intent(in) :: ph,en integer, intent(in) :: ph,en
integer :: i,k,l,m,n integer :: i,k,l,m,n
real(pReal) :: & real(pREAL) :: &
f_matrix,StressRatio_p,& f_matrix,StressRatio_p,&
E_kB_T, & E_kB_T, &
ddot_gamma_dtau, & ddot_gamma_dtau, &
tau, & tau, &
T T
real(pReal), dimension(param(ph)%sum_N_sl) :: & real(pREAL), dimension(param(ph)%sum_N_sl) :: &
dot_gamma_sl,ddot_gamma_dtau_sl dot_gamma_sl,ddot_gamma_dtau_sl
real(pReal), dimension(param(ph)%sum_N_tw) :: & real(pREAL), dimension(param(ph)%sum_N_tw) :: &
dot_gamma_tw,ddot_gamma_dtau_tw dot_gamma_tw,ddot_gamma_dtau_tw
real(pReal), dimension(param(ph)%sum_N_tr) :: & real(pREAL), dimension(param(ph)%sum_N_tr) :: &
dot_gamma_tr,ddot_gamma_dtau_tr dot_gamma_tr,ddot_gamma_dtau_tr
real(pReal):: dot_gamma_sb real(pREAL):: dot_gamma_sb
real(pReal), dimension(3,3) :: eigVectors, P_sb real(pREAL), dimension(3,3) :: eigVectors, P_sb
real(pReal), dimension(3) :: eigValues real(pREAL), dimension(3) :: eigValues
real(pReal), dimension(3,6), parameter :: & real(pREAL), dimension(3,6), parameter :: &
sb_sComposition = & sb_sComposition = &
reshape(real([& reshape(real([&
1, 0, 1, & 1, 0, 1, &
@ -532,7 +532,7 @@ module subroutine dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en)
1,-1, 0, & 1,-1, 0, &
0, 1, 1, & 0, 1, 1, &
0, 1,-1 & 0, 1,-1 &
],pReal),[ 3,6]), & ],pREAL),[ 3,6]), &
sb_mComposition = & sb_mComposition = &
reshape(real([& reshape(real([&
1, 0,-1, & 1, 0,-1, &
@ -541,16 +541,16 @@ module subroutine dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en)
1, 1, 0, & 1, 1, 0, &
0, 1,-1, & 0, 1,-1, &
0, 1, 1 & 0, 1, 1 &
],pReal),[ 3,6]) ],pREAL),[ 3,6])
T = thermal_T(ph,en) T = thermal_T(ph,en)
Lp = 0.0_pReal Lp = 0.0_pREAL
dLp_dMp = 0.0_pReal dLp_dMp = 0.0_pREAL
associate(prm => param(ph), stt => state(ph)) associate(prm => param(ph), stt => state(ph))
f_matrix = 1.0_pReal & f_matrix = 1.0_pREAL &
- sum(stt%f_tw(1:prm%sum_N_tw,en)) & - sum(stt%f_tw(1:prm%sum_N_tw,en)) &
- sum(stt%f_tr(1:prm%sum_N_tr,en)) - sum(stt%f_tr(1:prm%sum_N_tr,en))
@ -587,7 +587,7 @@ module subroutine dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en)
call math_eigh33(eigValues,eigVectors,Mp) ! is Mp symmetric by design? call math_eigh33(eigValues,eigVectors,Mp) ! is Mp symmetric by design?
do i = 1,6 do i = 1,6
P_sb = 0.5_pReal * math_outer(matmul(eigVectors,sb_sComposition(1:3,i)),& P_sb = 0.5_pREAL * math_outer(matmul(eigVectors,sb_sComposition(1:3,i)),&
matmul(eigVectors,sb_mComposition(1:3,i))) matmul(eigVectors,sb_mComposition(1:3,i)))
tau = math_tensordot(Mp,P_sb) tau = math_tensordot(Mp,P_sb)
@ -595,8 +595,8 @@ module subroutine dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en)
StressRatio_p = (abs(tau)/prm%tau_sb)**prm%p_sb StressRatio_p = (abs(tau)/prm%tau_sb)**prm%p_sb
dot_gamma_sb = sign(prm%gamma_0_sb*exp(-E_kB_T*(1-StressRatio_p)**prm%q_sb), tau) dot_gamma_sb = sign(prm%gamma_0_sb*exp(-E_kB_T*(1-StressRatio_p)**prm%q_sb), tau)
ddot_gamma_dtau = abs(dot_gamma_sb)*E_kB_T*prm%p_sb*prm%q_sb/prm%tau_sb & ddot_gamma_dtau = abs(dot_gamma_sb)*E_kB_T*prm%p_sb*prm%q_sb/prm%tau_sb &
* (abs(tau)/prm%tau_sb)**(prm%p_sb-1.0_pReal) & * (abs(tau)/prm%tau_sb)**(prm%p_sb-1.0_pREAL) &
* (1.0_pReal-StressRatio_p)**(prm%q_sb-1.0_pReal) * (1.0_pREAL-StressRatio_p)**(prm%q_sb-1.0_pREAL)
Lp = Lp + dot_gamma_sb * P_sb Lp = Lp + dot_gamma_sb * P_sb
forall (k=1:3,l=1:3,m=1:3,n=1:3) & forall (k=1:3,l=1:3,m=1:3,n=1:3) &
@ -617,31 +617,31 @@ end subroutine dislotwin_LpAndItsTangent
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
module function dislotwin_dotState(Mp,ph,en) result(dotState) module function dislotwin_dotState(Mp,ph,en) result(dotState)
real(pReal), dimension(3,3), intent(in):: & real(pREAL), dimension(3,3), intent(in):: &
Mp !< Mandel stress Mp !< Mandel stress
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
real(pReal), dimension(plasticState(ph)%sizeDotState) :: & real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
dotState dotState
integer :: i integer :: i
real(pReal) :: & real(pREAL) :: &
f_matrix, & f_matrix, &
d_hat, & d_hat, &
v_cl, & !< climb velocity v_cl, & !< climb velocity
tau, & tau, &
sigma_cl, & !< climb stress sigma_cl, & !< climb stress
b_d !< ratio of Burgers vector to stacking fault width b_d !< ratio of Burgers vector to stacking fault width
real(pReal), dimension(param(ph)%sum_N_sl) :: & real(pREAL), dimension(param(ph)%sum_N_sl) :: &
dot_rho_dip_formation, & dot_rho_dip_formation, &
dot_rho_dip_climb, & dot_rho_dip_climb, &
dot_gamma_sl dot_gamma_sl
real(pReal), dimension(param(ph)%sum_N_tw) :: & real(pREAL), dimension(param(ph)%sum_N_tw) :: &
dot_gamma_tw dot_gamma_tw
real(pReal), dimension(param(ph)%sum_N_tr) :: & real(pREAL), dimension(param(ph)%sum_N_tr) :: &
dot_gamma_tr dot_gamma_tr
real(pReal) :: & real(pREAL) :: &
mu, nu, & mu, nu, &
T T
@ -657,7 +657,7 @@ module function dislotwin_dotState(Mp,ph,en) result(dotState)
nu = elastic_nu(ph,en,prm%isotropic_bound) nu = elastic_nu(ph,en,prm%isotropic_bound)
T = thermal_T(ph,en) T = thermal_T(ph,en)
f_matrix = 1.0_pReal & f_matrix = 1.0_pREAL &
- sum(stt%f_tw(1:prm%sum_N_tw,en)) & - sum(stt%f_tw(1:prm%sum_N_tw,en)) &
- sum(stt%f_tr(1:prm%sum_N_tr,en)) - sum(stt%f_tr(1:prm%sum_N_tr,en))
@ -668,30 +668,30 @@ module function dislotwin_dotState(Mp,ph,en) result(dotState)
tau = math_tensordot(Mp,prm%P_sl(1:3,1:3,i)) tau = math_tensordot(Mp,prm%P_sl(1:3,1:3,i))
significantSlipStress: if (dEq0(tau) .or. prm%omitDipoles) then significantSlipStress: if (dEq0(tau) .or. prm%omitDipoles) then
dot_rho_dip_formation(i) = 0.0_pReal dot_rho_dip_formation(i) = 0.0_pREAL
dot_rho_dip_climb(i) = 0.0_pReal dot_rho_dip_climb(i) = 0.0_pREAL
else significantSlipStress else significantSlipStress
d_hat = 3.0_pReal*mu*prm%b_sl(i)/(16.0_pReal*PI*abs(tau)) d_hat = 3.0_pREAL*mu*prm%b_sl(i)/(16.0_pREAL*PI*abs(tau))
d_hat = math_clip(d_hat, right = dst%Lambda_sl(i,en)) d_hat = math_clip(d_hat, right = dst%Lambda_sl(i,en))
d_hat = math_clip(d_hat, left = prm%d_caron(i)) d_hat = math_clip(d_hat, left = prm%d_caron(i))
dot_rho_dip_formation(i) = 2.0_pReal*(d_hat-prm%d_caron(i))/prm%b_sl(i) & dot_rho_dip_formation(i) = 2.0_pREAL*(d_hat-prm%d_caron(i))/prm%b_sl(i) &
* stt%rho_mob(i,en)*abs_dot_gamma_sl(i) * stt%rho_mob(i,en)*abs_dot_gamma_sl(i)
if (dEq(d_hat,prm%d_caron(i))) then if (dEq(d_hat,prm%d_caron(i))) then
dot_rho_dip_climb(i) = 0.0_pReal dot_rho_dip_climb(i) = 0.0_pREAL
else else
! Argon & Moffat, Acta Metallurgica, Vol. 29, pg 293 to 299, 1981 ! Argon & Moffat, Acta Metallurgica, Vol. 29, pg 293 to 299, 1981
sigma_cl = dot_product(prm%n0_sl(1:3,i),matmul(Mp,prm%n0_sl(1:3,i))) sigma_cl = dot_product(prm%n0_sl(1:3,i),matmul(Mp,prm%n0_sl(1:3,i)))
if (prm%extendedDislocations) then if (prm%extendedDislocations) then
b_d = 24.0_pReal*PI*(1.0_pReal - nu)/(2.0_pReal + nu) * prm%Gamma_sf%at(T) / (mu*prm%b_sl(i)) b_d = 24.0_pREAL*PI*(1.0_pREAL - nu)/(2.0_pREAL + nu) * prm%Gamma_sf%at(T) / (mu*prm%b_sl(i))
else else
b_d = 1.0_pReal b_d = 1.0_pREAL
end if end if
v_cl = 2.0_pReal*prm%omega*b_d**2*exp(-prm%Q_cl/(K_B*T)) & v_cl = 2.0_pREAL*prm%omega*b_d**2*exp(-prm%Q_cl/(K_B*T)) &
* (exp(abs(sigma_cl)*prm%b_sl(i)**3/(K_B*T)) - 1.0_pReal) * (exp(abs(sigma_cl)*prm%b_sl(i)**3/(K_B*T)) - 1.0_pREAL)
dot_rho_dip_climb(i) = 4.0_pReal*v_cl*stt%rho_dip(i,en) & dot_rho_dip_climb(i) = 4.0_pREAL*v_cl*stt%rho_dip(i,en) &
/ (d_hat-prm%d_caron(i)) / (d_hat-prm%d_caron(i))
end if end if
end if significantSlipStress end if significantSlipStress
@ -699,10 +699,10 @@ module function dislotwin_dotState(Mp,ph,en) result(dotState)
dot_rho_mob = abs_dot_gamma_sl/(prm%b_sl*dst%Lambda_sl(:,en)) & dot_rho_mob = abs_dot_gamma_sl/(prm%b_sl*dst%Lambda_sl(:,en)) &
- dot_rho_dip_formation & - dot_rho_dip_formation &
- 2.0_pReal*prm%d_caron/prm%b_sl * stt%rho_mob(:,en)*abs_dot_gamma_sl - 2.0_pREAL*prm%d_caron/prm%b_sl * stt%rho_mob(:,en)*abs_dot_gamma_sl
dot_rho_dip = dot_rho_dip_formation & dot_rho_dip = dot_rho_dip_formation &
- 2.0_pReal*prm%d_caron/prm%b_sl * stt%rho_dip(:,en)*abs_dot_gamma_sl & - 2.0_pREAL*prm%d_caron/prm%b_sl * stt%rho_dip(:,en)*abs_dot_gamma_sl &
- dot_rho_dip_climb - dot_rho_dip_climb
if (prm%sum_N_tw > 0) call kinetics_tw(Mp,T,abs_dot_gamma_sl,ph,en,dot_gamma_tw) if (prm%sum_N_tw > 0) call kinetics_tw(Mp,T,abs_dot_gamma_sl,ph,en,dot_gamma_tw)
@ -725,17 +725,17 @@ module subroutine dislotwin_dependentState(ph,en)
ph, & ph, &
en en
real(pReal) :: & real(pREAL) :: &
sumf_tw, sumf_tr sumf_tw, sumf_tr
real(pReal), dimension(param(ph)%sum_N_sl) :: & real(pREAL), dimension(param(ph)%sum_N_sl) :: &
inv_lambda_sl inv_lambda_sl
real(pReal), dimension(param(ph)%sum_N_tw) :: & real(pREAL), dimension(param(ph)%sum_N_tw) :: &
inv_lambda_tw_tw, & !< 1/mean free distance between 2 twin stacks from different systems seen by a growing twin inv_lambda_tw_tw, & !< 1/mean free distance between 2 twin stacks from different systems seen by a growing twin
f_over_t_tw f_over_t_tw
real(pReal), dimension(param(ph)%sum_N_tr) :: & real(pREAL), dimension(param(ph)%sum_N_tr) :: &
inv_lambda_tr_tr, & !< 1/mean free distance between 2 martensite stacks from different systems seen by a growing martensite inv_lambda_tr_tr, & !< 1/mean free distance between 2 martensite stacks from different systems seen by a growing martensite
f_over_t_tr f_over_t_tr
real(pReal) :: & real(pREAL) :: &
mu mu
@ -752,16 +752,16 @@ module subroutine dislotwin_dependentState(ph,en)
inv_lambda_sl = sqrt(matmul(prm%forestProjection,stt%rho_mob(:,en)+stt%rho_dip(:,en)))/prm%i_sl inv_lambda_sl = sqrt(matmul(prm%forestProjection,stt%rho_mob(:,en)+stt%rho_dip(:,en)))/prm%i_sl
if (prm%sum_N_tw > 0 .and. prm%sum_N_sl > 0) & if (prm%sum_N_tw > 0 .and. prm%sum_N_sl > 0) &
inv_lambda_sl = inv_lambda_sl + matmul(prm%h_sl_tw,f_over_t_tw)/(1.0_pReal-sumf_tw) inv_lambda_sl = inv_lambda_sl + matmul(prm%h_sl_tw,f_over_t_tw)/(1.0_pREAL-sumf_tw)
if (prm%sum_N_tr > 0 .and. prm%sum_N_sl > 0) & if (prm%sum_N_tr > 0 .and. prm%sum_N_sl > 0) &
inv_lambda_sl = inv_lambda_sl + matmul(prm%h_sl_tr,f_over_t_tr)/(1.0_pReal-sumf_tr) inv_lambda_sl = inv_lambda_sl + matmul(prm%h_sl_tr,f_over_t_tr)/(1.0_pREAL-sumf_tr)
dst%Lambda_sl(:,en) = prm%D / (1.0_pReal+prm%D*inv_lambda_sl) dst%Lambda_sl(:,en) = prm%D / (1.0_pREAL+prm%D*inv_lambda_sl)
inv_lambda_tw_tw = matmul(prm%h_tw_tw,f_over_t_tw)/(1.0_pReal-sumf_tw) inv_lambda_tw_tw = matmul(prm%h_tw_tw,f_over_t_tw)/(1.0_pREAL-sumf_tw)
dst%Lambda_tw(:,en) = prm%i_tw*prm%D/(1.0_pReal+prm%D*inv_lambda_tw_tw) dst%Lambda_tw(:,en) = prm%i_tw*prm%D/(1.0_pREAL+prm%D*inv_lambda_tw_tw)
inv_lambda_tr_tr = matmul(prm%h_tr_tr,f_over_t_tr)/(1.0_pReal-sumf_tr) inv_lambda_tr_tr = matmul(prm%h_tr_tr,f_over_t_tr)/(1.0_pREAL-sumf_tr)
dst%Lambda_tr(:,en) = prm%i_tr*prm%D/(1.0_pReal+prm%D*inv_lambda_tr_tr) dst%Lambda_tr(:,en) = prm%i_tr*prm%D/(1.0_pREAL+prm%D*inv_lambda_tr_tr)
!* threshold stress for dislocation motion !* threshold stress for dislocation motion
dst%tau_pass(:,en) = mu*prm%b_sl* sqrt(matmul(prm%h_sl_sl,stt%rho_mob(:,en)+stt%rho_dip(:,en))) dst%tau_pass(:,en) = mu*prm%b_sl* sqrt(matmul(prm%h_sl_sl,stt%rho_mob(:,en)+stt%rho_dip(:,en)))
@ -834,22 +834,22 @@ end subroutine plastic_dislotwin_result
pure subroutine kinetics_sl(Mp,T,ph,en, & pure subroutine kinetics_sl(Mp,T,ph,en, &
dot_gamma_sl,ddot_gamma_dtau_sl,tau_sl) dot_gamma_sl,ddot_gamma_dtau_sl,tau_sl)
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress Mp !< Mandel stress
real(pReal), intent(in) :: & real(pREAL), intent(in) :: &
T !< temperature T !< temperature
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
real(pReal), dimension(param(ph)%sum_N_sl), intent(out) :: & real(pREAL), dimension(param(ph)%sum_N_sl), intent(out) :: &
dot_gamma_sl dot_gamma_sl
real(pReal), dimension(param(ph)%sum_N_sl), optional, intent(out) :: & real(pREAL), dimension(param(ph)%sum_N_sl), optional, intent(out) :: &
ddot_gamma_dtau_sl, & ddot_gamma_dtau_sl, &
tau_sl tau_sl
real(pReal), dimension(param(ph)%sum_N_sl) :: & real(pREAL), dimension(param(ph)%sum_N_sl) :: &
ddot_gamma_dtau ddot_gamma_dtau
real(pReal), dimension(param(ph)%sum_N_sl) :: & real(pREAL), dimension(param(ph)%sum_N_sl) :: &
tau, & tau, &
stressRatio, & stressRatio, &
StressRatio_p, & StressRatio_p, &
@ -873,23 +873,23 @@ pure subroutine kinetics_sl(Mp,T,ph,en, &
stressRatio = tau_eff/prm%tau_0 stressRatio = tau_eff/prm%tau_0
StressRatio_p = stressRatio** prm%p StressRatio_p = stressRatio** prm%p
Q_kB_T = prm%Q_sl/(K_B*T) Q_kB_T = prm%Q_sl/(K_B*T)
v_wait_inverse = exp(Q_kB_T*(1.0_pReal-StressRatio_p)** prm%q) & v_wait_inverse = exp(Q_kB_T*(1.0_pREAL-StressRatio_p)** prm%q) &
/ prm%v_0 / prm%v_0
v_run_inverse = prm%B/(tau_eff*prm%b_sl) v_run_inverse = prm%B/(tau_eff*prm%b_sl)
dot_gamma_sl = sign(stt%rho_mob(:,en)*prm%b_sl/(v_wait_inverse+v_run_inverse),tau) dot_gamma_sl = sign(stt%rho_mob(:,en)*prm%b_sl/(v_wait_inverse+v_run_inverse),tau)
dV_wait_inverse_dTau = -1.0_pReal * v_wait_inverse * prm%p * prm%q * Q_kB_T & dV_wait_inverse_dTau = -1.0_pREAL * v_wait_inverse * prm%p * prm%q * Q_kB_T &
* (stressRatio**(prm%p-1.0_pReal)) & * (stressRatio**(prm%p-1.0_pREAL)) &
* (1.0_pReal-StressRatio_p)**(prm%q-1.0_pReal) & * (1.0_pREAL-StressRatio_p)**(prm%q-1.0_pREAL) &
/ prm%tau_0 / prm%tau_0
dV_run_inverse_dTau = -1.0_pReal * v_run_inverse/tau_eff dV_run_inverse_dTau = -1.0_pREAL * v_run_inverse/tau_eff
dV_dTau = -1.0_pReal * (dV_wait_inverse_dTau+dV_run_inverse_dTau) & dV_dTau = -1.0_pREAL * (dV_wait_inverse_dTau+dV_run_inverse_dTau) &
/ (v_wait_inverse+v_run_inverse)**2 / (v_wait_inverse+v_run_inverse)**2
ddot_gamma_dtau = dV_dTau*stt%rho_mob(:,en)*prm%b_sl ddot_gamma_dtau = dV_dTau*stt%rho_mob(:,en)*prm%b_sl
else where significantStress else where significantStress
dot_gamma_sl = 0.0_pReal dot_gamma_sl = 0.0_pREAL
ddot_gamma_dtau = 0.0_pReal ddot_gamma_dtau = 0.0_pREAL
end where significantStress end where significantStress
end associate end associate
@ -910,21 +910,21 @@ end subroutine kinetics_sl
pure subroutine kinetics_tw(Mp,T,abs_dot_gamma_sl,ph,en,& pure subroutine kinetics_tw(Mp,T,abs_dot_gamma_sl,ph,en,&
dot_gamma_tw,ddot_gamma_dtau_tw) dot_gamma_tw,ddot_gamma_dtau_tw)
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress Mp !< Mandel stress
real(pReal), intent(in) :: & real(pREAL), intent(in) :: &
T !< temperature T !< temperature
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
real(pReal), dimension(param(ph)%sum_N_sl), intent(in) :: & real(pREAL), dimension(param(ph)%sum_N_sl), intent(in) :: &
abs_dot_gamma_sl abs_dot_gamma_sl
real(pReal), dimension(param(ph)%sum_N_tw), intent(out) :: & real(pREAL), dimension(param(ph)%sum_N_tw), intent(out) :: &
dot_gamma_tw dot_gamma_tw
real(pReal), dimension(param(ph)%sum_N_tw), optional, intent(out) :: & real(pREAL), dimension(param(ph)%sum_N_tw), optional, intent(out) :: &
ddot_gamma_dtau_tw ddot_gamma_dtau_tw
real(pReal) :: & real(pREAL) :: &
tau, tau_r, tau_hat, & tau, tau_r, tau_hat, &
dot_N_0, & dot_N_0, &
x0, V, & x0, V, &
@ -943,10 +943,10 @@ pure subroutine kinetics_tw(Mp,T,abs_dot_gamma_sl,ph,en,&
nu = elastic_nu(ph,en,prm%isotropic_bound) nu = elastic_nu(ph,en,prm%isotropic_bound)
Gamma_sf = prm%Gamma_sf%at(T) Gamma_sf = prm%Gamma_sf%at(T)
tau_hat = 3.0_pReal*prm%b_tw(1)*mu/prm%L_tw & tau_hat = 3.0_pREAL*prm%b_tw(1)*mu/prm%L_tw &
+ Gamma_sf/(3.0_pReal*prm%b_tw(1)) + Gamma_sf/(3.0_pREAL*prm%b_tw(1))
x0 = mu*prm%b_sl(1)**2*(2.0_pReal+nu)/(Gamma_sf*8.0_pReal*PI*(1.0_pReal-nu)) x0 = mu*prm%b_sl(1)**2*(2.0_pREAL+nu)/(Gamma_sf*8.0_pREAL*PI*(1.0_pREAL-nu))
tau_r = mu*prm%b_sl(1)/(2.0_pReal*PI)*(1.0_pReal/(x0+prm%x_c)+cos(PI/3.0_pReal)/x0) tau_r = mu*prm%b_sl(1)/(2.0_pREAL*PI)*(1.0_pREAL/(x0+prm%x_c)+cos(PI/3.0_pREAL)/x0)
do i = 1, prm%sum_N_tw do i = 1, prm%sum_N_tw
tau = math_tensordot(Mp,prm%P_tw(1:3,1:3,i)) tau = math_tensordot(Mp,prm%P_tw(1:3,1:3,i))
@ -956,18 +956,18 @@ pure subroutine kinetics_tw(Mp,T,abs_dot_gamma_sl,ph,en,&
dP_dTau = prm%r(i) * (tau_hat/tau)**prm%r(i)/tau * P dP_dTau = prm%r(i) * (tau_hat/tau)**prm%r(i)/tau * P
s = prm%fcc_twinNucleationSlipPair(1:2,i) s = prm%fcc_twinNucleationSlipPair(1:2,i)
dot_N_0 = sum(abs_dot_gamma_sl(s(2:1:-1))*(stt%rho_mob(s,en)+stt%rho_dip(s,en)))/(prm%L_tw*3.0_pReal) dot_N_0 = sum(abs_dot_gamma_sl(s(2:1:-1))*(stt%rho_mob(s,en)+stt%rho_dip(s,en)))/(prm%L_tw*3.0_pREAL)
P_ncs = 1.0_pReal-exp(-prm%V_cs/(K_B*T)*(tau_r-tau)) P_ncs = 1.0_pREAL-exp(-prm%V_cs/(K_B*T)*(tau_r-tau))
dP_ncs_dtau = prm%V_cs / (K_B * T) * (P_ncs - 1.0_pReal) dP_ncs_dtau = prm%V_cs / (K_B * T) * (P_ncs - 1.0_pREAL)
V = PI/4.0_pReal*dst%Lambda_tw(i,en)**2*prm%t_tw(i) V = PI/4.0_pREAL*dst%Lambda_tw(i,en)**2*prm%t_tw(i)
dot_gamma_tw(i) = V*dot_N_0*P_ncs*P*prm%gamma_char_tw(i) dot_gamma_tw(i) = V*dot_N_0*P_ncs*P*prm%gamma_char_tw(i)
if (present(ddot_gamma_dtau_tw)) & if (present(ddot_gamma_dtau_tw)) &
ddot_gamma_dtau_tw(i) = V*dot_N_0*(P*dP_ncs_dtau + P_ncs*dP_dtau)*prm%gamma_char_tw(i) ddot_gamma_dtau_tw(i) = V*dot_N_0*(P*dP_ncs_dtau + P_ncs*dP_dtau)*prm%gamma_char_tw(i)
else else
dot_gamma_tw(i) = 0.0_pReal dot_gamma_tw(i) = 0.0_pREAL
if (present(ddot_gamma_dtau_tw)) ddot_gamma_dtau_tw(i) = 0.0_pReal if (present(ddot_gamma_dtau_tw)) ddot_gamma_dtau_tw(i) = 0.0_pREAL
end if end if
end do end do
@ -986,21 +986,21 @@ end subroutine kinetics_tw
pure subroutine kinetics_tr(Mp,T,abs_dot_gamma_sl,ph,en,& pure subroutine kinetics_tr(Mp,T,abs_dot_gamma_sl,ph,en,&
dot_gamma_tr,ddot_gamma_dtau_tr) dot_gamma_tr,ddot_gamma_dtau_tr)
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress Mp !< Mandel stress
real(pReal), intent(in) :: & real(pREAL), intent(in) :: &
T !< temperature T !< temperature
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
real(pReal), dimension(param(ph)%sum_N_sl), intent(in) :: & real(pREAL), dimension(param(ph)%sum_N_sl), intent(in) :: &
abs_dot_gamma_sl abs_dot_gamma_sl
real(pReal), dimension(param(ph)%sum_N_tr), intent(out) :: & real(pREAL), dimension(param(ph)%sum_N_tr), intent(out) :: &
dot_gamma_tr dot_gamma_tr
real(pReal), dimension(param(ph)%sum_N_tr), optional, intent(out) :: & real(pREAL), dimension(param(ph)%sum_N_tr), optional, intent(out) :: &
ddot_gamma_dtau_tr ddot_gamma_dtau_tr
real(pReal) :: & real(pREAL) :: &
tau, tau_r, tau_hat, & tau, tau_r, tau_hat, &
dot_N_0, & dot_N_0, &
x0, V, & x0, V, &
@ -1019,10 +1019,10 @@ pure subroutine kinetics_tr(Mp,T,abs_dot_gamma_sl,ph,en,&
nu = elastic_nu(ph,en,prm%isotropic_bound) nu = elastic_nu(ph,en,prm%isotropic_bound)
Gamma_sf = prm%Gamma_sf%at(T) Gamma_sf = prm%Gamma_sf%at(T)
tau_hat = 3.0_pReal*prm%b_tr(1)*mu/prm%L_tr & tau_hat = 3.0_pREAL*prm%b_tr(1)*mu/prm%L_tr &
+ (Gamma_sf + (prm%h/prm%V_mol - 2.0_pReal*prm%rho)*prm%Delta_G%at(T))/(3.0_pReal*prm%b_tr(1)) + (Gamma_sf + (prm%h/prm%V_mol - 2.0_pREAL*prm%rho)*prm%Delta_G%at(T))/(3.0_pREAL*prm%b_tr(1))
x0 = mu*prm%b_sl(1)**2*(2.0_pReal+nu)/(Gamma_sf*8.0_pReal*PI*(1.0_pReal-nu)) x0 = mu*prm%b_sl(1)**2*(2.0_pREAL+nu)/(Gamma_sf*8.0_pREAL*PI*(1.0_pREAL-nu))
tau_r = mu*prm%b_sl(1)/(2.0_pReal*PI)*(1.0_pReal/(x0+prm%x_c)+cos(PI/3.0_pReal)/x0) tau_r = mu*prm%b_sl(1)/(2.0_pREAL*PI)*(1.0_pREAL/(x0+prm%x_c)+cos(PI/3.0_pREAL)/x0)
do i = 1, prm%sum_N_tr do i = 1, prm%sum_N_tr
tau = math_tensordot(Mp,prm%P_tr(1:3,1:3,i)) tau = math_tensordot(Mp,prm%P_tr(1:3,1:3,i))
@ -1032,18 +1032,18 @@ pure subroutine kinetics_tr(Mp,T,abs_dot_gamma_sl,ph,en,&
dP_dTau = prm%s(i) * (tau_hat/tau)**prm%s(i)/tau * P dP_dTau = prm%s(i) * (tau_hat/tau)**prm%s(i)/tau * P
s = prm%fcc_twinNucleationSlipPair(1:2,i) s = prm%fcc_twinNucleationSlipPair(1:2,i)
dot_N_0 = sum(abs_dot_gamma_sl(s(2:1:-1))*(stt%rho_mob(s,en)+stt%rho_dip(s,en)))/(prm%L_tr*3.0_pReal) dot_N_0 = sum(abs_dot_gamma_sl(s(2:1:-1))*(stt%rho_mob(s,en)+stt%rho_dip(s,en)))/(prm%L_tr*3.0_pREAL)
P_ncs = 1.0_pReal-exp(-prm%V_cs/(K_B*T)*(tau_r-tau)) P_ncs = 1.0_pREAL-exp(-prm%V_cs/(K_B*T)*(tau_r-tau))
dP_ncs_dtau = prm%V_cs / (K_B * T) * (P_ncs - 1.0_pReal) dP_ncs_dtau = prm%V_cs / (K_B * T) * (P_ncs - 1.0_pREAL)
V = PI/4.0_pReal*dst%Lambda_tr(i,en)**2*prm%t_tr(i) V = PI/4.0_pREAL*dst%Lambda_tr(i,en)**2*prm%t_tr(i)
dot_gamma_tr(i) = V*dot_N_0*P_ncs*P*gamma_char_tr dot_gamma_tr(i) = V*dot_N_0*P_ncs*P*gamma_char_tr
if (present(ddot_gamma_dtau_tr)) & if (present(ddot_gamma_dtau_tr)) &
ddot_gamma_dtau_tr(i) = V*dot_N_0*(P*dP_ncs_dtau + P_ncs*dP_dtau)*gamma_char_tr ddot_gamma_dtau_tr(i) = V*dot_N_0*(P*dP_ncs_dtau + P_ncs*dP_dtau)*gamma_char_tr
else else
dot_gamma_tr(i) = 0.0_pReal dot_gamma_tr(i) = 0.0_pREAL
if (present(ddot_gamma_dtau_tr)) ddot_gamma_dtau_tr(i) = 0.0_pReal if (present(ddot_gamma_dtau_tr)) ddot_gamma_dtau_tr(i) = 0.0_pREAL
end if end if
end do end do

92
src/phase_mechanical_plastic_isotropic.f90
View File

@ -10,7 +10,7 @@
submodule(phase:plastic) isotropic submodule(phase:plastic) isotropic
type :: tParameters type :: tParameters
real(pReal) :: & real(pREAL) :: &
M, & !< Taylor factor M, & !< Taylor factor
dot_gamma_0, & !< reference strain rate dot_gamma_0, & !< reference strain rate
n, & !< stress exponent n, & !< stress exponent
@ -30,7 +30,7 @@ submodule(phase:plastic) isotropic
end type tParameters end type tParameters
type :: tIsotropicState type :: tIsotropicState
real(pReal), pointer, dimension(:) :: & real(pREAL), pointer, dimension(:) :: &
xi xi
end type tIsotropicState end type tIsotropicState
@ -52,7 +52,7 @@ module function plastic_isotropic_init() result(myPlasticity)
ph, & ph, &
Nmembers, & Nmembers, &
sizeState, sizeDotState sizeState, sizeDotState
real(pReal) :: & real(pREAL) :: &
xi_0 !< initial critical stress xi_0 !< initial critical stress
character(len=:), allocatable :: & character(len=:), allocatable :: &
refs, & refs, &
@ -103,24 +103,24 @@ module function plastic_isotropic_init() result(myPlasticity)
prm%dot_gamma_0 = pl%get_asReal('dot_gamma_0') prm%dot_gamma_0 = pl%get_asReal('dot_gamma_0')
prm%n = pl%get_asReal('n') prm%n = pl%get_asReal('n')
prm%h_0 = pl%get_asReal('h_0') prm%h_0 = pl%get_asReal('h_0')
prm%h = pl%get_asReal('h', defaultVal=3.0_pReal) ! match for fcc random polycrystal prm%h = pl%get_asReal('h', defaultVal=3.0_pREAL) ! match for fcc random polycrystal
prm%M = pl%get_asReal('M') prm%M = pl%get_asReal('M')
prm%h_ln = pl%get_asReal('h_ln', defaultVal=0.0_pReal) prm%h_ln = pl%get_asReal('h_ln', defaultVal=0.0_pREAL)
prm%c_1 = pl%get_asReal('c_1', defaultVal=0.0_pReal) prm%c_1 = pl%get_asReal('c_1', defaultVal=0.0_pREAL)
prm%c_4 = pl%get_asReal('c_4', defaultVal=0.0_pReal) prm%c_4 = pl%get_asReal('c_4', defaultVal=0.0_pREAL)
prm%c_3 = pl%get_asReal('c_3', defaultVal=0.0_pReal) prm%c_3 = pl%get_asReal('c_3', defaultVal=0.0_pREAL)
prm%c_2 = pl%get_asReal('c_2', defaultVal=0.0_pReal) prm%c_2 = pl%get_asReal('c_2', defaultVal=0.0_pREAL)
prm%a = pl%get_asReal('a') prm%a = pl%get_asReal('a')
prm%dilatation = pl%get_asBool('dilatation',defaultVal = .false.) prm%dilatation = pl%get_asBool('dilatation',defaultVal = .false.)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! sanity checks ! sanity checks
if (xi_0 < 0.0_pReal) extmsg = trim(extmsg)//' xi_0' if (xi_0 < 0.0_pREAL) extmsg = trim(extmsg)//' xi_0'
if (prm%dot_gamma_0 <= 0.0_pReal) extmsg = trim(extmsg)//' dot_gamma_0' if (prm%dot_gamma_0 <= 0.0_pREAL) extmsg = trim(extmsg)//' dot_gamma_0'
if (prm%n <= 0.0_pReal) extmsg = trim(extmsg)//' n' if (prm%n <= 0.0_pREAL) extmsg = trim(extmsg)//' n'
if (prm%a <= 0.0_pReal) extmsg = trim(extmsg)//' a' if (prm%a <= 0.0_pREAL) extmsg = trim(extmsg)//' a'
if (prm%M <= 0.0_pReal) extmsg = trim(extmsg)//' M' if (prm%M <= 0.0_pREAL) extmsg = trim(extmsg)//' M'
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! allocate state arrays ! allocate state arrays
@ -135,8 +135,8 @@ module function plastic_isotropic_init() result(myPlasticity)
! state aliases and initialization ! state aliases and initialization
stt%xi => plasticState(ph)%state(1,:) stt%xi => plasticState(ph)%state(1,:)
stt%xi = xi_0 stt%xi = xi_0
plasticState(ph)%atol(1) = pl%get_asReal('atol_xi',defaultVal=1.0_pReal) plasticState(ph)%atol(1) = pl%get_asReal('atol_xi',defaultVal=1.0_pREAL)
if (plasticState(ph)%atol(1) < 0.0_pReal) extmsg = trim(extmsg)//' atol_xi' if (plasticState(ph)%atol(1) < 0.0_pREAL) extmsg = trim(extmsg)//' atol_xi'
end associate end associate
@ -154,20 +154,20 @@ end function plastic_isotropic_init
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
module subroutine isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en) module subroutine isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en)
real(pReal), dimension(3,3), intent(out) :: & real(pREAL), dimension(3,3), intent(out) :: &
Lp !< plastic velocity gradient Lp !< plastic velocity gradient
real(pReal), dimension(3,3,3,3), intent(out) :: & real(pREAL), dimension(3,3,3,3), intent(out) :: &
dLp_dMp !< derivative of Lp with respect to the Mandel stress dLp_dMp !< derivative of Lp with respect to the Mandel stress
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress Mp !< Mandel stress
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
real(pReal), dimension(3,3) :: & real(pREAL), dimension(3,3) :: &
Mp_dev !< deviatoric part of the Mandel stress Mp_dev !< deviatoric part of the Mandel stress
real(pReal) :: & real(pREAL) :: &
dot_gamma, & !< strainrate dot_gamma, & !< strainrate
norm_Mp_dev, & !< norm of the deviatoric part of the Mandel stress norm_Mp_dev, & !< norm of the deviatoric part of the Mandel stress
squarenorm_Mp_dev !< square of the norm of the deviatoric part of the Mandel stress squarenorm_Mp_dev !< square of the norm of the deviatoric part of the Mandel stress
@ -181,20 +181,20 @@ module subroutine isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en)
squarenorm_Mp_dev = math_tensordot(Mp_dev,Mp_dev) squarenorm_Mp_dev = math_tensordot(Mp_dev,Mp_dev)
norm_Mp_dev = sqrt(squarenorm_Mp_dev) norm_Mp_dev = sqrt(squarenorm_Mp_dev)
if (norm_Mp_dev > 0.0_pReal) then if (norm_Mp_dev > 0.0_pREAL) then
dot_gamma = prm%dot_gamma_0 * (sqrt(1.5_pReal) * norm_Mp_dev/(prm%M*stt%xi(en)))**prm%n dot_gamma = prm%dot_gamma_0 * (sqrt(1.5_pREAL) * norm_Mp_dev/(prm%M*stt%xi(en)))**prm%n
Lp = dot_gamma * Mp_dev/norm_Mp_dev Lp = dot_gamma * Mp_dev/norm_Mp_dev
forall (k=1:3,l=1:3,m=1:3,n=1:3) & forall (k=1:3,l=1:3,m=1:3,n=1:3) &
dLp_dMp(k,l,m,n) = (prm%n-1.0_pReal) * Mp_dev(k,l)*Mp_dev(m,n) / squarenorm_Mp_dev dLp_dMp(k,l,m,n) = (prm%n-1.0_pREAL) * Mp_dev(k,l)*Mp_dev(m,n) / squarenorm_Mp_dev
forall (k=1:3,l=1:3) & forall (k=1:3,l=1:3) &
dLp_dMp(k,l,k,l) = dLp_dMp(k,l,k,l) + 1.0_pReal dLp_dMp(k,l,k,l) = dLp_dMp(k,l,k,l) + 1.0_pREAL
forall (k=1:3,m=1:3) & forall (k=1:3,m=1:3) &
dLp_dMp(k,k,m,m) = dLp_dMp(k,k,m,m) - 1.0_pReal/3.0_pReal dLp_dMp(k,k,m,m) = dLp_dMp(k,k,m,m) - 1.0_pREAL/3.0_pREAL
dLp_dMp = dot_gamma * dLp_dMp / norm_Mp_dev dLp_dMp = dot_gamma * dLp_dMp / norm_Mp_dev
else else
Lp = 0.0_pReal Lp = 0.0_pREAL
dLp_dMp = 0.0_pReal dLp_dMp = 0.0_pREAL
end if end if
end associate end associate
@ -207,18 +207,18 @@ end subroutine isotropic_LpAndItsTangent
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
module subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dMi,Mi,ph,en) module subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dMi,Mi,ph,en)
real(pReal), dimension(3,3), intent(out) :: & real(pREAL), dimension(3,3), intent(out) :: &
Li !< inleastic velocity gradient Li !< inleastic velocity gradient
real(pReal), dimension(3,3,3,3), intent(out) :: & real(pREAL), dimension(3,3,3,3), intent(out) :: &
dLi_dMi !< derivative of Li with respect to Mandel stress dLi_dMi !< derivative of Li with respect to Mandel stress
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mi !< Mandel stress Mi !< Mandel stress
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
real(pReal) :: & real(pREAL) :: &
tr !< trace of spherical part of Mandel stress (= 3 x pressure) tr !< trace of spherical part of Mandel stress (= 3 x pressure)
integer :: & integer :: &
k, l, m, n k, l, m, n
@ -228,14 +228,14 @@ module subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dMi,Mi,ph,en)
tr=math_trace33(math_spherical33(Mi)) tr=math_trace33(math_spherical33(Mi))
if (prm%dilatation .and. abs(tr) > 0.0_pReal) then ! no stress or J2 plasticity --> Li and its derivative are zero if (prm%dilatation .and. abs(tr) > 0.0_pREAL) then ! no stress or J2 plasticity --> Li and its derivative are zero
Li = math_I3 & Li = math_I3 &
* prm%dot_gamma_0 * (3.0_pReal*prm%M*stt%xi(en))**(-prm%n) & * prm%dot_gamma_0 * (3.0_pREAL*prm%M*stt%xi(en))**(-prm%n) &
* tr * abs(tr)**(prm%n-1.0_pReal) * tr * abs(tr)**(prm%n-1.0_pREAL)
forall (k=1:3,l=1:3,m=1:3,n=1:3) dLi_dMi(k,l,m,n) = prm%n / tr * Li(k,l) * math_I3(m,n) forall (k=1:3,l=1:3,m=1:3,n=1:3) dLi_dMi(k,l,m,n) = prm%n / tr * Li(k,l) * math_I3(m,n)
else else
Li = 0.0_pReal Li = 0.0_pREAL
dLi_dMi = 0.0_pReal dLi_dMi = 0.0_pREAL
end if end if
end associate end associate
@ -248,15 +248,15 @@ module subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dMi,Mi,ph,en)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
module function isotropic_dotState(Mp,ph,en) result(dotState) module function isotropic_dotState(Mp,ph,en) result(dotState)
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress Mp !< Mandel stress
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
real(pReal), dimension(plasticState(ph)%sizeDotState) :: & real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
dotState dotState
real(pReal) :: & real(pREAL) :: &
dot_gamma, & !< strainrate dot_gamma, & !< strainrate
xi_inf_star, & !< saturation xi xi_inf_star, & !< saturation xi
norm_Mp !< norm of the (deviatoric) Mandel stress norm_Mp !< norm of the (deviatoric) Mandel stress
@ -267,21 +267,21 @@ module function isotropic_dotState(Mp,ph,en) result(dotState)
sqrt(math_tensordot(math_deviatoric33(Mp),math_deviatoric33(Mp))), & sqrt(math_tensordot(math_deviatoric33(Mp),math_deviatoric33(Mp))), &
prm%dilatation) prm%dilatation)
dot_gamma = prm%dot_gamma_0 * (sqrt(1.5_pReal) * norm_Mp /(prm%M*stt%xi(en))) **prm%n dot_gamma = prm%dot_gamma_0 * (sqrt(1.5_pREAL) * norm_Mp /(prm%M*stt%xi(en))) **prm%n
if (dot_gamma > 1e-12_pReal) then if (dot_gamma > 1e-12_pREAL) then
if (dEq0(prm%c_1)) then if (dEq0(prm%c_1)) then
xi_inf_star = prm%xi_inf xi_inf_star = prm%xi_inf
else else
xi_inf_star = prm%xi_inf & xi_inf_star = prm%xi_inf &
+ asinh( (dot_gamma / prm%c_1)**(1.0_pReal / prm%c_2))**(1.0_pReal / prm%c_3) & + asinh( (dot_gamma / prm%c_1)**(1.0_pREAL / prm%c_2))**(1.0_pREAL / prm%c_3) &
/ prm%c_4 * (dot_gamma / prm%dot_gamma_0)**(1.0_pReal / prm%n) / prm%c_4 * (dot_gamma / prm%dot_gamma_0)**(1.0_pREAL / prm%n)
end if end if
dot_xi = dot_gamma & dot_xi = dot_gamma &
* ( prm%h_0 + prm%h_ln * log(dot_gamma) ) & * ( prm%h_0 + prm%h_ln * log(dot_gamma) ) &
* sign(abs(1.0_pReal - stt%xi(en)/xi_inf_star)**prm%a *prm%h, 1.0_pReal-stt%xi(en)/xi_inf_star) * sign(abs(1.0_pREAL - stt%xi(en)/xi_inf_star)**prm%a *prm%h, 1.0_pREAL-stt%xi(en)/xi_inf_star)
else else
dot_xi = 0.0_pReal dot_xi = 0.0_pREAL
end if end if
end associate end associate

98
src/phase_mechanical_plastic_kinehardening.f90
View File

@ -8,10 +8,10 @@
submodule(phase:plastic) kinehardening submodule(phase:plastic) kinehardening
type :: tParameters type :: tParameters
real(pReal) :: & real(pREAL) :: &
n = 1.0_pReal, & !< stress exponent for slip n = 1.0_pREAL, & !< stress exponent for slip
dot_gamma_0 = 1.0_pReal !< reference shear strain rate for slip dot_gamma_0 = 1.0_pREAL !< reference shear strain rate for slip
real(pReal), allocatable, dimension(:) :: & real(pREAL), allocatable, dimension(:) :: &
h_0_xi, & !< initial hardening rate of forest stress per slip family h_0_xi, & !< initial hardening rate of forest stress per slip family
!! θ_0,for !! θ_0,for
h_0_chi, & !< initial hardening rate of back stress per slip family h_0_chi, & !< initial hardening rate of back stress per slip family
@ -22,9 +22,9 @@ submodule(phase:plastic) kinehardening
!! θ_1,bs !! θ_1,bs
xi_inf, & !< back-extrapolated forest stress from terminal linear hardening xi_inf, & !< back-extrapolated forest stress from terminal linear hardening
chi_inf !< back-extrapolated back stress from terminal linear hardening chi_inf !< back-extrapolated back stress from terminal linear hardening
real(pReal), allocatable, dimension(:,:) :: & real(pREAL), allocatable, dimension(:,:) :: &
h_sl_sl !< slip resistance change per slip activity h_sl_sl !< slip resistance change per slip activity
real(pReal), allocatable, dimension(:,:,:) :: & real(pREAL), allocatable, dimension(:,:,:) :: &
P, & P, &
P_nS_pos, & P_nS_pos, &
P_nS_neg P_nS_neg
@ -46,7 +46,7 @@ submodule(phase:plastic) kinehardening
end type tIndexDotState end type tIndexDotState
type :: tKinehardeningState type :: tKinehardeningState
real(pReal), pointer, dimension(:,:) :: & real(pREAL), pointer, dimension(:,:) :: &
xi, & !< forest stress xi, & !< forest stress
!! τ_for !! τ_for
chi, & !< back stress chi, & !< back stress
@ -82,7 +82,7 @@ module function plastic_kinehardening_init() result(myPlasticity)
startIndex, endIndex startIndex, endIndex
integer, dimension(:), allocatable :: & integer, dimension(:), allocatable :: &
N_sl N_sl
real(pReal), dimension(:), allocatable :: & real(pREAL), dimension(:), allocatable :: &
xi_0, & !< initial forest stress xi_0, & !< initial forest stress
!! τ_for,0 !! τ_for,0
a !< non-Schmid coefficients a !< non-Schmid coefficients
@ -175,11 +175,11 @@ module function plastic_kinehardening_init() result(myPlasticity)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! sanity checks ! sanity checks
if ( prm%dot_gamma_0 <= 0.0_pReal) extmsg = trim(extmsg)//' dot_gamma_0' if ( prm%dot_gamma_0 <= 0.0_pREAL) extmsg = trim(extmsg)//' dot_gamma_0'
if ( prm%n <= 0.0_pReal) extmsg = trim(extmsg)//' n' if ( prm%n <= 0.0_pREAL) extmsg = trim(extmsg)//' n'
if (any(xi_0 <= 0.0_pReal)) extmsg = trim(extmsg)//' xi_0' if (any(xi_0 <= 0.0_pREAL)) extmsg = trim(extmsg)//' xi_0'
if (any(prm%xi_inf <= 0.0_pReal)) extmsg = trim(extmsg)//' xi_inf' if (any(prm%xi_inf <= 0.0_pREAL)) extmsg = trim(extmsg)//' xi_inf'
if (any(prm%chi_inf <= 0.0_pReal)) extmsg = trim(extmsg)//' chi_inf' if (any(prm%chi_inf <= 0.0_pREAL)) extmsg = trim(extmsg)//' chi_inf'
else slipActive else slipActive
xi_0 = emptyRealArray xi_0 = emptyRealArray
@ -208,21 +208,21 @@ module function plastic_kinehardening_init() result(myPlasticity)
idx_dot%xi = [startIndex,endIndex] idx_dot%xi = [startIndex,endIndex]
stt%xi => plasticState(ph)%state(startIndex:endIndex,:) stt%xi => plasticState(ph)%state(startIndex:endIndex,:)
stt%xi = spread(xi_0, 2, Nmembers) stt%xi = spread(xi_0, 2, Nmembers)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_xi',defaultVal=1.0_pReal) plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_xi',defaultVal=1.0_pREAL)
if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_xi' if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pREAL)) extmsg = trim(extmsg)//' atol_xi'
startIndex = endIndex + 1 startIndex = endIndex + 1
endIndex = endIndex + prm%sum_N_sl endIndex = endIndex + prm%sum_N_sl
idx_dot%chi = [startIndex,endIndex] idx_dot%chi = [startIndex,endIndex]
stt%chi => plasticState(ph)%state(startIndex:endIndex,:) stt%chi => plasticState(ph)%state(startIndex:endIndex,:)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_xi',defaultVal=1.0_pReal) plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_xi',defaultVal=1.0_pREAL)
startIndex = endIndex + 1 startIndex = endIndex + 1
endIndex = endIndex + prm%sum_N_sl endIndex = endIndex + prm%sum_N_sl
idx_dot%gamma = [startIndex,endIndex] idx_dot%gamma = [startIndex,endIndex]
stt%gamma => plasticState(ph)%state(startIndex:endIndex,:) stt%gamma => plasticState(ph)%state(startIndex:endIndex,:)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_gamma',defaultVal=1.0e-6_pReal) plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_gamma',defaultVal=1.0e-6_pREAL)
if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_gamma' if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pREAL)) extmsg = trim(extmsg)//' atol_gamma'
o = plasticState(ph)%offsetDeltaState o = plasticState(ph)%offsetDeltaState
startIndex = endIndex + 1 startIndex = endIndex + 1
@ -257,12 +257,12 @@ end function plastic_kinehardening_init
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure module subroutine kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en) pure module subroutine kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en)
real(pReal), dimension(3,3), intent(out) :: & real(pREAL), dimension(3,3), intent(out) :: &
Lp !< plastic velocity gradient Lp !< plastic velocity gradient
real(pReal), dimension(3,3,3,3), intent(out) :: & real(pREAL), dimension(3,3,3,3), intent(out) :: &
dLp_dMp !< derivative of Lp with respect to the Mandel stress dLp_dMp !< derivative of Lp with respect to the Mandel stress
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress Mp !< Mandel stress
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
@ -270,12 +270,12 @@ pure module subroutine kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en)
integer :: & integer :: &
i,k,l,m,n i,k,l,m,n
real(pReal), dimension(param(ph)%sum_N_sl) :: & real(pREAL), dimension(param(ph)%sum_N_sl) :: &
dot_gamma_pos,dot_gamma_neg, & dot_gamma_pos,dot_gamma_neg, &
ddot_gamma_dtau_pos,ddot_gamma_dtau_neg ddot_gamma_dtau_pos,ddot_gamma_dtau_neg
Lp = 0.0_pReal Lp = 0.0_pREAL
dLp_dMp = 0.0_pReal dLp_dMp = 0.0_pREAL
associate(prm => param(ph)) associate(prm => param(ph))
@ -299,17 +299,17 @@ end subroutine kinehardening_LpAndItsTangent
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
module function plastic_kinehardening_dotState(Mp,ph,en) result(dotState) module function plastic_kinehardening_dotState(Mp,ph,en) result(dotState)
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress Mp !< Mandel stress
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
real(pReal), dimension(plasticState(ph)%sizeDotState) :: & real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
dotState dotState
real(pReal) :: & real(pREAL) :: &
sumGamma sumGamma
real(pReal), dimension(param(ph)%sum_N_sl) :: & real(pREAL), dimension(param(ph)%sum_N_sl) :: &
dot_gamma_pos,dot_gamma_neg dot_gamma_pos,dot_gamma_neg
@ -326,14 +326,14 @@ module function plastic_kinehardening_dotState(Mp,ph,en) result(dotState)
dot_xi = matmul(prm%h_sl_sl,dot_gamma) & dot_xi = matmul(prm%h_sl_sl,dot_gamma) &
* ( prm%h_inf_xi & * ( prm%h_inf_xi &
+ ( prm%h_0_xi & + ( prm%h_0_xi &
- prm%h_inf_xi * (1_pReal -sumGamma*prm%h_0_xi/prm%xi_inf) ) & - prm%h_inf_xi * (1_pREAL -sumGamma*prm%h_0_xi/prm%xi_inf) ) &
* exp(-sumGamma*prm%h_0_xi/prm%xi_inf) & * exp(-sumGamma*prm%h_0_xi/prm%xi_inf) &
) )
dot_chi = stt%sgn_gamma(:,en)*dot_gamma & dot_chi = stt%sgn_gamma(:,en)*dot_gamma &
* ( prm%h_inf_chi & * ( prm%h_inf_chi &
+ ( prm%h_0_chi & + ( prm%h_0_chi &
- prm%h_inf_chi*(1_pReal -(stt%gamma(:,en)-stt%gamma_flip(:,en))*prm%h_0_chi/(prm%chi_inf+stt%chi_flip(:,en))) ) & - prm%h_inf_chi*(1_pREAL -(stt%gamma(:,en)-stt%gamma_flip(:,en))*prm%h_0_chi/(prm%chi_inf+stt%chi_flip(:,en))) ) &
* exp(-(stt%gamma(:,en)-stt%gamma_flip(:,en))*prm%h_0_chi/(prm%chi_inf+stt%chi_flip(:,en))) & * exp(-(stt%gamma(:,en)-stt%gamma_flip(:,en))*prm%h_0_chi/(prm%chi_inf+stt%chi_flip(:,en))) &
) )
@ -347,13 +347,13 @@ end function plastic_kinehardening_dotState
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
module subroutine plastic_kinehardening_deltaState(Mp,ph,en) module subroutine plastic_kinehardening_deltaState(Mp,ph,en)
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress Mp !< Mandel stress
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
real(pReal), dimension(param(ph)%sum_N_sl) :: & real(pREAL), dimension(param(ph)%sum_N_sl) :: &
dot_gamma_pos,dot_gamma_neg, & dot_gamma_pos,dot_gamma_neg, &
sgn_gamma sgn_gamma
@ -362,17 +362,17 @@ module subroutine plastic_kinehardening_deltaState(Mp,ph,en)
call kinetics(Mp,ph,en, dot_gamma_pos,dot_gamma_neg) call kinetics(Mp,ph,en, dot_gamma_pos,dot_gamma_neg)
sgn_gamma = merge(state(ph)%sgn_gamma(:,en), & sgn_gamma = merge(state(ph)%sgn_gamma(:,en), &
sign(1.0_pReal,dot_gamma_pos+dot_gamma_neg), & sign(1.0_pREAL,dot_gamma_pos+dot_gamma_neg), &
dEq0(dot_gamma_pos+dot_gamma_neg,1e-10_pReal)) dEq0(dot_gamma_pos+dot_gamma_neg,1e-10_pREAL))
where(dNeq(sgn_gamma,stt%sgn_gamma(:,en),0.1_pReal)) ! ToDo sgn_gamma*stt%sgn_gamma(:,en)<0 where(dNeq(sgn_gamma,stt%sgn_gamma(:,en),0.1_pREAL)) ! ToDo sgn_gamma*stt%sgn_gamma(:,en)<0
dlt%sgn_gamma (:,en) = sgn_gamma - stt%sgn_gamma (:,en) dlt%sgn_gamma (:,en) = sgn_gamma - stt%sgn_gamma (:,en)
dlt%chi_flip (:,en) = abs(stt%chi (:,en)) - stt%chi_flip (:,en) dlt%chi_flip (:,en) = abs(stt%chi (:,en)) - stt%chi_flip (:,en)
dlt%gamma_flip(:,en) = stt%gamma(:,en) - stt%gamma_flip(:,en) dlt%gamma_flip(:,en) = stt%gamma(:,en) - stt%gamma_flip(:,en)
else where else where
dlt%sgn_gamma (:,en) = 0.0_pReal dlt%sgn_gamma (:,en) = 0.0_pREAL
dlt%chi_flip (:,en) = 0.0_pReal dlt%chi_flip (:,en) = 0.0_pREAL
dlt%gamma_flip(:,en) = 0.0_pReal dlt%gamma_flip(:,en) = 0.0_pREAL
end where end where
end associate end associate
@ -434,20 +434,20 @@ end subroutine plastic_kinehardening_result
pure subroutine kinetics(Mp,ph,en, & pure subroutine kinetics(Mp,ph,en, &
dot_gamma_pos,dot_gamma_neg,ddot_gamma_dtau_pos,ddot_gamma_dtau_neg) dot_gamma_pos,dot_gamma_neg,ddot_gamma_dtau_pos,ddot_gamma_dtau_neg)
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress Mp !< Mandel stress
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
real(pReal), intent(out), dimension(param(ph)%sum_N_sl) :: & real(pREAL), intent(out), dimension(param(ph)%sum_N_sl) :: &
dot_gamma_pos, & dot_gamma_pos, &
dot_gamma_neg dot_gamma_neg
real(pReal), intent(out), dimension(param(ph)%sum_N_sl), optional :: & real(pREAL), intent(out), dimension(param(ph)%sum_N_sl), optional :: &
ddot_gamma_dtau_pos, & ddot_gamma_dtau_pos, &
ddot_gamma_dtau_neg ddot_gamma_dtau_neg
real(pReal), dimension(param(ph)%sum_N_sl) :: & real(pREAL), dimension(param(ph)%sum_N_sl) :: &
tau_pos, & tau_pos, &
tau_neg tau_neg
integer :: i integer :: i
@ -458,35 +458,35 @@ pure subroutine kinetics(Mp,ph,en, &
do i = 1, prm%sum_N_sl do i = 1, prm%sum_N_sl
tau_pos(i) = math_tensordot(Mp,prm%P_nS_pos(1:3,1:3,i)) - stt%chi(i,en) tau_pos(i) = math_tensordot(Mp,prm%P_nS_pos(1:3,1:3,i)) - stt%chi(i,en)
tau_neg(i) = merge(math_tensordot(Mp,prm%P_nS_neg(1:3,1:3,i)) - stt%chi(i,en), & tau_neg(i) = merge(math_tensordot(Mp,prm%P_nS_neg(1:3,1:3,i)) - stt%chi(i,en), &
0.0_pReal, prm%nonSchmidActive) 0.0_pREAL, prm%nonSchmidActive)
end do end do
where(dNeq0(tau_pos)) where(dNeq0(tau_pos))
dot_gamma_pos = prm%dot_gamma_0 * merge(0.5_pReal,1.0_pReal, prm%nonSchmidActive) & ! 1/2 if non-Schmid active dot_gamma_pos = prm%dot_gamma_0 * merge(0.5_pREAL,1.0_pREAL, prm%nonSchmidActive) & ! 1/2 if non-Schmid active
* sign(abs(tau_pos/stt%xi(:,en))**prm%n, tau_pos) * sign(abs(tau_pos/stt%xi(:,en))**prm%n, tau_pos)
else where else where
dot_gamma_pos = 0.0_pReal dot_gamma_pos = 0.0_pREAL
end where end where
where(dNeq0(tau_neg)) where(dNeq0(tau_neg))
dot_gamma_neg = prm%dot_gamma_0 * 0.5_pReal & ! only used if non-Schmid active, always 1/2 dot_gamma_neg = prm%dot_gamma_0 * 0.5_pREAL & ! only used if non-Schmid active, always 1/2
* sign(abs(tau_neg/stt%xi(:,en))**prm%n, tau_neg) * sign(abs(tau_neg/stt%xi(:,en))**prm%n, tau_neg)
else where else where
dot_gamma_neg = 0.0_pReal dot_gamma_neg = 0.0_pREAL
end where end where
if (present(ddot_gamma_dtau_pos)) then if (present(ddot_gamma_dtau_pos)) then
where(dNeq0(dot_gamma_pos)) where(dNeq0(dot_gamma_pos))
ddot_gamma_dtau_pos = dot_gamma_pos*prm%n/tau_pos ddot_gamma_dtau_pos = dot_gamma_pos*prm%n/tau_pos
else where else where
ddot_gamma_dtau_pos = 0.0_pReal ddot_gamma_dtau_pos = 0.0_pREAL
end where end where
end if end if
if (present(ddot_gamma_dtau_neg)) then if (present(ddot_gamma_dtau_neg)) then
where(dNeq0(dot_gamma_neg)) where(dNeq0(dot_gamma_neg))
ddot_gamma_dtau_neg = dot_gamma_neg*prm%n/tau_neg ddot_gamma_dtau_neg = dot_gamma_neg*prm%n/tau_neg
else where else where
ddot_gamma_dtau_neg = 0.0_pReal ddot_gamma_dtau_neg = 0.0_pREAL
end where end where
end if end if

466
src/phase_mechanical_plastic_nonlocal.f90
View File

File diff suppressed because it is too large Load Diff

142
src/phase_mechanical_plastic_phenopowerlaw.f90
View File

@ -7,30 +7,30 @@
submodule(phase:plastic) phenopowerlaw submodule(phase:plastic) phenopowerlaw
type :: tParameters type :: tParameters
real(pReal) :: & real(pREAL) :: &
dot_gamma_0_sl = 1.0_pReal, & !< reference shear strain rate for slip dot_gamma_0_sl = 1.0_pREAL, & !< reference shear strain rate for slip
dot_gamma_0_tw = 1.0_pReal, & !< reference shear strain rate for twin dot_gamma_0_tw = 1.0_pREAL, & !< reference shear strain rate for twin
n_sl = 1.0_pReal, & !< stress exponent for slip n_sl = 1.0_pREAL, & !< stress exponent for slip
n_tw = 1.0_pReal, & !< stress exponent for twin n_tw = 1.0_pREAL, & !< stress exponent for twin
f_sat_sl_tw = 1.0_pReal, & !< push-up factor for slip saturation due to twinning f_sat_sl_tw = 1.0_pREAL, & !< push-up factor for slip saturation due to twinning
c_1 = 1.0_pReal, & c_1 = 1.0_pREAL, &
c_2 = 1.0_pReal, & c_2 = 1.0_pREAL, &
c_3 = 1.0_pReal, & c_3 = 1.0_pREAL, &
c_4 = 1.0_pReal, & c_4 = 1.0_pREAL, &
h_0_sl_sl = 1.0_pReal, & !< reference hardening slip - slip h_0_sl_sl = 1.0_pREAL, & !< reference hardening slip - slip
h_0_tw_sl = 1.0_pReal, & !< reference hardening twin - slip h_0_tw_sl = 1.0_pREAL, & !< reference hardening twin - slip
h_0_tw_tw = 1.0_pReal, & !< reference hardening twin - twin h_0_tw_tw = 1.0_pREAL, & !< reference hardening twin - twin
a_sl = 1.0_pReal a_sl = 1.0_pREAL
real(pReal), allocatable, dimension(:) :: & real(pREAL), allocatable, dimension(:) :: &
xi_inf_sl, & !< maximum critical shear stress for slip xi_inf_sl, & !< maximum critical shear stress for slip
h_int, & !< per family hardening activity (optional) h_int, & !< per family hardening activity (optional)
gamma_char !< characteristic shear for twins gamma_char !< characteristic shear for twins
real(pReal), allocatable, dimension(:,:) :: & real(pREAL), allocatable, dimension(:,:) :: &
h_sl_sl, & !< slip resistance from slip activity h_sl_sl, & !< slip resistance from slip activity
h_sl_tw, & !< slip resistance from twin activity h_sl_tw, & !< slip resistance from twin activity
h_tw_sl, & !< twin resistance from slip activity h_tw_sl, & !< twin resistance from slip activity
h_tw_tw !< twin resistance from twin activity h_tw_tw !< twin resistance from twin activity
real(pReal), allocatable, dimension(:,:,:) :: & real(pREAL), allocatable, dimension(:,:,:) :: &
P_sl, & P_sl, &
P_tw, & P_tw, &
P_nS_pos, & P_nS_pos, &
@ -56,7 +56,7 @@ submodule(phase:plastic) phenopowerlaw
end type tIndexDotState end type tIndexDotState
type :: tPhenopowerlawState type :: tPhenopowerlawState
real(pReal), pointer, dimension(:,:) :: & real(pREAL), pointer, dimension(:,:) :: &
xi_sl, & xi_sl, &
xi_tw, & xi_tw, &
gamma_sl, & gamma_sl, &
@ -87,7 +87,7 @@ module function plastic_phenopowerlaw_init() result(myPlasticity)
integer, dimension(:), allocatable :: & integer, dimension(:), allocatable :: &
N_sl, & !< number of slip-systems for a given slip family N_sl, & !< number of slip-systems for a given slip family
N_tw !< number of twin-systems for a given twin family N_tw !< number of twin-systems for a given twin family
real(pReal), dimension(:), allocatable :: & real(pREAL), dimension(:), allocatable :: &
xi_0_sl, & !< initial critical shear stress for slip xi_0_sl, & !< initial critical shear stress for slip
xi_0_tw, & !< initial critical shear stress for twin xi_0_tw, & !< initial critical shear stress for twin
a !< non-Schmid coefficients a !< non-Schmid coefficients
@ -156,7 +156,7 @@ module function plastic_phenopowerlaw_init() result(myPlasticity)
xi_0_sl = pl%get_as1dReal('xi_0_sl', requiredSize=size(N_sl)) xi_0_sl = pl%get_as1dReal('xi_0_sl', requiredSize=size(N_sl))
prm%xi_inf_sl = pl%get_as1dReal('xi_inf_sl', requiredSize=size(N_sl)) prm%xi_inf_sl = pl%get_as1dReal('xi_inf_sl', requiredSize=size(N_sl))
prm%h_int = pl%get_as1dReal('h_int', requiredSize=size(N_sl), & prm%h_int = pl%get_as1dReal('h_int', requiredSize=size(N_sl), &
defaultVal=[(0.0_pReal,i=1,size(N_sl))]) defaultVal=[(0.0_pREAL,i=1,size(N_sl))])
prm%dot_gamma_0_sl = pl%get_asReal('dot_gamma_0_sl') prm%dot_gamma_0_sl = pl%get_asReal('dot_gamma_0_sl')
prm%n_sl = pl%get_asReal('n_sl') prm%n_sl = pl%get_asReal('n_sl')
@ -169,11 +169,11 @@ module function plastic_phenopowerlaw_init() result(myPlasticity)
prm%h_int = math_expand(prm%h_int, N_sl) prm%h_int = math_expand(prm%h_int, N_sl)
! sanity checks ! sanity checks
if ( prm%dot_gamma_0_sl <= 0.0_pReal) extmsg = trim(extmsg)//' dot_gamma_0_sl' if ( prm%dot_gamma_0_sl <= 0.0_pREAL) extmsg = trim(extmsg)//' dot_gamma_0_sl'
if ( prm%a_sl <= 0.0_pReal) extmsg = trim(extmsg)//' a_sl' if ( prm%a_sl <= 0.0_pREAL) extmsg = trim(extmsg)//' a_sl'
if ( prm%n_sl <= 0.0_pReal) extmsg = trim(extmsg)//' n_sl' if ( prm%n_sl <= 0.0_pREAL) extmsg = trim(extmsg)//' n_sl'
if (any(xi_0_sl <= 0.0_pReal)) extmsg = trim(extmsg)//' xi_0_sl' if (any(xi_0_sl <= 0.0_pREAL)) extmsg = trim(extmsg)//' xi_0_sl'
if (any(prm%xi_inf_sl <= 0.0_pReal)) extmsg = trim(extmsg)//' xi_inf_sl' if (any(prm%xi_inf_sl <= 0.0_pREAL)) extmsg = trim(extmsg)//' xi_inf_sl'
else slipActive else slipActive
xi_0_sl = emptyRealArray xi_0_sl = emptyRealArray
@ -193,10 +193,10 @@ module function plastic_phenopowerlaw_init() result(myPlasticity)
xi_0_tw = pl%get_as1dReal('xi_0_tw',requiredSize=size(N_tw)) xi_0_tw = pl%get_as1dReal('xi_0_tw',requiredSize=size(N_tw))
prm%c_1 = pl%get_asReal('c_1',defaultVal=0.0_pReal) prm%c_1 = pl%get_asReal('c_1',defaultVal=0.0_pREAL)
prm%c_2 = pl%get_asReal('c_2',defaultVal=1.0_pReal) prm%c_2 = pl%get_asReal('c_2',defaultVal=1.0_pREAL)
prm%c_3 = pl%get_asReal('c_3',defaultVal=0.0_pReal) prm%c_3 = pl%get_asReal('c_3',defaultVal=0.0_pREAL)
prm%c_4 = pl%get_asReal('c_4',defaultVal=0.0_pReal) prm%c_4 = pl%get_asReal('c_4',defaultVal=0.0_pREAL)
prm%dot_gamma_0_tw = pl%get_asReal('dot_gamma_0_tw') prm%dot_gamma_0_tw = pl%get_asReal('dot_gamma_0_tw')
prm%n_tw = pl%get_asReal('n_tw') prm%n_tw = pl%get_asReal('n_tw')
prm%f_sat_sl_tw = pl%get_asReal('f_sat_sl-tw') prm%f_sat_sl_tw = pl%get_asReal('f_sat_sl-tw')
@ -206,8 +206,8 @@ module function plastic_phenopowerlaw_init() result(myPlasticity)
xi_0_tw = math_expand(xi_0_tw,N_tw) xi_0_tw = math_expand(xi_0_tw,N_tw)
! sanity checks ! sanity checks
if (prm%dot_gamma_0_tw <= 0.0_pReal) extmsg = trim(extmsg)//' dot_gamma_0_tw' if (prm%dot_gamma_0_tw <= 0.0_pREAL) extmsg = trim(extmsg)//' dot_gamma_0_tw'
if (prm%n_tw <= 0.0_pReal) extmsg = trim(extmsg)//' n_tw' if (prm%n_tw <= 0.0_pREAL) extmsg = trim(extmsg)//' n_tw'
else twinActive else twinActive
xi_0_tw = emptyRealArray xi_0_tw = emptyRealArray
@ -226,7 +226,7 @@ module function plastic_phenopowerlaw_init() result(myPlasticity)
else slipAndTwinActive else slipAndTwinActive
allocate(prm%h_sl_tw(prm%sum_N_sl,prm%sum_N_tw)) ! at least one dimension is 0 allocate(prm%h_sl_tw(prm%sum_N_sl,prm%sum_N_tw)) ! at least one dimension is 0
allocate(prm%h_tw_sl(prm%sum_N_tw,prm%sum_N_sl)) ! at least one dimension is 0 allocate(prm%h_tw_sl(prm%sum_N_tw,prm%sum_N_sl)) ! at least one dimension is 0
prm%h_0_tw_sl = 0.0_pReal prm%h_0_tw_sl = 0.0_pREAL
end if slipAndTwinActive end if slipAndTwinActive
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
@ -246,28 +246,28 @@ module function plastic_phenopowerlaw_init() result(myPlasticity)
idx_dot%xi_sl = [startIndex,endIndex] idx_dot%xi_sl = [startIndex,endIndex]
stt%xi_sl => plasticState(ph)%state(startIndex:endIndex,:) stt%xi_sl => plasticState(ph)%state(startIndex:endIndex,:)
stt%xi_sl = spread(xi_0_sl, 2, Nmembers) stt%xi_sl = spread(xi_0_sl, 2, Nmembers)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_xi',defaultVal=1.0_pReal) plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_xi',defaultVal=1.0_pREAL)
if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_xi' if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pREAL)) extmsg = trim(extmsg)//' atol_xi'
startIndex = endIndex + 1 startIndex = endIndex + 1
endIndex = endIndex + prm%sum_N_tw endIndex = endIndex + prm%sum_N_tw
idx_dot%xi_tw = [startIndex,endIndex] idx_dot%xi_tw = [startIndex,endIndex]
stt%xi_tw => plasticState(ph)%state(startIndex:endIndex,:) stt%xi_tw => plasticState(ph)%state(startIndex:endIndex,:)
stt%xi_tw = spread(xi_0_tw, 2, Nmembers) stt%xi_tw = spread(xi_0_tw, 2, Nmembers)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_xi',defaultVal=1.0_pReal) plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_xi',defaultVal=1.0_pREAL)
startIndex = endIndex + 1 startIndex = endIndex + 1
endIndex = endIndex + prm%sum_N_sl endIndex = endIndex + prm%sum_N_sl
idx_dot%gamma_sl = [startIndex,endIndex] idx_dot%gamma_sl = [startIndex,endIndex]
stt%gamma_sl => plasticState(ph)%state(startIndex:endIndex,:) stt%gamma_sl => plasticState(ph)%state(startIndex:endIndex,:)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_gamma',defaultVal=1.0e-6_pReal) plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_gamma',defaultVal=1.0e-6_pREAL)
if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_gamma' if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pREAL)) extmsg = trim(extmsg)//' atol_gamma'
startIndex = endIndex + 1 startIndex = endIndex + 1
endIndex = endIndex + prm%sum_N_tw endIndex = endIndex + prm%sum_N_tw
idx_dot%gamma_tw = [startIndex,endIndex] idx_dot%gamma_tw = [startIndex,endIndex]
stt%gamma_tw => plasticState(ph)%state(startIndex:endIndex,:) stt%gamma_tw => plasticState(ph)%state(startIndex:endIndex,:)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_gamma',defaultVal=1.0e-6_pReal) plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_gamma',defaultVal=1.0e-6_pREAL)
end associate end associate
@ -287,12 +287,12 @@ end function plastic_phenopowerlaw_init
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure module subroutine phenopowerlaw_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en) pure module subroutine phenopowerlaw_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en)
real(pReal), dimension(3,3), intent(out) :: & real(pREAL), dimension(3,3), intent(out) :: &
Lp !< plastic velocity gradient Lp !< plastic velocity gradient
real(pReal), dimension(3,3,3,3), intent(out) :: & real(pREAL), dimension(3,3,3,3), intent(out) :: &
dLp_dMp !< derivative of Lp with respect to the Mandel stress dLp_dMp !< derivative of Lp with respect to the Mandel stress
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress Mp !< Mandel stress
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
@ -300,14 +300,14 @@ pure module subroutine phenopowerlaw_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en)
integer :: & integer :: &
i,k,l,m,n i,k,l,m,n
real(pReal), dimension(param(ph)%sum_N_sl) :: & real(pREAL), dimension(param(ph)%sum_N_sl) :: &
dot_gamma_sl_pos,dot_gamma_sl_neg, & dot_gamma_sl_pos,dot_gamma_sl_neg, &
ddot_gamma_dtau_sl_pos,ddot_gamma_dtau_sl_neg ddot_gamma_dtau_sl_pos,ddot_gamma_dtau_sl_neg
real(pReal), dimension(param(ph)%sum_N_tw) :: & real(pREAL), dimension(param(ph)%sum_N_tw) :: &
dot_gamma_tw,ddot_gamma_dtau_tw dot_gamma_tw,ddot_gamma_dtau_tw
Lp = 0.0_pReal Lp = 0.0_pREAL
dLp_dMp = 0.0_pReal dLp_dMp = 0.0_pREAL
associate(prm => param(ph)) associate(prm => param(ph))
@ -338,18 +338,18 @@ end subroutine phenopowerlaw_LpAndItsTangent
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
module function phenopowerlaw_dotState(Mp,ph,en) result(dotState) module function phenopowerlaw_dotState(Mp,ph,en) result(dotState)
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress Mp !< Mandel stress
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
real(pReal), dimension(plasticState(ph)%sizeDotState) :: & real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
dotState dotState
real(pReal) :: & real(pREAL) :: &
xi_sl_sat_offset,& xi_sl_sat_offset,&
sumF sumF
real(pReal), dimension(param(ph)%sum_N_sl) :: & real(pREAL), dimension(param(ph)%sum_N_sl) :: &
dot_gamma_sl_pos,dot_gamma_sl_neg, & dot_gamma_sl_pos,dot_gamma_sl_neg, &
left_SlipSlip left_SlipSlip
@ -365,10 +365,10 @@ module function phenopowerlaw_dotState(Mp,ph,en) result(dotState)
sumF = sum(stt%gamma_tw(:,en)/prm%gamma_char) sumF = sum(stt%gamma_tw(:,en)/prm%gamma_char)
xi_sl_sat_offset = prm%f_sat_sl_tw*sqrt(sumF) xi_sl_sat_offset = prm%f_sat_sl_tw*sqrt(sumF)
left_SlipSlip = sign(abs(1.0_pReal-stt%xi_sl(:,en) / (prm%xi_inf_sl+xi_sl_sat_offset))**prm%a_sl, & left_SlipSlip = sign(abs(1.0_pREAL-stt%xi_sl(:,en) / (prm%xi_inf_sl+xi_sl_sat_offset))**prm%a_sl, &
1.0_pReal-stt%xi_sl(:,en) / (prm%xi_inf_sl+xi_sl_sat_offset)) 1.0_pREAL-stt%xi_sl(:,en) / (prm%xi_inf_sl+xi_sl_sat_offset))
dot_xi_sl = prm%h_0_sl_sl * (1.0_pReal + prm%c_1 * sumF**prm%c_2) * (1.0_pReal + prm%h_int) & dot_xi_sl = prm%h_0_sl_sl * (1.0_pREAL + prm%c_1 * sumF**prm%c_2) * (1.0_pREAL + prm%h_int) &
* left_SlipSlip * matmul(prm%h_sl_sl,dot_gamma_sl) & * left_SlipSlip * matmul(prm%h_sl_sl,dot_gamma_sl) &
+ matmul(prm%h_sl_tw,dot_gamma_tw) + matmul(prm%h_sl_tw,dot_gamma_tw)
@ -431,20 +431,20 @@ end subroutine plastic_phenopowerlaw_result
pure subroutine kinetics_sl(Mp,ph,en, & pure subroutine kinetics_sl(Mp,ph,en, &
dot_gamma_sl_pos,dot_gamma_sl_neg,ddot_gamma_dtau_sl_pos,ddot_gamma_dtau_sl_neg) dot_gamma_sl_pos,dot_gamma_sl_neg,ddot_gamma_dtau_sl_pos,ddot_gamma_dtau_sl_neg)
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress Mp !< Mandel stress
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
real(pReal), intent(out), dimension(param(ph)%sum_N_sl) :: & real(pREAL), intent(out), dimension(param(ph)%sum_N_sl) :: &
dot_gamma_sl_pos, & dot_gamma_sl_pos, &
dot_gamma_sl_neg dot_gamma_sl_neg
real(pReal), intent(out), optional, dimension(param(ph)%sum_N_sl) :: & real(pREAL), intent(out), optional, dimension(param(ph)%sum_N_sl) :: &
ddot_gamma_dtau_sl_pos, & ddot_gamma_dtau_sl_pos, &
ddot_gamma_dtau_sl_neg ddot_gamma_dtau_sl_neg
real(pReal), dimension(param(ph)%sum_N_sl) :: & real(pREAL), dimension(param(ph)%sum_N_sl) :: &
tau_sl_pos, & tau_sl_pos, &
tau_sl_neg tau_sl_neg
integer :: i integer :: i
@ -454,35 +454,35 @@ pure subroutine kinetics_sl(Mp,ph,en, &
do i = 1, prm%sum_N_sl do i = 1, prm%sum_N_sl
tau_sl_pos(i) = math_tensordot(Mp,prm%P_nS_pos(1:3,1:3,i)) tau_sl_pos(i) = math_tensordot(Mp,prm%P_nS_pos(1:3,1:3,i))
tau_sl_neg(i) = merge(math_tensordot(Mp,prm%P_nS_neg(1:3,1:3,i)), & tau_sl_neg(i) = merge(math_tensordot(Mp,prm%P_nS_neg(1:3,1:3,i)), &
0.0_pReal, prm%nonSchmidActive) 0.0_pREAL, prm%nonSchmidActive)
end do end do
where(dNeq0(tau_sl_pos)) where(dNeq0(tau_sl_pos))
dot_gamma_sl_pos = prm%dot_gamma_0_sl * merge(0.5_pReal,1.0_pReal, prm%nonSchmidActive) & ! 1/2 if non-Schmid active dot_gamma_sl_pos = prm%dot_gamma_0_sl * merge(0.5_pREAL,1.0_pREAL, prm%nonSchmidActive) & ! 1/2 if non-Schmid active
* sign(abs(tau_sl_pos/stt%xi_sl(:,en))**prm%n_sl, tau_sl_pos) * sign(abs(tau_sl_pos/stt%xi_sl(:,en))**prm%n_sl, tau_sl_pos)
else where else where
dot_gamma_sl_pos = 0.0_pReal dot_gamma_sl_pos = 0.0_pREAL
end where end where
where(dNeq0(tau_sl_neg)) where(dNeq0(tau_sl_neg))
dot_gamma_sl_neg = prm%dot_gamma_0_sl * 0.5_pReal & ! only used if non-Schmid active, always 1/2 dot_gamma_sl_neg = prm%dot_gamma_0_sl * 0.5_pREAL & ! only used if non-Schmid active, always 1/2
* sign(abs(tau_sl_neg/stt%xi_sl(:,en))**prm%n_sl, tau_sl_neg) * sign(abs(tau_sl_neg/stt%xi_sl(:,en))**prm%n_sl, tau_sl_neg)
else where else where
dot_gamma_sl_neg = 0.0_pReal dot_gamma_sl_neg = 0.0_pREAL
end where end where
if (present(ddot_gamma_dtau_sl_pos)) then if (present(ddot_gamma_dtau_sl_pos)) then
where(dNeq0(dot_gamma_sl_pos)) where(dNeq0(dot_gamma_sl_pos))
ddot_gamma_dtau_sl_pos = dot_gamma_sl_pos*prm%n_sl/tau_sl_pos ddot_gamma_dtau_sl_pos = dot_gamma_sl_pos*prm%n_sl/tau_sl_pos
else where else where
ddot_gamma_dtau_sl_pos = 0.0_pReal ddot_gamma_dtau_sl_pos = 0.0_pREAL
end where end where
end if end if
if (present(ddot_gamma_dtau_sl_neg)) then if (present(ddot_gamma_dtau_sl_neg)) then
where(dNeq0(dot_gamma_sl_neg)) where(dNeq0(dot_gamma_sl_neg))
ddot_gamma_dtau_sl_neg = dot_gamma_sl_neg*prm%n_sl/tau_sl_neg ddot_gamma_dtau_sl_neg = dot_gamma_sl_neg*prm%n_sl/tau_sl_neg
else where else where
ddot_gamma_dtau_sl_neg = 0.0_pReal ddot_gamma_dtau_sl_neg = 0.0_pREAL
end where end where
end if end if
@ -501,18 +501,18 @@ end subroutine kinetics_sl
pure subroutine kinetics_tw(Mp,ph,en,& pure subroutine kinetics_tw(Mp,ph,en,&
dot_gamma_tw,ddot_gamma_dtau_tw) dot_gamma_tw,ddot_gamma_dtau_tw)
real(pReal), dimension(3,3), intent(in) :: & real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress Mp !< Mandel stress
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
real(pReal), dimension(param(ph)%sum_N_tw), intent(out) :: & real(pREAL), dimension(param(ph)%sum_N_tw), intent(out) :: &
dot_gamma_tw dot_gamma_tw
real(pReal), dimension(param(ph)%sum_N_tw), intent(out), optional :: & real(pREAL), dimension(param(ph)%sum_N_tw), intent(out), optional :: &
ddot_gamma_dtau_tw ddot_gamma_dtau_tw
real(pReal), dimension(param(ph)%sum_N_tw) :: & real(pREAL), dimension(param(ph)%sum_N_tw) :: &
tau_tw tau_tw
integer :: i integer :: i
@ -521,18 +521,18 @@ pure subroutine kinetics_tw(Mp,ph,en,&
tau_tw = [(math_tensordot(Mp,prm%P_tw(1:3,1:3,i)),i=1,prm%sum_N_tw)] tau_tw = [(math_tensordot(Mp,prm%P_tw(1:3,1:3,i)),i=1,prm%sum_N_tw)]
where(tau_tw > 0.0_pReal) where(tau_tw > 0.0_pREAL)
dot_gamma_tw = (1.0_pReal-sum(stt%gamma_tw(:,en)/prm%gamma_char)) & ! only twin in untwinned volume fraction dot_gamma_tw = (1.0_pREAL-sum(stt%gamma_tw(:,en)/prm%gamma_char)) & ! only twin in untwinned volume fraction
* prm%dot_gamma_0_tw*(abs(tau_tw)/stt%xi_tw(:,en))**prm%n_tw * prm%dot_gamma_0_tw*(abs(tau_tw)/stt%xi_tw(:,en))**prm%n_tw
else where else where
dot_gamma_tw = 0.0_pReal dot_gamma_tw = 0.0_pREAL
end where end where
if (present(ddot_gamma_dtau_tw)) then if (present(ddot_gamma_dtau_tw)) then
where(dNeq0(dot_gamma_tw)) where(dNeq0(dot_gamma_tw))
ddot_gamma_dtau_tw = dot_gamma_tw*prm%n_tw/tau_tw ddot_gamma_dtau_tw = dot_gamma_tw*prm%n_tw/tau_tw
else where else where
ddot_gamma_dtau_tw = 0.0_pReal ddot_gamma_dtau_tw = 0.0_pREAL
end where end where
end if end if

30
src/phase_thermal.f90
View File

@ -4,8 +4,8 @@
submodule(phase) thermal submodule(phase) thermal
type :: tThermalParameters type :: tThermalParameters
real(pReal) :: C_p = 0.0_pReal !< heat capacity real(pREAL) :: C_p = 0.0_pREAL !< heat capacity
real(pReal), dimension(3,3) :: K = 0.0_pReal !< thermal conductivity real(pREAL), dimension(3,3) :: K = 0.0_pREAL !< thermal conductivity
character(len=pSTRLEN), allocatable, dimension(:) :: output character(len=pSTRLEN), allocatable, dimension(:) :: output
end type tThermalParameters end type tThermalParameters
@ -22,7 +22,7 @@ submodule(phase) thermal
end enum end enum
type :: tDataContainer ! ?? not very telling name. Better: "fieldQuantities" ?? type :: tDataContainer ! ?? not very telling name. Better: "fieldQuantities" ??
real(pReal), dimension(:), allocatable :: T, dot_T real(pREAL), dimension(:), allocatable :: T, dot_T
end type tDataContainer end type tDataContainer
integer(kind(THERMAL_UNDEFINED_ID)), dimension(:,:), allocatable :: & integer(kind(THERMAL_UNDEFINED_ID)), dimension(:,:), allocatable :: &
thermal_source thermal_source
@ -57,14 +57,14 @@ submodule(phase) thermal
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
real(pReal) :: f_T real(pREAL) :: f_T
end function dissipation_f_T end function dissipation_f_T
module function externalheat_f_T(ph,en) result(f_T) module function externalheat_f_T(ph,en) result(f_T)
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
real(pReal) :: f_T real(pREAL) :: f_T
end function externalheat_f_T end function externalheat_f_T
end interface end interface
@ -100,7 +100,7 @@ module subroutine thermal_init(phases)
do ph = 1, phases%length do ph = 1, phases%length
Nmembers = count(material_ID_phase == ph) Nmembers = count(material_ID_phase == ph)
allocate(current(ph)%T(Nmembers),source=T_ROOM) allocate(current(ph)%T(Nmembers),source=T_ROOM)
allocate(current(ph)%dot_T(Nmembers),source=0.0_pReal) allocate(current(ph)%dot_T(Nmembers),source=0.0_pREAL)
phase => phases%get_dict(ph) phase => phases%get_dict(ph)
thermal => phase%get_dict('thermal',defaultVal=emptyDict) thermal => phase%get_dict('thermal',defaultVal=emptyDict)
@ -156,13 +156,13 @@ end subroutine thermal_init
module function phase_f_T(ph,en) result(f) module function phase_f_T(ph,en) result(f)
integer, intent(in) :: ph, en integer, intent(in) :: ph, en
real(pReal) :: f real(pREAL) :: f
integer :: so integer :: so
f = 0.0_pReal f = 0.0_pREAL
do so = 1, thermal_Nsources(ph) do so = 1, thermal_Nsources(ph)
select case(thermal_source(so,ph)) select case(thermal_source(so,ph))
@ -211,7 +211,7 @@ end function phase_thermal_collectDotState
module function phase_mu_T(co,ce) result(mu) module function phase_mu_T(co,ce) result(mu)
integer, intent(in) :: co, ce integer, intent(in) :: co, ce
real(pReal) :: mu real(pREAL) :: mu
mu = phase_rho(material_ID_phase(co,ce)) & mu = phase_rho(material_ID_phase(co,ce)) &
@ -226,7 +226,7 @@ end function phase_mu_T
module function phase_K_T(co,ce) result(K) module function phase_K_T(co,ce) result(K)
integer, intent(in) :: co, ce integer, intent(in) :: co, ce
real(pReal), dimension(3,3) :: K real(pREAL), dimension(3,3) :: K
K = crystallite_push33ToRef(co,ce,param(material_ID_phase(co,ce))%K) K = crystallite_push33ToRef(co,ce,param(material_ID_phase(co,ce))%K)
@ -236,7 +236,7 @@ end function phase_K_T
module function phase_thermal_constitutive(Delta_t,ph,en) result(converged_) module function phase_thermal_constitutive(Delta_t,ph,en) result(converged_)
real(pReal), intent(in) :: Delta_t real(pREAL), intent(in) :: Delta_t
integer, intent(in) :: ph, en integer, intent(in) :: ph, en
logical :: converged_ logical :: converged_
@ -251,7 +251,7 @@ end function phase_thermal_constitutive
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
function integrateThermalState(Delta_t, ph,en) result(broken) function integrateThermalState(Delta_t, ph,en) result(broken)
real(pReal), intent(in) :: Delta_t real(pREAL), intent(in) :: Delta_t
integer, intent(in) :: ph, en integer, intent(in) :: ph, en
logical :: & logical :: &
broken broken
@ -323,7 +323,7 @@ end subroutine thermal_forward
pure module function thermal_T(ph,en) result(T) pure module function thermal_T(ph,en) result(T)
integer, intent(in) :: ph, en integer, intent(in) :: ph, en
real(pReal) :: T real(pREAL) :: T
T = current(ph)%T(en) T = current(ph)%T(en)
@ -337,7 +337,7 @@ end function thermal_T
module function thermal_dot_T(ph,en) result(dot_T) module function thermal_dot_T(ph,en) result(dot_T)
integer, intent(in) :: ph, en integer, intent(in) :: ph, en
real(pReal) :: dot_T real(pREAL) :: dot_T
dot_T = current(ph)%dot_T(en) dot_T = current(ph)%dot_T(en)
@ -350,7 +350,7 @@ end function thermal_dot_T
!---------------------------------------------------------------------------------------------- !----------------------------------------------------------------------------------------------
module subroutine phase_thermal_setField(T,dot_T, co,ce) module subroutine phase_thermal_setField(T,dot_T, co,ce)
real(pReal), intent(in) :: T, dot_T real(pREAL), intent(in) :: T, dot_T
integer, intent(in) :: ce, co integer, intent(in) :: ce, co

6
src/phase_thermal_dissipation.f90
View File

@ -8,7 +8,7 @@
submodule(phase:thermal) dissipation submodule(phase:thermal) dissipation
type :: tParameters !< container type for internal constitutive parameters type :: tParameters !< container type for internal constitutive parameters
real(pReal) :: & real(pREAL) :: &
kappa !< TAYLOR-QUINNEY factor kappa !< TAYLOR-QUINNEY factor
end type tParameters end type tParameters
@ -80,9 +80,9 @@ end function dissipation_init
module function dissipation_f_T(ph,en) result(f_T) module function dissipation_f_T(ph,en) result(f_T)
integer, intent(in) :: ph, en integer, intent(in) :: ph, en
real(pReal) :: & real(pREAL) :: &
f_T f_T
real(pReal), dimension(3,3) :: & real(pREAL), dimension(3,3) :: &
Mp !< Mandel stress work conjugate with Lp Mp !< Mandel stress work conjugate with Lp
Mp = matmul(matmul(transpose(mechanical_F_i(ph,en)),mechanical_F_i(ph,en)),mechanical_S(ph,en)) Mp = matmul(matmul(transpose(mechanical_F_i(ph,en)),mechanical_F_i(ph,en)),mechanical_S(ph,en))

4
src/phase_thermal_externalheat.f90
View File

@ -92,7 +92,7 @@ module subroutine externalheat_dotState(ph, en)
so = source_thermal_externalheat_offset(ph) so = source_thermal_externalheat_offset(ph)
thermalState(ph)%p(so)%dotState(1,en) = 1.0_pReal ! state is current time thermalState(ph)%p(so)%dotState(1,en) = 1.0_pREAL ! state is current time
end subroutine externalheat_dotState end subroutine externalheat_dotState
@ -105,7 +105,7 @@ module function externalheat_f_T(ph,en) result(f_T)
integer, intent(in) :: & integer, intent(in) :: &
ph, & ph, &
en en
real(pReal) :: & real(pREAL) :: &
f_T f_T
integer :: & integer :: &

40
src/polynomials.f90
View File

@ -12,8 +12,8 @@ module polynomials
private private
type, public :: tPolynomial type, public :: tPolynomial
real(pReal), dimension(:), allocatable :: coef real(pREAL), dimension(:), allocatable :: coef
real(pReal) :: x_ref = huge(0.0_pReal) real(pREAL) :: x_ref = huge(0.0_pREAL)
contains contains
procedure, public :: at => eval procedure, public :: at => eval
end type tPolynomial end type tPolynomial
@ -47,8 +47,8 @@ end subroutine polynomials_init
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function polynomial_from_coef(coef,x_ref) result(p) pure function polynomial_from_coef(coef,x_ref) result(p)
real(pReal), dimension(0:), intent(in) :: coef real(pREAL), dimension(0:), intent(in) :: coef
real(pReal), intent(in) :: x_ref real(pREAL), intent(in) :: x_ref
type(tPolynomial) :: p type(tPolynomial) :: p
@ -67,8 +67,8 @@ function polynomial_from_dict(dict,y,x) result(p)
character(len=*), intent(in) :: y, x character(len=*), intent(in) :: y, x
type(tPolynomial) :: p type(tPolynomial) :: p
real(pReal), dimension(:), allocatable :: coef real(pREAL), dimension(:), allocatable :: coef
real(pReal) :: x_ref real(pREAL) :: x_ref
integer :: i, o integer :: i, o
character(len=1) :: o_s character(len=1) :: o_s
@ -83,7 +83,7 @@ function polynomial_from_dict(dict,y,x) result(p)
write(o_s,'(I0.0)') o write(o_s,'(I0.0)') o
if (dict%contains(y//','//x//'^'//o_s)) then if (dict%contains(y//','//x//'^'//o_s)) then
x_ref = dict%get_asReal(x//'_ref') x_ref = dict%get_asReal(x//'_ref')
coef = [coef,[(0.0_pReal,i=size(coef),o-1)],dict%get_asReal(y//','//x//'^'//o_s)] coef = [coef,[(0.0_pREAL,i=size(coef),o-1)],dict%get_asReal(y//','//x//'^'//o_s)]
end if end if
end do end do
@ -99,8 +99,8 @@ end function polynomial_from_dict
pure function eval(self,x) result(y) pure function eval(self,x) result(y)
class(tPolynomial), intent(in) :: self class(tPolynomial), intent(in) :: self
real(pReal), intent(in) :: x real(pREAL), intent(in) :: x
real(pReal) :: y real(pREAL) :: y
integer :: o integer :: o
@ -123,9 +123,9 @@ end function eval
subroutine selfTest() subroutine selfTest()
type(tPolynomial) :: p1, p2 type(tPolynomial) :: p1, p2
real(pReal), dimension(5) :: coef real(pREAL), dimension(5) :: coef
integer :: i integer :: i
real(pReal) :: x_ref, x, y real(pREAL) :: x_ref, x, y
type(tDict), pointer :: dict type(tDict), pointer :: dict
character(len=pSTRLEN), dimension(size(coef)) :: coef_s character(len=pSTRLEN), dimension(size(coef)) :: coef_s
character(len=pSTRLEN) :: x_ref_s, x_s, YAML_s character(len=pSTRLEN) :: x_ref_s, x_s, YAML_s
@ -135,9 +135,9 @@ subroutine selfTest()
call random_number(x_ref) call random_number(x_ref)
call random_number(x) call random_number(x)
coef = coef*10_pReal -0.5_pReal coef = coef*10_pREAL -0.5_pREAL
x_ref = x_ref*10_pReal -0.5_pReal x_ref = x_ref*10_pREAL -0.5_pREAL
x = x*10_pReal -0.5_pReal x = x*10_pREAL -0.5_pREAL
p1 = polynomial([coef(1)],x_ref) p1 = polynomial([coef(1)],x_ref)
if (dNeq(p1%at(x),coef(1))) error stop 'polynomial: eval(constant)' if (dNeq(p1%at(x),coef(1))) error stop 'polynomial: eval(constant)'
@ -158,37 +158,37 @@ subroutine selfTest()
'T_ref: '//trim(adjustl(x_ref_s))//IO_EOL 'T_ref: '//trim(adjustl(x_ref_s))//IO_EOL
dict => YAML_parse_str_asDict(trim(YAML_s)) dict => YAML_parse_str_asDict(trim(YAML_s))
p2 = polynomial(dict,'C','T') p2 = polynomial(dict,'C','T')
if (dNeq(p1%at(x),p2%at(x),1.0e-6_pReal)) error stop 'polynomials: init' if (dNeq(p1%at(x),p2%at(x),1.0e-6_pREAL)) error stop 'polynomials: init'
y = coef(1)+coef(2)*(x-x_ref)+coef(3)*(x-x_ref)**2+coef(4)*(x-x_ref)**3+coef(5)*(x-x_ref)**4 y = coef(1)+coef(2)*(x-x_ref)+coef(3)*(x-x_ref)**2+coef(4)*(x-x_ref)**3+coef(5)*(x-x_ref)**4
if (dNeq(p1%at(x),y,1.0e-6_pReal)) error stop 'polynomials: eval(full)' if (dNeq(p1%at(x),y,1.0e-6_pREAL)) error stop 'polynomials: eval(full)'
YAML_s = 'C: 0.0'//IO_EOL//& YAML_s = 'C: 0.0'//IO_EOL//&
'C,T: '//trim(adjustl(coef_s(2)))//IO_EOL//& 'C,T: '//trim(adjustl(coef_s(2)))//IO_EOL//&
'T_ref: '//trim(adjustl(x_ref_s))//IO_EOL 'T_ref: '//trim(adjustl(x_ref_s))//IO_EOL
dict => YAML_parse_str_asDict(trim(YAML_s)) dict => YAML_parse_str_asDict(trim(YAML_s))
p1 = polynomial(dict,'C','T') p1 = polynomial(dict,'C','T')
if (dNeq(p1%at(x_ref+x),-p1%at(x_ref-x),1.0e-10_pReal)) error stop 'polynomials: eval(linear)' if (dNeq(p1%at(x_ref+x),-p1%at(x_ref-x),1.0e-10_pREAL)) error stop 'polynomials: eval(linear)'
YAML_s = 'C: 0.0'//IO_EOL//& YAML_s = 'C: 0.0'//IO_EOL//&
'C,T^2: '//trim(adjustl(coef_s(3)))//IO_EOL//& 'C,T^2: '//trim(adjustl(coef_s(3)))//IO_EOL//&
'T_ref: '//trim(adjustl(x_ref_s))//IO_EOL 'T_ref: '//trim(adjustl(x_ref_s))//IO_EOL
dict => YAML_parse_str_asDict(trim(YAML_s)) dict => YAML_parse_str_asDict(trim(YAML_s))
p1 = polynomial(dict,'C','T') p1 = polynomial(dict,'C','T')
if (dNeq(p1%at(x_ref+x),p1%at(x_ref-x),1e-10_pReal)) error stop 'polynomials: eval(quadratic)' if (dNeq(p1%at(x_ref+x),p1%at(x_ref-x),1e-10_pREAL)) error stop 'polynomials: eval(quadratic)'
YAML_s = 'Y: '//trim(adjustl(coef_s(1)))//IO_EOL//& YAML_s = 'Y: '//trim(adjustl(coef_s(1)))//IO_EOL//&
'Y,X^3: '//trim(adjustl(coef_s(2)))//IO_EOL//& 'Y,X^3: '//trim(adjustl(coef_s(2)))//IO_EOL//&
'X_ref: '//trim(adjustl(x_ref_s))//IO_EOL 'X_ref: '//trim(adjustl(x_ref_s))//IO_EOL
dict => YAML_parse_str_asDict(trim(YAML_s)) dict => YAML_parse_str_asDict(trim(YAML_s))
p1 = polynomial(dict,'Y','X') p1 = polynomial(dict,'Y','X')
if (dNeq(p1%at(x_ref+x)-coef(1),-(p1%at(x_ref-x)-coef(1)),1.0e-8_pReal)) error stop 'polynomials: eval(cubic)' if (dNeq(p1%at(x_ref+x)-coef(1),-(p1%at(x_ref-x)-coef(1)),1.0e-8_pREAL)) error stop 'polynomials: eval(cubic)'
YAML_s = 'Y: '//trim(adjustl(coef_s(1)))//IO_EOL//& YAML_s = 'Y: '//trim(adjustl(coef_s(1)))//IO_EOL//&
'Y,X^4: '//trim(adjustl(coef_s(2)))//IO_EOL//& 'Y,X^4: '//trim(adjustl(coef_s(2)))//IO_EOL//&
'X_ref: '//trim(adjustl(x_ref_s))//IO_EOL 'X_ref: '//trim(adjustl(x_ref_s))//IO_EOL
dict => YAML_parse_str_asDict(trim(YAML_s)) dict => YAML_parse_str_asDict(trim(YAML_s))
p1 = polynomial(dict,'Y','X') p1 = polynomial(dict,'Y','X')
if (dNeq(p1%at(x_ref+x),p1%at(x_ref-x),1.0e-6_pReal)) error stop 'polynomials: eval(quartic)' if (dNeq(p1%at(x_ref+x),p1%at(x_ref-x),1.0e-6_pREAL)) error stop 'polynomials: eval(quartic)'
end subroutine selfTest end subroutine selfTest

58
src/prec.f90
View File

@ -19,26 +19,26 @@ module prec
public public
! https://stevelionel.com/drfortran/2017/03/27/doctor-fortran-in-it-takes-all-kinds ! https://stevelionel.com/drfortran/2017/03/27/doctor-fortran-in-it-takes-all-kinds
integer, parameter :: pReal = IEEE_selected_real_kind(15,307) !< number with 15 significant digits, up to 1e+-307 (typically 64 bit) integer, parameter :: pREAL = IEEE_selected_real_kind(15,307) !< number with 15 significant digits, up to 1e+-307 (typically 64 bit)
integer, parameter :: pI32 = selected_int_kind(9) !< number with at least up to +-1e9 (typically 32 bit) integer, parameter :: pI32 = selected_int_kind(9) !< number with at least up to +-1e9 (typically 32 bit)
integer, parameter :: pI64 = selected_int_kind(18) !< number with at least up to +-1e18 (typically 64 bit) integer, parameter :: pI64 = selected_int_kind(18) !< number with at least up to +-1e18 (typically 64 bit)
#ifdef PETSC #ifdef PETSC
PetscInt, private :: dummy_int PetscInt, private :: dummy_int
integer, parameter :: pPETSCINT = kind(dummy_int) integer, parameter :: pPETSCINT = kind(dummy_int)
PetscScalar, private :: dummy_scalar PetscScalar, private :: dummy_scalar
real(pReal), parameter, private :: pPETSCSCALAR = kind(dummy_scalar) real(pREAL), parameter, private :: pPETSCSCALAR = kind(dummy_scalar)
#endif #endif
integer, parameter :: pSTRLEN = 256 !< default string length integer, parameter :: pSTRLEN = 256 !< default string length
integer, parameter :: pPATHLEN = 4096 !< maximum length of a path name on linux integer, parameter :: pPATHLEN = 4096 !< maximum length of a path name on linux
real(pReal), parameter :: tol_math_check = 1.0e-8_pReal !< tolerance for internal math self-checks (rotation) real(pREAL), parameter :: tol_math_check = 1.0e-8_pREAL !< tolerance for internal math self-checks (rotation)
real(pReal), private, parameter :: PREAL_EPSILON = epsilon(0.0_pReal) !< minimum positive number such that 1.0 + EPSILON /= 1.0. real(pREAL), private, parameter :: PREAL_EPSILON = epsilon(0.0_pREAL) !< minimum positive number such that 1.0 + EPSILON /= 1.0.
real(pReal), private, parameter :: PREAL_MIN = tiny(0.0_pReal) !< smallest normalized floating point number real(pREAL), private, parameter :: PREAL_MIN = tiny(0.0_pREAL) !< smallest normalized floating point number
integer, dimension(0), parameter :: emptyIntArray = [integer::] integer, dimension(0), parameter :: emptyIntArray = [integer::]
real(pReal), dimension(0), parameter :: emptyRealArray = [real(pReal)::] real(pREAL), dimension(0), parameter :: emptyRealArray = [real(pREAL)::]
character(len=pSTRLEN), dimension(0), parameter :: emptyStrArray = [character(len=pSTRLEN)::] character(len=pSTRLEN), dimension(0), parameter :: emptyStrArray = [character(len=pSTRLEN)::]
@ -54,11 +54,11 @@ subroutine prec_init()
print'(/,a,i3)', ' integer size / bit: ',bit_size(0) print'(/,a,i3)', ' integer size / bit: ',bit_size(0)
print'( a,i19)', ' maximum value: ',huge(0) print'( a,i19)', ' maximum value: ',huge(0)
print'(/,a,i3)', ' real size / bit: ',storage_size(0.0_pReal) print'(/,a,i3)', ' real size / bit: ',storage_size(0.0_pREAL)
print'( a,e10.3)', ' maximum value: ',huge(0.0_pReal) print'( a,e10.3)', ' maximum value: ',huge(0.0_pREAL)
print'( a,e10.3)', ' minimum value: ',PREAL_MIN print'( a,e10.3)', ' minimum value: ',PREAL_MIN
print'( a,e10.3)', ' epsilon value: ',PREAL_EPSILON print'( a,e10.3)', ' epsilon value: ',PREAL_EPSILON
print'( a,i3)', ' decimal precision: ',precision(0.0_pReal) print'( a,i3)', ' decimal precision: ',precision(0.0_pREAL)
call prec_selfTest() call prec_selfTest()
@ -74,8 +74,8 @@ end subroutine prec_init
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
logical elemental pure function dEq(a,b,tol) logical elemental pure function dEq(a,b,tol)
real(pReal), intent(in) :: a,b real(pREAL), intent(in) :: a,b
real(pReal), intent(in), optional :: tol real(pREAL), intent(in), optional :: tol
if (present(tol)) then if (present(tol)) then
@ -95,8 +95,8 @@ end function dEq
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
logical elemental pure function dNeq(a,b,tol) logical elemental pure function dNeq(a,b,tol)
real(pReal), intent(in) :: a,b real(pREAL), intent(in) :: a,b
real(pReal), intent(in), optional :: tol real(pREAL), intent(in), optional :: tol
dNeq = .not. dEq(a,b,tol) dNeq = .not. dEq(a,b,tol)
@ -112,14 +112,14 @@ end function dNeq
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
logical elemental pure function dEq0(a,tol) logical elemental pure function dEq0(a,tol)
real(pReal), intent(in) :: a real(pREAL), intent(in) :: a
real(pReal), intent(in), optional :: tol real(pREAL), intent(in), optional :: tol
if (present(tol)) then if (present(tol)) then
dEq0 = abs(a) <= tol dEq0 = abs(a) <= tol
else else
dEq0 = abs(a) <= PREAL_MIN * 10.0_pReal dEq0 = abs(a) <= PREAL_MIN * 10.0_pREAL
end if end if
end function dEq0 end function dEq0
@ -133,8 +133,8 @@ end function dEq0
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
logical elemental pure function dNeq0(a,tol) logical elemental pure function dNeq0(a,tol)
real(pReal), intent(in) :: a real(pREAL), intent(in) :: a
real(pReal), intent(in), optional :: tol real(pREAL), intent(in), optional :: tol
dNeq0 = .not. dEq0(a,tol) dNeq0 = .not. dEq0(a,tol)
@ -151,8 +151,8 @@ end function dNeq0
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
logical elemental pure function cEq(a,b,tol) logical elemental pure function cEq(a,b,tol)
complex(pReal), intent(in) :: a,b complex(pREAL), intent(in) :: a,b
real(pReal), intent(in), optional :: tol real(pREAL), intent(in), optional :: tol
if (present(tol)) then if (present(tol)) then
@ -173,8 +173,8 @@ end function cEq
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
logical elemental pure function cNeq(a,b,tol) logical elemental pure function cNeq(a,b,tol)
complex(pReal), intent(in) :: a,b complex(pREAL), intent(in) :: a,b
real(pReal), intent(in), optional :: tol real(pREAL), intent(in), optional :: tol
cNeq = .not. cEq(a,b,tol) cNeq = .not. cEq(a,b,tol)
@ -248,13 +248,13 @@ end function prec_bytesToC_INT64_T
subroutine prec_selfTest() subroutine prec_selfTest()
integer, allocatable, dimension(:) :: realloc_lhs_test integer, allocatable, dimension(:) :: realloc_lhs_test
real(pReal), dimension(1) :: f real(pREAL), dimension(1) :: f
integer(pI64), dimension(1) :: i integer(pI64), dimension(1) :: i
real(pReal), dimension(2) :: r real(pREAL), dimension(2) :: r
#ifdef PETSC #ifdef PETSC
if (pReal /= pPETSCSCALAR) error stop 'PETSc and DAMASK scalar datatypes do not match' if (pREAL /= pPETSCSCALAR) error stop 'PETSc and DAMASK scalar datatypes do not match'
#endif #endif
realloc_lhs_test = [1,2] realloc_lhs_test = [1,2]
if (any(realloc_lhs_test/=[1,2])) error stop 'LHS allocation' if (any(realloc_lhs_test/=[1,2])) error stop 'LHS allocation'
@ -267,11 +267,11 @@ subroutine prec_selfTest()
! https://www.binaryconvert.com ! https://www.binaryconvert.com
! https://www.rapidtables.com/convert/number/binary-to-decimal.html ! https://www.rapidtables.com/convert/number/binary-to-decimal.html
f = real(prec_bytesToC_FLOAT(int([-65,+11,-102,+75],C_SIGNED_CHAR)),pReal) f = real(prec_bytesToC_FLOAT(int([-65,+11,-102,+75],C_SIGNED_CHAR)),pREAL)
if (dNeq(f(1),20191102.0_pReal,0.0_pReal)) error stop 'prec_bytesToC_FLOAT' if (dNeq(f(1),20191102.0_pREAL,0.0_pREAL)) error stop 'prec_bytesToC_FLOAT'
f = real(prec_bytesToC_DOUBLE(int([0,0,0,-32,+119,+65,+115,65],C_SIGNED_CHAR)),pReal) f = real(prec_bytesToC_DOUBLE(int([0,0,0,-32,+119,+65,+115,65],C_SIGNED_CHAR)),pREAL)
if (dNeq(f(1),20191102.0_pReal,0.0_pReal)) error stop 'prec_bytesToC_DOUBLE' if (dNeq(f(1),20191102.0_pREAL,0.0_pREAL)) error stop 'prec_bytesToC_DOUBLE'
i = int(prec_bytesToC_INT32_T(int([+126,+23,+52,+1],C_SIGNED_CHAR)),pI64) i = int(prec_bytesToC_INT32_T(int([+126,+23,+52,+1],C_SIGNED_CHAR)),pI64)
if (i(1) /= 20191102_pI64) error stop 'prec_bytesToC_INT32_T' if (i(1) /= 20191102_pI64) error stop 'prec_bytesToC_INT32_T'

14
src/result.f90
View File

@ -141,7 +141,7 @@ end subroutine result_closeJobFile
subroutine result_addIncrement(inc,time) subroutine result_addIncrement(inc,time)
integer, intent(in) :: inc integer, intent(in) :: inc
real(pReal), intent(in) :: time real(pREAL), intent(in) :: time
character(len=pSTRLEN) :: incChar character(len=pSTRLEN) :: incChar
@ -251,7 +251,7 @@ end subroutine result_addAttribute_int
subroutine result_addAttribute_real(attrLabel,attrValue,path) subroutine result_addAttribute_real(attrLabel,attrValue,path)
character(len=*), intent(in) :: attrLabel character(len=*), intent(in) :: attrLabel
real(pReal), intent(in) :: attrValue real(pREAL), intent(in) :: attrValue
character(len=*), intent(in), optional :: path character(len=*), intent(in), optional :: path
@ -296,7 +296,7 @@ end subroutine result_addAttribute_int_array
subroutine result_addAttribute_real_array(attrLabel,attrValue,path) subroutine result_addAttribute_real_array(attrLabel,attrValue,path)
character(len=*), intent(in) :: attrLabel character(len=*), intent(in) :: attrLabel
real(pReal), intent(in), dimension(:) :: attrValue real(pREAL), intent(in), dimension(:) :: attrValue
character(len=*), intent(in), optional :: path character(len=*), intent(in), optional :: path
@ -345,7 +345,7 @@ subroutine result_writeScalarDataset_real(dataset,group,label,description,SIunit
character(len=*), intent(in) :: label,group,description character(len=*), intent(in) :: label,group,description
character(len=*), intent(in), optional :: SIunit character(len=*), intent(in), optional :: SIunit
real(pReal), intent(in), dimension(:) :: dataset real(pREAL), intent(in), dimension(:) :: dataset
integer(HID_T) :: groupHandle integer(HID_T) :: groupHandle
@ -366,7 +366,7 @@ subroutine result_writeVectorDataset_real(dataset,group,label,description,SIunit
character(len=*), intent(in) :: label,group,description character(len=*), intent(in) :: label,group,description
character(len=*), intent(in), optional :: SIunit character(len=*), intent(in), optional :: SIunit
character(len=*), intent(in), dimension(:), optional :: systems character(len=*), intent(in), dimension(:), optional :: systems
real(pReal), intent(in), dimension(:,:) :: dataset real(pREAL), intent(in), dimension(:,:) :: dataset
integer(HID_T) :: groupHandle integer(HID_T) :: groupHandle
@ -390,11 +390,11 @@ subroutine result_writeTensorDataset_real(dataset,group,label,description,SIunit
character(len=*), intent(in) :: label,group,description character(len=*), intent(in) :: label,group,description
character(len=*), intent(in), optional :: SIunit character(len=*), intent(in), optional :: SIunit
logical, intent(in), optional :: transposed logical, intent(in), optional :: transposed
real(pReal), intent(in), dimension(:,:,:) :: dataset real(pREAL), intent(in), dimension(:,:,:) :: dataset
integer :: i integer :: i
integer(HID_T) :: groupHandle integer(HID_T) :: groupHandle
real(pReal), dimension(:,:,:), allocatable :: dataset_transposed real(pREAL), dimension(:,:,:), allocatable :: dataset_transposed
groupHandle = result_openGroup(group) groupHandle = result_openGroup(group)

324
src/rotations.f90
View File

@ -53,10 +53,10 @@ module rotations
implicit none(type,external) implicit none(type,external)
private private
real(pReal), parameter :: P = -1.0_pReal !< parameter for orientation conversion. real(pREAL), parameter :: P = -1.0_pREAL !< parameter for orientation conversion.
type, public :: tRotation type, public :: tRotation
real(pReal), dimension(4) :: q real(pREAL), dimension(4) :: q
contains contains
procedure, public :: asQuaternion procedure, public :: asQuaternion
procedure, public :: asEulers procedure, public :: asEulers
@ -79,16 +79,16 @@ module rotations
procedure, public :: standardize procedure, public :: standardize
end type tRotation end type tRotation
real(pReal), parameter :: & real(pREAL), parameter :: &
PREF = sqrt(6.0_pReal/PI), & PREF = sqrt(6.0_pREAL/PI), &
A = PI**(5.0_pReal/6.0_pReal)/6.0_pReal**(1.0_pReal/6.0_pReal), & A = PI**(5.0_pREAL/6.0_pREAL)/6.0_pREAL**(1.0_pREAL/6.0_pREAL), &
AP = PI**(2.0_pReal/3.0_pReal), & AP = PI**(2.0_pREAL/3.0_pREAL), &
SC = A/AP, & SC = A/AP, &
BETA = A/2.0_pReal, & BETA = A/2.0_pREAL, &
R1 = (3.0_pReal*PI/4.0_pReal)**(1.0_pReal/3.0_pReal), & R1 = (3.0_pREAL*PI/4.0_pREAL)**(1.0_pREAL/3.0_pREAL), &
R2 = sqrt(2.0_pReal), & R2 = sqrt(2.0_pREAL), &
PI12 = PI/12.0_pReal, & PI12 = PI/12.0_pREAL, &
PREK = R1 * 2.0_pReal**(1.0_pReal/4.0_pReal)/BETA PREK = R1 * 2.0_pREAL**(1.0_pREAL/4.0_pREAL)/BETA
public :: & public :: &
rotations_init, & rotations_init, &
@ -117,7 +117,7 @@ end subroutine rotations_init
pure function asQuaternion(self) pure function asQuaternion(self)
class(tRotation), intent(in) :: self class(tRotation), intent(in) :: self
real(pReal), dimension(4) :: asQuaternion real(pREAL), dimension(4) :: asQuaternion
asQuaternion = self%q asQuaternion = self%q
@ -127,7 +127,7 @@ end function asQuaternion
pure function asEulers(self) pure function asEulers(self)
class(tRotation), intent(in) :: self class(tRotation), intent(in) :: self
real(pReal), dimension(3) :: asEulers real(pREAL), dimension(3) :: asEulers
asEulers = qu2eu(self%q) asEulers = qu2eu(self%q)
@ -137,7 +137,7 @@ end function asEulers
pure function asAxisAngle(self) pure function asAxisAngle(self)
class(tRotation), intent(in) :: self class(tRotation), intent(in) :: self
real(pReal), dimension(4) :: asAxisAngle real(pREAL), dimension(4) :: asAxisAngle
asAxisAngle = qu2ax(self%q) asAxisAngle = qu2ax(self%q)
@ -147,7 +147,7 @@ end function asAxisAngle
pure function asMatrix(self) pure function asMatrix(self)
class(tRotation), intent(in) :: self class(tRotation), intent(in) :: self
real(pReal), dimension(3,3) :: asMatrix real(pREAL), dimension(3,3) :: asMatrix
asMatrix = qu2om(self%q) asMatrix = qu2om(self%q)
@ -160,10 +160,10 @@ end function asMatrix
subroutine fromQuaternion(self,qu) subroutine fromQuaternion(self,qu)
class(tRotation), intent(out) :: self class(tRotation), intent(out) :: self
real(pReal), dimension(4), intent(in) :: qu real(pREAL), dimension(4), intent(in) :: qu
if (dNeq(norm2(qu),1.0_pReal,1.0e-8_pReal)) call IO_error(402,ext_msg='fromQuaternion') if (dNeq(norm2(qu),1.0_pREAL,1.0e-8_pREAL)) call IO_error(402,ext_msg='fromQuaternion')
self%q = qu self%q = qu
@ -172,15 +172,15 @@ end subroutine fromQuaternion
subroutine fromEulers(self,eu,degrees) subroutine fromEulers(self,eu,degrees)
class(tRotation), intent(out) :: self class(tRotation), intent(out) :: self
real(pReal), dimension(3), intent(in) :: eu real(pREAL), dimension(3), intent(in) :: eu
logical, intent(in), optional :: degrees logical, intent(in), optional :: degrees
real(pReal), dimension(3) :: Eulers real(pREAL), dimension(3) :: Eulers
Eulers = merge(eu*INRAD,eu,misc_optional(degrees,.false.)) Eulers = merge(eu*INRAD,eu,misc_optional(degrees,.false.))
if (any(Eulers<0.0_pReal) .or. any(Eulers>TAU) .or. Eulers(2) > PI) & if (any(Eulers<0.0_pREAL) .or. any(Eulers>TAU) .or. Eulers(2) > PI) &
call IO_error(402,ext_msg='fromEulers') call IO_error(402,ext_msg='fromEulers')
self%q = eu2qu(Eulers) self%q = eu2qu(Eulers)
@ -190,20 +190,20 @@ end subroutine fromEulers
subroutine fromAxisAngle(self,ax,degrees,P) subroutine fromAxisAngle(self,ax,degrees,P)
class(tRotation), intent(out) :: self class(tRotation), intent(out) :: self
real(pReal), dimension(4), intent(in) :: ax real(pREAL), dimension(4), intent(in) :: ax
logical, intent(in), optional :: degrees logical, intent(in), optional :: degrees
integer, intent(in), optional :: P integer, intent(in), optional :: P
real(pReal) :: angle real(pREAL) :: angle
real(pReal),dimension(3) :: axis real(pREAL),dimension(3) :: axis
angle = merge(ax(4)*INRAD,ax(4),misc_optional(degrees,.false.)) angle = merge(ax(4)*INRAD,ax(4),misc_optional(degrees,.false.))
axis = ax(1:3) * merge(-1.0_pReal,1.0_pReal,misc_optional(P,-1) == 1) axis = ax(1:3) * merge(-1.0_pREAL,1.0_pREAL,misc_optional(P,-1) == 1)
if (abs(misc_optional(P,-1)) /= 1) call IO_error(402,ext_msg='fromAxisAngle (P)') if (abs(misc_optional(P,-1)) /= 1) call IO_error(402,ext_msg='fromAxisAngle (P)')
if (dNeq(norm2(axis),1.0_pReal) .or. angle < 0.0_pReal .or. angle > PI) & if (dNeq(norm2(axis),1.0_pREAL) .or. angle < 0.0_pREAL .or. angle > PI) &
call IO_error(402,ext_msg='fromAxisAngle') call IO_error(402,ext_msg='fromAxisAngle')
self%q = ax2qu([axis,angle]) self%q = ax2qu([axis,angle])
@ -213,10 +213,10 @@ end subroutine fromAxisAngle
subroutine fromMatrix(self,om) subroutine fromMatrix(self,om)
class(tRotation), intent(out) :: self class(tRotation), intent(out) :: self
real(pReal), dimension(3,3), intent(in) :: om real(pREAL), dimension(3,3), intent(in) :: om
if (dNeq(math_det33(om),1.0_pReal,tol=1.0e-5_pReal)) & if (dNeq(math_det33(om),1.0_pREAL,tol=1.0e-5_pREAL)) &
call IO_error(402,ext_msg='fromMatrix') call IO_error(402,ext_msg='fromMatrix')
self%q = om2qu(om) self%q = om2qu(om)
@ -248,7 +248,7 @@ pure elemental subroutine standardize(self)
class(tRotation), intent(inout) :: self class(tRotation), intent(inout) :: self
if (sign(1.0_pReal,self%q(1)) < 0.0_pReal) self%q = - self%q if (sign(1.0_pREAL,self%q(1)) < 0.0_pREAL) self%q = - self%q
end subroutine standardize end subroutine standardize
@ -259,18 +259,18 @@ end subroutine standardize
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function rotVector(self,v,active) result(vRot) pure function rotVector(self,v,active) result(vRot)
real(pReal), dimension(3) :: vRot real(pREAL), dimension(3) :: vRot
class(tRotation), intent(in) :: self class(tRotation), intent(in) :: self
real(pReal), intent(in), dimension(3) :: v real(pREAL), intent(in), dimension(3) :: v
logical, intent(in), optional :: active logical, intent(in), optional :: active
real(pReal), dimension(4) :: v_normed, q real(pREAL), dimension(4) :: v_normed, q
if (dEq0(norm2(v))) then if (dEq0(norm2(v))) then
vRot = v vRot = v
else else
v_normed = [0.0_pReal,v]/norm2(v) v_normed = [0.0_pREAL,v]/norm2(v)
q = merge(multiplyQuaternion(conjugateQuaternion(self%q), multiplyQuaternion(v_normed, self%q)), & q = merge(multiplyQuaternion(conjugateQuaternion(self%q), multiplyQuaternion(v_normed, self%q)), &
multiplyQuaternion(self%q, multiplyQuaternion(v_normed, conjugateQuaternion(self%q))), & multiplyQuaternion(self%q, multiplyQuaternion(v_normed, conjugateQuaternion(self%q))), &
misc_optional(active,.false.)) misc_optional(active,.false.))
@ -287,9 +287,9 @@ end function rotVector
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function rotTensor2(self,T,active) result(tRot) pure function rotTensor2(self,T,active) result(tRot)
real(pReal), dimension(3,3) :: tRot real(pREAL), dimension(3,3) :: tRot
class(tRotation), intent(in) :: self class(tRotation), intent(in) :: self
real(pReal), intent(in), dimension(3,3) :: T real(pREAL), intent(in), dimension(3,3) :: T
logical, intent(in), optional :: active logical, intent(in), optional :: active
@ -307,17 +307,17 @@ end function rotTensor2
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function rotTensor4(self,T,active) result(tRot) pure function rotTensor4(self,T,active) result(tRot)
real(pReal), dimension(3,3,3,3) :: tRot real(pREAL), dimension(3,3,3,3) :: tRot
class(tRotation), intent(in) :: self class(tRotation), intent(in) :: self
real(pReal), intent(in), dimension(3,3,3,3) :: T real(pREAL), intent(in), dimension(3,3,3,3) :: T
logical, intent(in), optional :: active logical, intent(in), optional :: active
real(pReal), dimension(3,3) :: R real(pREAL), dimension(3,3) :: R
integer :: i,j,k,l,m,n,o,p integer :: i,j,k,l,m,n,o,p
R = merge(transpose(self%asMatrix()),self%asMatrix(),misc_optional(active,.false.)) R = merge(transpose(self%asMatrix()),self%asMatrix(),misc_optional(active,.false.))
tRot = 0.0_pReal tRot = 0.0_pREAL
do i = 1,3;do j = 1,3;do k = 1,3;do l = 1,3 do i = 1,3;do j = 1,3;do k = 1,3;do l = 1,3
do m = 1,3;do n = 1,3;do o = 1,3;do p = 1,3 do m = 1,3;do n = 1,3;do o = 1,3;do p = 1,3
tRot(i,j,k,l) = tRot(i,j,k,l) & tRot(i,j,k,l) = tRot(i,j,k,l) &
@ -334,13 +334,13 @@ end function rotTensor4
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function rotStiffness(self,C,active) result(cRot) pure function rotStiffness(self,C,active) result(cRot)
real(pReal), dimension(6,6) :: cRot real(pREAL), dimension(6,6) :: cRot
class(tRotation), intent(in) :: self class(tRotation), intent(in) :: self
real(pReal), intent(in), dimension(6,6) :: C real(pREAL), intent(in), dimension(6,6) :: C
logical, intent(in), optional :: active logical, intent(in), optional :: active
real(pReal), dimension(3,3) :: R real(pREAL), dimension(3,3) :: R
real(pReal), dimension(6,6) :: M real(pREAL), dimension(6,6) :: M
R = merge(transpose(self%asMatrix()),self%asMatrix(),misc_optional(active,.false.)) R = merge(transpose(self%asMatrix()),self%asMatrix(),misc_optional(active,.false.))
@ -351,11 +351,11 @@ pure function rotStiffness(self,C,active) result(cRot)
R(2,2)*R(3,2), R(1,2)*R(3,2), R(1,2)*R(2,2), & R(2,2)*R(3,2), R(1,2)*R(3,2), R(1,2)*R(2,2), &
R(1,3)**2, R(2,3)**2, R(3,3)**2, & R(1,3)**2, R(2,3)**2, R(3,3)**2, &
R(2,3)*R(3,3), R(1,3)*R(3,3), R(1,3)*R(2,3), & R(2,3)*R(3,3), R(1,3)*R(3,3), R(1,3)*R(2,3), &
2.0_pReal*R(1,2)*R(1,3), 2.0_pReal*R(2,2)*R(2,3), 2.0_pReal*R(3,2)*R(3,3), & 2.0_pREAL*R(1,2)*R(1,3), 2.0_pREAL*R(2,2)*R(2,3), 2.0_pREAL*R(3,2)*R(3,3), &
R(2,2)*R(3,3)+R(2,3)*R(3,2), R(1,2)*R(3,3)+R(1,3)*R(3,2), R(1,2)*R(2,3)+R(1,3)*R(2,2), & R(2,2)*R(3,3)+R(2,3)*R(3,2), R(1,2)*R(3,3)+R(1,3)*R(3,2), R(1,2)*R(2,3)+R(1,3)*R(2,2), &
2.0_pReal*R(1,3)*R(1,1), 2.0_pReal*R(2,3)*R(2,1), 2.0_pReal*R(3,3)*R(3,1), & 2.0_pREAL*R(1,3)*R(1,1), 2.0_pREAL*R(2,3)*R(2,1), 2.0_pREAL*R(3,3)*R(3,1), &
R(2,3)*R(3,1)+R(2,1)*R(3,3), R(1,3)*R(3,1)+R(1,1)*R(3,3), R(1,3)*R(2,1)+R(1,1)*R(2,3), & R(2,3)*R(3,1)+R(2,1)*R(3,3), R(1,3)*R(3,1)+R(1,1)*R(3,3), R(1,3)*R(2,1)+R(1,1)*R(2,3), &
2.0_pReal*R(1,1)*R(1,2), 2.0_pReal*R(2,1)*R(2,2), 2.0_pReal*R(3,1)*R(3,2), & 2.0_pREAL*R(1,1)*R(1,2), 2.0_pREAL*R(2,1)*R(2,2), 2.0_pREAL*R(3,1)*R(3,2), &
R(2,1)*R(3,2)+R(2,2)*R(3,1), R(1,1)*R(3,2)+R(1,2)*R(3,1), R(1,1)*R(2,2)+R(1,2)*R(2,1)],[6,6]) R(2,1)*R(3,2)+R(2,2)*R(3,1), R(1,1)*R(3,2)+R(1,2)*R(3,1), R(1,1)*R(2,2)+R(1,2)*R(2,1)],[6,6])
cRot = matmul(M,matmul(C,transpose(M))) cRot = matmul(M,matmul(C,transpose(M)))
@ -383,27 +383,27 @@ end function misorientation
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function qu2om(qu) result(om) pure function qu2om(qu) result(om)
real(pReal), intent(in), dimension(4) :: qu real(pREAL), intent(in), dimension(4) :: qu
real(pReal), dimension(3,3) :: om real(pREAL), dimension(3,3) :: om
real(pReal) :: qq real(pREAL) :: qq
qq = qu(1)**2-sum(qu(2:4)**2) qq = qu(1)**2-sum(qu(2:4)**2)
om(1,1) = qq+2.0_pReal*qu(2)**2 om(1,1) = qq+2.0_pREAL*qu(2)**2
om(2,2) = qq+2.0_pReal*qu(3)**2 om(2,2) = qq+2.0_pREAL*qu(3)**2
om(3,3) = qq+2.0_pReal*qu(4)**2 om(3,3) = qq+2.0_pREAL*qu(4)**2
om(1,2) = 2.0_pReal*(qu(2)*qu(3)-qu(1)*qu(4)) om(1,2) = 2.0_pREAL*(qu(2)*qu(3)-qu(1)*qu(4))
om(2,3) = 2.0_pReal*(qu(3)*qu(4)-qu(1)*qu(2)) om(2,3) = 2.0_pREAL*(qu(3)*qu(4)-qu(1)*qu(2))
om(3,1) = 2.0_pReal*(qu(4)*qu(2)-qu(1)*qu(3)) om(3,1) = 2.0_pREAL*(qu(4)*qu(2)-qu(1)*qu(3))
om(2,1) = 2.0_pReal*(qu(3)*qu(2)+qu(1)*qu(4)) om(2,1) = 2.0_pREAL*(qu(3)*qu(2)+qu(1)*qu(4))
om(3,2) = 2.0_pReal*(qu(4)*qu(3)+qu(1)*qu(2)) om(3,2) = 2.0_pREAL*(qu(4)*qu(3)+qu(1)*qu(2))
om(1,3) = 2.0_pReal*(qu(2)*qu(4)+qu(1)*qu(3)) om(1,3) = 2.0_pREAL*(qu(2)*qu(4)+qu(1)*qu(3))
if (sign(1.0_pReal,P) < 0.0_pReal) om = transpose(om) if (sign(1.0_pREAL,P) < 0.0_pREAL) om = transpose(om)
om = om/math_det33(om)**(1.0_pReal/3.0_pReal) om = om/math_det33(om)**(1.0_pREAL/3.0_pREAL)
end function qu2om end function qu2om
@ -414,10 +414,10 @@ end function qu2om
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function qu2eu(qu) result(eu) pure function qu2eu(qu) result(eu)
real(pReal), intent(in), dimension(4) :: qu real(pREAL), intent(in), dimension(4) :: qu
real(pReal), dimension(3) :: eu real(pREAL), dimension(3) :: eu
real(pReal) :: q12, q03, chi real(pREAL) :: q12, q03, chi
q03 = qu(1)**2+qu(4)**2 q03 = qu(1)**2+qu(4)**2
@ -425,15 +425,15 @@ pure function qu2eu(qu) result(eu)
chi = sqrt(q03*q12) chi = sqrt(q03*q12)
degenerated: if (dEq0(q12)) then degenerated: if (dEq0(q12)) then
eu = [atan2(-P*2.0_pReal*qu(1)*qu(4),qu(1)**2-qu(4)**2), 0.0_pReal, 0.0_pReal] eu = [atan2(-P*2.0_pREAL*qu(1)*qu(4),qu(1)**2-qu(4)**2), 0.0_pREAL, 0.0_pREAL]
elseif (dEq0(q03)) then elseif (dEq0(q03)) then
eu = [atan2( 2.0_pReal*qu(2)*qu(3),qu(2)**2-qu(3)**2), PI, 0.0_pReal] eu = [atan2( 2.0_pREAL*qu(2)*qu(3),qu(2)**2-qu(3)**2), PI, 0.0_pREAL]
else degenerated else degenerated
eu = [atan2((-P*qu(1)*qu(3)+qu(2)*qu(4))*chi, (-P*qu(1)*qu(2)-qu(3)*qu(4))*chi ), & eu = [atan2((-P*qu(1)*qu(3)+qu(2)*qu(4))*chi, (-P*qu(1)*qu(2)-qu(3)*qu(4))*chi ), &
atan2( 2.0_pReal*chi, q03-q12 ), & atan2( 2.0_pREAL*chi, q03-q12 ), &
atan2(( P*qu(1)*qu(3)+qu(2)*qu(4))*chi, (-P*qu(1)*qu(2)+qu(3)*qu(4))*chi )] atan2(( P*qu(1)*qu(3)+qu(2)*qu(4))*chi, (-P*qu(1)*qu(2)+qu(3)*qu(4))*chi )]
end if degenerated end if degenerated
where(sign(1.0_pReal,eu)<0.0_pReal) eu = mod(eu+TAU,[TAU,PI,TAU]) where(sign(1.0_pREAL,eu)<0.0_pREAL) eu = mod(eu+TAU,[TAU,PI,TAU])
end function qu2eu end function qu2eu
@ -444,17 +444,17 @@ end function qu2eu
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function qu2ax(qu) result(ax) pure function qu2ax(qu) result(ax)
real(pReal), intent(in), dimension(4) :: qu real(pREAL), intent(in), dimension(4) :: qu
real(pReal), dimension(4) :: ax real(pREAL), dimension(4) :: ax
real(pReal) :: omega, s real(pREAL) :: omega, s
if (dEq0(sum(qu(2:4)**2))) then if (dEq0(sum(qu(2:4)**2))) then
ax = [ 0.0_pReal, 0.0_pReal, 1.0_pReal, 0.0_pReal ] ! axis = [001] ax = [ 0.0_pREAL, 0.0_pREAL, 1.0_pREAL, 0.0_pREAL ] ! axis = [001]
elseif (dNeq0(qu(1))) then elseif (dNeq0(qu(1))) then
s = sign(1.0_pReal,qu(1))/norm2(qu(2:4)) s = sign(1.0_pREAL,qu(1))/norm2(qu(2:4))
omega = 2.0_pReal * acos(math_clip(qu(1),-1.0_pReal,1.0_pReal)) omega = 2.0_pREAL * acos(math_clip(qu(1),-1.0_pREAL,1.0_pREAL))
ax = [ qu(2)*s, qu(3)*s, qu(4)*s, omega ] ax = [ qu(2)*s, qu(3)*s, qu(4)*s, omega ]
else else
ax = [ qu(2), qu(3), qu(4), PI ] ax = [ qu(2), qu(3), qu(4), PI ]
@ -470,29 +470,29 @@ end function qu2ax
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function om2qu(om) result(qu) pure function om2qu(om) result(qu)
real(pReal), intent(in), dimension(3,3) :: om real(pREAL), intent(in), dimension(3,3) :: om
real(pReal), dimension(4) :: qu real(pREAL), dimension(4) :: qu
real(pReal) :: trace,s real(pREAL) :: trace,s
trace = math_trace33(om) trace = math_trace33(om)
if (trace > 0.0_pReal) then if (trace > 0.0_pREAL) then
s = 0.5_pReal / sqrt(trace+1.0_pReal) s = 0.5_pREAL / sqrt(trace+1.0_pREAL)
qu = [0.25_pReal/s, (om(3,2)-om(2,3))*s,(om(1,3)-om(3,1))*s,(om(2,1)-om(1,2))*s] qu = [0.25_pREAL/s, (om(3,2)-om(2,3))*s,(om(1,3)-om(3,1))*s,(om(2,1)-om(1,2))*s]
else else
if ( om(1,1) > om(2,2) .and. om(1,1) > om(3,3) ) then if ( om(1,1) > om(2,2) .and. om(1,1) > om(3,3) ) then
s = 2.0_pReal * sqrt( 1.0_pReal + om(1,1) - om(2,2) - om(3,3)) s = 2.0_pREAL * sqrt( 1.0_pREAL + om(1,1) - om(2,2) - om(3,3))
qu = [ (om(3,2) - om(2,3)) /s,0.25_pReal * s,(om(1,2) + om(2,1)) / s,(om(1,3) + om(3,1)) / s] qu = [ (om(3,2) - om(2,3)) /s,0.25_pREAL * s,(om(1,2) + om(2,1)) / s,(om(1,3) + om(3,1)) / s]
elseif (om(2,2) > om(3,3)) then elseif (om(2,2) > om(3,3)) then
s = 2.0_pReal * sqrt( 1.0_pReal + om(2,2) - om(1,1) - om(3,3)) s = 2.0_pREAL * sqrt( 1.0_pREAL + om(2,2) - om(1,1) - om(3,3))
qu = [ (om(1,3) - om(3,1)) /s,(om(1,2) + om(2,1)) / s,0.25_pReal * s,(om(2,3) + om(3,2)) / s] qu = [ (om(1,3) - om(3,1)) /s,(om(1,2) + om(2,1)) / s,0.25_pREAL * s,(om(2,3) + om(3,2)) / s]
else else
s = 2.0_pReal * sqrt( 1.0_pReal + om(3,3) - om(1,1) - om(2,2) ) s = 2.0_pREAL * sqrt( 1.0_pREAL + om(3,3) - om(1,1) - om(2,2) )
qu = [ (om(2,1) - om(1,2)) /s,(om(1,3) + om(3,1)) / s,(om(2,3) + om(3,2)) / s,0.25_pReal * s] qu = [ (om(2,1) - om(1,2)) /s,(om(1,3) + om(3,1)) / s,(om(2,3) + om(3,2)) / s,0.25_pREAL * s]
end if end if
end if end if
if (sign(1.0_pReal,qu(1))<0.0_pReal) qu =-1.0_pReal * qu if (sign(1.0_pREAL,qu(1))<0.0_pREAL) qu =-1.0_pREAL * qu
qu(2:4) = merge(qu(2:4),qu(2:4)*P,dEq0(qu(2:4))) qu(2:4) = merge(qu(2:4),qu(2:4)*P,dEq0(qu(2:4)))
qu = qu/norm2(qu) qu = qu/norm2(qu)
@ -506,21 +506,21 @@ end function om2qu
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function om2eu(om) result(eu) pure function om2eu(om) result(eu)
real(pReal), intent(in), dimension(3,3) :: om real(pREAL), intent(in), dimension(3,3) :: om
real(pReal), dimension(3) :: eu real(pREAL), dimension(3) :: eu
real(pReal) :: zeta real(pREAL) :: zeta
if (dNeq(abs(om(3,3)),1.0_pReal,1.e-8_pReal)) then if (dNeq(abs(om(3,3)),1.0_pREAL,1.e-8_pREAL)) then
zeta = 1.0_pReal/sqrt(math_clip(1.0_pReal-om(3,3)**2,1e-64_pReal,1.0_pReal)) zeta = 1.0_pREAL/sqrt(math_clip(1.0_pREAL-om(3,3)**2,1e-64_pREAL,1.0_pREAL))
eu = [atan2(om(3,1)*zeta,-om(3,2)*zeta), & eu = [atan2(om(3,1)*zeta,-om(3,2)*zeta), &
acos(math_clip(om(3,3),-1.0_pReal,1.0_pReal)), & acos(math_clip(om(3,3),-1.0_pREAL,1.0_pREAL)), &
atan2(om(1,3)*zeta, om(2,3)*zeta)] atan2(om(1,3)*zeta, om(2,3)*zeta)]
else else
eu = [atan2(om(1,2),om(1,1)), 0.5_pReal*PI*(1.0_pReal-om(3,3)),0.0_pReal ] eu = [atan2(om(1,2),om(1,1)), 0.5_pREAL*PI*(1.0_pREAL-om(3,3)),0.0_pREAL ]
end if end if
where(abs(eu) < 1.e-8_pReal) eu = 0.0_pReal where(abs(eu) < 1.e-8_pREAL) eu = 0.0_pREAL
where(sign(1.0_pReal,eu)<0.0_pReal) eu = mod(eu+TAU,[TAU,PI,TAU]) where(sign(1.0_pREAL,eu)<0.0_pREAL) eu = mod(eu+TAU,[TAU,PI,TAU])
end function om2eu end function om2eu
@ -531,28 +531,28 @@ end function om2eu
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
function om2ax(om) result(ax) function om2ax(om) result(ax)
real(pReal), intent(in), dimension(3,3) :: om real(pREAL), intent(in), dimension(3,3) :: om
real(pReal), dimension(4) :: ax real(pREAL), dimension(4) :: ax
real(pReal) :: t real(pREAL) :: t
real(pReal), dimension(3) :: Wr, Wi real(pREAL), dimension(3) :: Wr, Wi
real(pReal), dimension((64+2)*3) :: work real(pREAL), dimension((64+2)*3) :: work
real(pReal), dimension(3,3) :: VR, devNull, om_ real(pREAL), dimension(3,3) :: VR, devNull, om_
integer :: ierr, i integer :: ierr, i
om_ = om om_ = om
! first get the rotation angle ! first get the rotation angle
t = 0.5_pReal * (math_trace33(om) - 1.0_pReal) t = 0.5_pREAL * (math_trace33(om) - 1.0_pREAL)
ax(4) = acos(math_clip(t,-1.0_pReal,1.0_pReal)) ax(4) = acos(math_clip(t,-1.0_pREAL,1.0_pREAL))
if (dEq0(ax(4))) then if (dEq0(ax(4))) then
ax(1:3) = [ 0.0_pReal, 0.0_pReal, 1.0_pReal ] ax(1:3) = [ 0.0_pREAL, 0.0_pREAL, 1.0_pREAL ]
else else
call dgeev('N','V',3,om_,3,Wr,Wi,devNull,3,VR,3,work,size(work,1),ierr) call dgeev('N','V',3,om_,3,Wr,Wi,devNull,3,VR,3,work,size(work,1),ierr)
if (ierr /= 0) error stop 'LAPACK error' if (ierr /= 0) error stop 'LAPACK error'
i = findloc(cEq(cmplx(Wr,Wi,pReal),cmplx(1.0_pReal,0.0_pReal,pReal),tol=1.0e-14_pReal),.true.,dim=1) !find eigenvalue (1,0) i = findloc(cEq(cmplx(Wr,Wi,pREAL),cmplx(1.0_pREAL,0.0_pREAL,pREAL),tol=1.0e-14_pREAL),.true.,dim=1) !find eigenvalue (1,0)
if (i == 0) error stop 'om2ax conversion failed' if (i == 0) error stop 'om2ax conversion failed'
ax(1:3) = VR(1:3,i) ax(1:3) = VR(1:3,i)
where ( dNeq0([om(2,3)-om(3,2), om(3,1)-om(1,3), om(1,2)-om(2,1)])) & where ( dNeq0([om(2,3)-om(3,2), om(3,1)-om(1,3), om(1,2)-om(2,1)])) &
@ -568,13 +568,13 @@ end function om2ax
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function eu2qu(eu) result(qu) pure function eu2qu(eu) result(qu)
real(pReal), intent(in), dimension(3) :: eu real(pREAL), intent(in), dimension(3) :: eu
real(pReal), dimension(4) :: qu real(pREAL), dimension(4) :: qu
real(pReal), dimension(3) :: ee real(pREAL), dimension(3) :: ee
real(pReal) :: cPhi, sPhi real(pREAL) :: cPhi, sPhi
ee = 0.5_pReal*eu ee = 0.5_pREAL*eu
cPhi = cos(ee(2)) cPhi = cos(ee(2))
sPhi = sin(ee(2)) sPhi = sin(ee(2))
@ -583,7 +583,7 @@ pure function eu2qu(eu) result(qu)
-P*sPhi*cos(ee(1)-ee(3)), & -P*sPhi*cos(ee(1)-ee(3)), &
-P*sPhi*sin(ee(1)-ee(3)), & -P*sPhi*sin(ee(1)-ee(3)), &
-P*cPhi*sin(ee(1)+ee(3))] -P*cPhi*sin(ee(1)+ee(3))]
if (sign(1.0_pReal,qu(1)) < 0.0_pReal) qu = qu * (-1.0_pReal) if (sign(1.0_pREAL,qu(1)) < 0.0_pREAL) qu = qu * (-1.0_pREAL)
end function eu2qu end function eu2qu
@ -594,10 +594,10 @@ end function eu2qu
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function eu2om(eu) result(om) pure function eu2om(eu) result(om)
real(pReal), intent(in), dimension(3) :: eu real(pREAL), intent(in), dimension(3) :: eu
real(pReal), dimension(3,3) :: om real(pREAL), dimension(3,3) :: om
real(pReal), dimension(3) :: c, s real(pREAL), dimension(3) :: c, s
c = cos(eu) c = cos(eu)
@ -613,7 +613,7 @@ pure function eu2om(eu) result(om)
om(2,3) = c(3)*s(2) om(2,3) = c(3)*s(2)
om(3,3) = c(2) om(3,3) = c(2)
where(abs(om)<1.0e-12_pReal) om = 0.0_pReal where(abs(om)<1.0e-12_pREAL) om = 0.0_pREAL
end function eu2om end function eu2om
@ -624,25 +624,25 @@ end function eu2om
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function eu2ax(eu) result(ax) pure function eu2ax(eu) result(ax)
real(pReal), intent(in), dimension(3) :: eu real(pREAL), intent(in), dimension(3) :: eu
real(pReal), dimension(4) :: ax real(pREAL), dimension(4) :: ax
real(pReal) :: t, delta, tau, alpha, sigma real(pREAL) :: t, delta, tau, alpha, sigma
t = tan(eu(2)*0.5_pReal) t = tan(eu(2)*0.5_pREAL)
sigma = 0.5_pReal*(eu(1)+eu(3)) sigma = 0.5_pREAL*(eu(1)+eu(3))
delta = 0.5_pReal*(eu(1)-eu(3)) delta = 0.5_pREAL*(eu(1)-eu(3))
tau = sqrt(t**2+sin(sigma)**2) tau = sqrt(t**2+sin(sigma)**2)
alpha = merge(PI, 2.0_pReal*atan(tau/cos(sigma)), dEq(sigma,PI*0.5_pReal,tol=1.0e-15_pReal)) alpha = merge(PI, 2.0_pREAL*atan(tau/cos(sigma)), dEq(sigma,PI*0.5_pREAL,tol=1.0e-15_pREAL))
if (dEq0(alpha)) then ! return a default identity axis-angle pair if (dEq0(alpha)) then ! return a default identity axis-angle pair
ax = [ 0.0_pReal, 0.0_pReal, 1.0_pReal, 0.0_pReal ] ax = [ 0.0_pREAL, 0.0_pREAL, 1.0_pREAL, 0.0_pREAL ]
else else
ax(1:3) = -P/tau * [ t*cos(delta), t*sin(delta), sin(sigma) ] ! passive axis-angle pair so a minus sign in front ax(1:3) = -P/tau * [ t*cos(delta), t*sin(delta), sin(sigma) ] ! passive axis-angle pair so a minus sign in front
ax(4) = alpha ax(4) = alpha
if (sign(1.0_pReal,alpha) < 0.0_pReal) ax = -ax ! ensure alpha is positive if (sign(1.0_pREAL,alpha) < 0.0_pREAL) ax = -ax ! ensure alpha is positive
end if end if
end function eu2ax end function eu2ax
@ -654,17 +654,17 @@ end function eu2ax
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function ax2qu(ax) result(qu) pure function ax2qu(ax) result(qu)
real(pReal), intent(in), dimension(4) :: ax real(pREAL), intent(in), dimension(4) :: ax
real(pReal), dimension(4) :: qu real(pREAL), dimension(4) :: qu
real(pReal) :: c, s real(pREAL) :: c, s
if (dEq0(ax(4))) then if (dEq0(ax(4))) then
qu = [ 1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal ] qu = [ 1.0_pREAL, 0.0_pREAL, 0.0_pREAL, 0.0_pREAL ]
else else
c = cos(ax(4)*0.5_pReal) c = cos(ax(4)*0.5_pREAL)
s = sin(ax(4)*0.5_pReal) s = sin(ax(4)*0.5_pREAL)
qu = [ c, ax(1)*s, ax(2)*s, ax(3)*s ] qu = [ c, ax(1)*s, ax(2)*s, ax(3)*s ]
end if end if
@ -677,15 +677,15 @@ end function ax2qu
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function ax2om(ax) result(om) pure function ax2om(ax) result(om)
real(pReal), intent(in), dimension(4) :: ax real(pREAL), intent(in), dimension(4) :: ax
real(pReal), dimension(3,3) :: om real(pREAL), dimension(3,3) :: om
real(pReal) :: q, c, s, omc real(pREAL) :: q, c, s, omc
c = cos(ax(4)) c = cos(ax(4))
s = sin(ax(4)) s = sin(ax(4))
omc = 1.0_pReal-c omc = 1.0_pREAL-c
om(1,1) = ax(1)**2*omc + c om(1,1) = ax(1)**2*omc + c
om(2,2) = ax(2)**2*omc + c om(2,2) = ax(2)**2*omc + c
@ -703,7 +703,7 @@ pure function ax2om(ax) result(om)
om(3,1) = q + s*ax(2) om(3,1) = q + s*ax(2)
om(1,3) = q - s*ax(2) om(1,3) = q - s*ax(2)
if (P > 0.0_pReal) om = transpose(om) if (P > 0.0_pREAL) om = transpose(om)
end function ax2om end function ax2om
@ -714,8 +714,8 @@ end function ax2om
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function ax2eu(ax) result(eu) pure function ax2eu(ax) result(eu)
real(pReal), intent(in), dimension(4) :: ax real(pREAL), intent(in), dimension(4) :: ax
real(pReal), dimension(3) :: eu real(pREAL), dimension(3) :: eu
eu = om2eu(ax2om(ax)) eu = om2eu(ax2om(ax))
@ -728,8 +728,8 @@ end function ax2eu
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function multiplyQuaternion(qu1,qu2) pure function multiplyQuaternion(qu1,qu2)
real(pReal), dimension(4), intent(in) :: qu1, qu2 real(pREAL), dimension(4), intent(in) :: qu1, qu2
real(pReal), dimension(4) :: multiplyQuaternion real(pREAL), dimension(4) :: multiplyQuaternion
multiplyQuaternion(1) = qu1(1)*qu2(1) - qu1(2)*qu2(2) - qu1(3)*qu2(3) - qu1(4)*qu2(4) multiplyQuaternion(1) = qu1(1)*qu2(1) - qu1(2)*qu2(2) - qu1(3)*qu2(3) - qu1(4)*qu2(4)
@ -745,8 +745,8 @@ end function multiplyQuaternion
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function conjugateQuaternion(qu) pure function conjugateQuaternion(qu)
real(pReal), dimension(4), intent(in) :: qu real(pREAL), dimension(4), intent(in) :: qu
real(pReal), dimension(4) :: conjugateQuaternion real(pREAL), dimension(4) :: conjugateQuaternion
conjugateQuaternion = [qu(1), -qu(2), -qu(3), -qu(4)] conjugateQuaternion = [qu(1), -qu(2), -qu(3), -qu(4)]
@ -760,36 +760,36 @@ end function conjugateQuaternion
subroutine selfTest() subroutine selfTest()
type(tRotation) :: R type(tRotation) :: R
real(pReal), dimension(4) :: qu real(pREAL), dimension(4) :: qu
real(pReal), dimension(3) :: x, eu, v3 real(pREAL), dimension(3) :: x, eu, v3
real(pReal), dimension(3,3) :: om, t33 real(pREAL), dimension(3,3) :: om, t33
real(pReal), dimension(3,3,3,3) :: t3333 real(pREAL), dimension(3,3,3,3) :: t3333
real(pReal), dimension(6,6) :: C real(pREAL), dimension(6,6) :: C
real(pReal) :: A,B real(pREAL) :: A,B
integer :: i integer :: i
do i = 1, 20 do i = 1, 20
if (i==1) then if (i==1) then
qu = [1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal] qu = [1.0_pREAL, 0.0_pREAL, 0.0_pREAL, 0.0_pREAL]
elseif (i==2) then elseif (i==2) then
qu = [1.0_pReal,-0.0_pReal,-0.0_pReal,-0.0_pReal] qu = [1.0_pREAL,-0.0_pREAL,-0.0_pREAL,-0.0_pREAL]
elseif (i==3) then elseif (i==3) then
qu = [0.0_pReal, 1.0_pReal, 0.0_pReal, 0.0_pReal] qu = [0.0_pREAL, 1.0_pREAL, 0.0_pREAL, 0.0_pREAL]
elseif (i==4) then elseif (i==4) then
qu = [0.0_pReal,0.0_pReal,1.0_pReal,0.0_pReal] qu = [0.0_pREAL,0.0_pREAL,1.0_pREAL,0.0_pREAL]
elseif (i==5) then elseif (i==5) then
qu = [0.0_pReal, 0.0_pReal, 0.0_pReal, 1.0_pReal] qu = [0.0_pREAL, 0.0_pREAL, 0.0_pREAL, 1.0_pREAL]
else else
call random_number(x) call random_number(x)
A = sqrt(x(3)) A = sqrt(x(3))
B = sqrt(1-0_pReal -x(3)) B = sqrt(1-0_pREAL -x(3))
qu = [cos(TAU*x(1))*A,& qu = [cos(TAU*x(1))*A,&
sin(TAU*x(2))*B,& sin(TAU*x(2))*B,&
cos(TAU*x(2))*B,& cos(TAU*x(2))*B,&
sin(TAU*x(1))*A] sin(TAU*x(1))*A]
if (qu(1)<0.0_pReal) qu = qu * (-1.0_pReal) if (qu(1)<0.0_pREAL) qu = qu * (-1.0_pREAL)
end if end if
@ -807,24 +807,24 @@ subroutine selfTest()
call R%fromMatrix(om) call R%fromMatrix(om)
call random_number(v3) call random_number(v3)
if (any(dNeq(R%rotVector(R%rotVector(v3),active=.true.),v3,1.0e-12_pReal))) & if (any(dNeq(R%rotVector(R%rotVector(v3),active=.true.),v3,1.0e-12_pREAL))) &
error stop 'rotVector' error stop 'rotVector'
call random_number(t33) call random_number(t33)
if (any(dNeq(R%rotTensor2(R%rotTensor2(t33),active=.true.),t33,1.0e-12_pReal))) & if (any(dNeq(R%rotTensor2(R%rotTensor2(t33),active=.true.),t33,1.0e-12_pREAL))) &
error stop 'rotTensor2' error stop 'rotTensor2'
call random_number(t3333) call random_number(t3333)
if (any(dNeq(R%rotTensor4(R%rotTensor4(t3333),active=.true.),t3333,1.0e-12_pReal))) & if (any(dNeq(R%rotTensor4(R%rotTensor4(t3333),active=.true.),t3333,1.0e-12_pREAL))) &
error stop 'rotTensor4' error stop 'rotTensor4'
call random_number(C) call random_number(C)
C = C+transpose(C) C = C+transpose(C)
if (any(dNeq(R%rotStiffness(C), & if (any(dNeq(R%rotStiffness(C), &
math_3333toVoigt66_stiffness(R%rotate(math_Voigt66to3333_stiffness(C))),1.0e-12_pReal))) & math_3333toVoigt66_stiffness(R%rotate(math_Voigt66to3333_stiffness(C))),1.0e-12_pREAL))) &
error stop 'rotStiffness' error stop 'rotStiffness'
call R%fromQuaternion(qu * (1.0_pReal + merge(+5.e-9_pReal,-5.e-9_pReal, mod(i,2) == 0))) ! allow reasonable tolerance for ASCII/YAML call R%fromQuaternion(qu * (1.0_pREAL + merge(+5.e-9_pREAL,-5.e-9_pREAL, mod(i,2) == 0))) ! allow reasonable tolerance for ASCII/YAML
end do end do
@ -832,12 +832,12 @@ subroutine selfTest()
pure recursive function quaternion_equal(qu1,qu2) result(ok) pure recursive function quaternion_equal(qu1,qu2) result(ok)
real(pReal), intent(in), dimension(4) :: qu1,qu2 real(pREAL), intent(in), dimension(4) :: qu1,qu2
logical :: ok logical :: ok
ok = all(dEq(qu1,qu2,1.0e-7_pReal)) ok = all(dEq(qu1,qu2,1.0e-7_pREAL))
if (dEq0(qu1(1),1.0e-12_pReal)) & if (dEq0(qu1(1),1.0e-12_pREAL)) &
ok = ok .or. all(dEq(-1.0_pReal*qu1,qu2,1.0e-7_pReal)) ok = ok .or. all(dEq(-1.0_pREAL*qu1,qu2,1.0e-7_pREAL))
end function quaternion_equal end function quaternion_equal

30
src/tables.f90
View File

@ -13,7 +13,7 @@ module tables
private private
type, public :: tTable type, public :: tTable
real(pReal), dimension(:), allocatable :: x,y real(pREAL), dimension(:), allocatable :: x,y
contains contains
procedure, public :: at => eval procedure, public :: at => eval
end type tTable end type tTable
@ -47,7 +47,7 @@ end subroutine tables_init
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
function table_from_values(x,y) result(t) function table_from_values(x,y) result(t)
real(pReal), dimension(:), intent(in) :: x,y real(pREAL), dimension(:), intent(in) :: x,y
type(tTable) :: t type(tTable) :: t
@ -55,7 +55,7 @@ function table_from_values(x,y) result(t)
if (size(y) < 1) call IO_error(603,ext_msg='missing tabulated y data') if (size(y) < 1) call IO_error(603,ext_msg='missing tabulated y data')
if (size(x) /= size(y)) call IO_error(603,ext_msg='shape mismatch in tabulated data') if (size(x) /= size(y)) call IO_error(603,ext_msg='shape mismatch in tabulated data')
if (size(x) /= 1) then if (size(x) /= 1) then
if (any(x(2:size(x))-x(1:size(x)-1) <= 0.0_pReal)) & if (any(x(2:size(x))-x(1:size(x)-1) <= 0.0_pREAL)) &
call IO_error(603,ext_msg='ordinate data does not increase monotonically') call IO_error(603,ext_msg='ordinate data does not increase monotonically')
end if end if
@ -86,8 +86,8 @@ end function table_from_dict
pure function eval(self,x) result(y) pure function eval(self,x) result(y)
class(tTable), intent(in) :: self class(tTable), intent(in) :: self
real(pReal), intent(in) :: x real(pREAL), intent(in) :: x
real(pReal) :: y real(pREAL) :: y
integer :: i integer :: i
@ -109,25 +109,25 @@ end function eval
subroutine selfTest() subroutine selfTest()
type(tTable) :: t type(tTable) :: t
real(pReal), dimension(*), parameter :: & real(pREAL), dimension(*), parameter :: &
x = real([ 1., 2., 3., 4.],pReal), & x = real([ 1., 2., 3., 4.],pREAL), &
y = real([ 1., 3., 2.,-2.],pReal), & y = real([ 1., 3., 2.,-2.],pREAL), &
x_eval = real([ 0.0, 0.5, 1.0, 1.5, 2.0, 2.5, 3.0, 3.5, 4.0, 4.5, 5.0],pReal), & x_eval = real([ 0.0, 0.5, 1.0, 1.5, 2.0, 2.5, 3.0, 3.5, 4.0, 4.5, 5.0],pREAL), &
y_true = real([-1.0, 0.0, 1.0, 2.0, 3.0, 2.5 ,2.0, 0.0,-2.0,-4.0,-6.0],pReal) y_true = real([-1.0, 0.0, 1.0, 2.0, 3.0, 2.5 ,2.0, 0.0,-2.0,-4.0,-6.0],pREAL)
integer :: i integer :: i
type(tDict), pointer :: dict type(tDict), pointer :: dict
type(tList), pointer :: l_x, l_y type(tList), pointer :: l_x, l_y
real(pReal) :: r real(pREAL) :: r
call random_number(r) call random_number(r)
t = table(real([0.],pReal),real([r],pReal)) t = table(real([0.],pREAL),real([r],pREAL))
if (dNeq(r,t%at(r),1.0e-9_pReal)) error stop 'table eval/mono' if (dNeq(r,t%at(r),1.0e-9_pREAL)) error stop 'table eval/mono'
r = r-0.5_pReal r = r-0.5_pREAL
t = table(x+r,y) t = table(x+r,y)
do i = 1, size(x_eval) do i = 1, size(x_eval)
if (dNeq(y_true(i),t%at(x_eval(i)+r),1.0e-9_pReal)) error stop 'table eval/values' if (dNeq(y_true(i),t%at(x_eval(i)+r),1.0e-9_pREAL)) error stop 'table eval/values'
end do end do
l_x => YAML_parse_str_asList('[1, 2, 3, 4]'//IO_EOL) l_x => YAML_parse_str_asList('[1, 2, 3, 4]'//IO_EOL)

2
src/test/test_HDF5_utilities.f90
View File

@ -22,7 +22,7 @@ end subroutine HDF5_utilities_test
subroutine test_read_write() subroutine test_read_write()
integer(HID_T) :: f integer(HID_T) :: f
real(pReal), dimension(3) :: d_in,d_out real(pREAL), dimension(3) :: d_in,d_out
call random_number(d_in) call random_number(d_in)