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

Merge branch '289-consistent-name-for-base-datatypes-in-fortran' into 'development' 

Resolve "consistent name for base datatypes in Fortran"

Closes #289

See merge request damask/DAMASK!761
This commit is contained in:
Philip Eisenlohr 2023-06-06 17:32:19 +00:00
parent fd55fe2b9f 11530c19bb
commit 58ee3312c7
64 changed files with 3359 additions and 3359 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/CLI.f90
View File

@ -42,7 +42,7 @@ subroutine CLI_init
-- UNSUPPORTED PETSc VERSION --- UNSUPPORTED PETSc VERSION --- UNSUPPORTED PETSc VERSION ---
#endif
character(len=pPathLen*3+pStringLen) :: &
character(len=pPathLen*3+pSTRLEN) :: &
commandLine !< command line call as string
character(len=pPathLen) :: &
arg, & !< individual argument

40
src/HDF5_utilities.f90
View File

@ -28,7 +28,7 @@ module HDF5_utilities
private
!--------------------------------------------------------------------------------------------------
!> @brief Read integer or float data of defined shape from file.
!> @brief Read integer or real data of defined shape from file.
!> @details for parallel IO, all dimension except for the last need to match
!--------------------------------------------------------------------------------------------------
interface HDF5_read
@ -135,8 +135,8 @@ subroutine HDF5_utilities_init()
call H5Tget_size_f(H5T_NATIVE_DOUBLE,typeSize, hdferr)
call HDF5_chkerr(hdferr)
if (int(storage_size(0.0_pReal),SIZE_T)/=typeSize*8) &
error stop 'pReal does not match H5T_NATIVE_DOUBLE'
if (int(storage_size(0.0_pREAL),SIZE_T)/=typeSize*8) &
error stop 'pREAL does not match H5T_NATIVE_DOUBLE'
call H5get_libversion_f(HDF5_major,HDF5_minor,HDF5_release,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
character(len=*), intent(in) :: attrLabel
real(pReal), intent(in) :: attrValue
real(pREAL), intent(in) :: attrValue
character(len=*), intent(in), optional :: path
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
character(len=*), intent(in) :: attrLabel
real(pReal), intent(in), dimension(:) :: attrValue
real(pREAL), intent(in), dimension(:) :: attrValue
character(len=*), intent(in), optional :: path
integer(HSIZE_T),dimension(1) :: array_size
@ -640,7 +640,7 @@ end subroutine HDF5_setLink
!--------------------------------------------------------------------------------------------------
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
character(len=*), intent(in) :: datasetName !< name of the dataset in the file
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)
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
character(len=*), intent(in) :: datasetName !< name of the dataset in the file
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)
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
character(len=*), intent(in) :: datasetName !< name of the dataset in the file
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)
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
character(len=*), intent(in) :: datasetName !< name of the dataset in the file
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)
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
character(len=*), intent(in) :: datasetName !< name of the dataset in the file
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)
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
character(len=*), intent(in) :: datasetName !< name of the dataset in the file
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)
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
character(len=*), intent(in) :: datasetName !< name of the dataset in the file
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)
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
character(len=*), intent(in) :: datasetName !< name of the dataset in the file
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)
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
character(len=*), intent(in) :: datasetName !< name of the dataset in the file
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)
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
character(len=*), intent(in) :: datasetName !< name of the dataset in the file
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)
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
character(len=*), intent(in) :: datasetName !< name of the dataset in the file
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)
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
character(len=*), intent(in) :: datasetName !< name of the dataset in the file
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)
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
character(len=*), intent(in) :: datasetName !< name of the dataset in the file
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)
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
character(len=*), intent(in) :: datasetName !< name of the dataset in the file
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)
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
character(len=*), intent(in) :: datasetName !< name of the dataset in the file
logical, intent(in), optional :: parallel !< dataset is distributed over multiple processes

244
src/IO.f90
View File

@ -32,16 +32,16 @@ module IO
IO_readlines, &
IO_isBlank, &
IO_wrapLines, &
IO_stringPos, &
IO_stringValue, &
IO_strPos, &
IO_strValue, &
IO_intValue, &
IO_floatValue, &
IO_realValue, &
IO_lc, &
IO_rmComment, &
IO_intAsString, &
IO_stringAsInt, &
IO_stringAsFloat, &
IO_stringAsBool, &
IO_intAsStr, &
IO_strAsInt, &
IO_strAsReal, &
IO_strAsBool, &
IO_error, &
IO_warning, &
IO_STDOUT
@ -67,9 +67,9 @@ end subroutine IO_init
function IO_readlines(fileName) result(fileContent)
character(len=*), intent(in) :: fileName
character(len=pStringLen), dimension(:), allocatable :: fileContent !< file content, separated per lines
character(len=pSTRLEN), dimension(:), allocatable :: fileContent !< file content, separated per lines
character(len=pStringLen) :: line
character(len=pSTRLEN) :: line
character(len=:), allocatable :: rawData
integer :: &
startPos, endPos, &
@ -90,8 +90,8 @@ function IO_readlines(fileName) result(fileContent)
l = 1
do while (l <= N_lines)
endPos = startPos + scan(rawData(startPos:),IO_EOL) - 2
if (endPos - startPos > pStringLen-1) then
line = rawData(startPos:startPos+pStringLen-1)
if (endPos - startPos > pSTRLEN-1) then
line = rawData(startPos:startPos+pSTRLEN-1)
if (.not. warned) then
call IO_warning(207,trim(fileName),label1='line',ID1=l)
warned = .true.
@ -147,15 +147,15 @@ end function IO_read
!--------------------------------------------------------------------------------------------------
!> @brief Identifiy strings without content.
!--------------------------------------------------------------------------------------------------
logical pure function IO_isBlank(string)
logical pure function IO_isBlank(str)
character(len=*), intent(in) :: string !< string to check for content
character(len=*), intent(in) :: str !< string to check for content
integer :: posNonBlank
posNonBlank = verify(string,IO_WHITESPACE)
IO_isBlank = posNonBlank == 0 .or. posNonBlank == scan(string,IO_COMMENT)
posNonBlank = verify(str,IO_WHITESPACE)
IO_isBlank = posNonBlank == 0 .or. posNonBlank == scan(str,IO_COMMENT)
end function IO_isBlank
@ -163,9 +163,9 @@ end function IO_isBlank
!--------------------------------------------------------------------------------------------------
!> @brief Insert EOL at separator trying to keep line length below limit.
!--------------------------------------------------------------------------------------------------
function IO_wrapLines(string,separator,filler,length)
function IO_wrapLines(str,separator,filler,length)
character(len=*), intent(in) :: string !< string to split
character(len=*), intent(in) :: str !< string to split
character, optional, intent(in) :: separator !< line breaks are possible after this character, defaults to ','
character(len=*), optional, intent(in) :: filler !< character(s) to insert after line break, defaults to none
integer, optional, intent(in) :: length !< (soft) line limit, defaults to 80
@ -175,18 +175,18 @@ function IO_wrapLines(string,separator,filler,length)
integer :: i,s,e
i = index(string,misc_optional(separator,','))
i = index(str,misc_optional(separator,','))
if (i == 0) then
IO_wrapLines = string
IO_wrapLines = str
else
pos_sep = [0]
s = i
do while (i /= 0 .and. s < len(string))
do while (i /= 0 .and. s < len(str))
pos_sep = [pos_sep,s]
i = index(string(s+1:),misc_optional(separator,','))
i = index(str(s+1:),misc_optional(separator,','))
s = s + i
end do
pos_sep = [pos_sep,len(string)]
pos_sep = [pos_sep,len(str)]
pos_split = emptyIntArray
s = 1
@ -194,12 +194,12 @@ function IO_wrapLines(string,separator,filler,length)
IO_wrapLines = ''
do while (e < size(pos_sep))
if (pos_sep(e+1) - pos_sep(s) >= misc_optional(length,80)) then
IO_wrapLines = IO_wrapLines//adjustl(string(pos_sep(s)+1:pos_sep(e)))//IO_EOL//misc_optional(filler,'')
IO_wrapLines = IO_wrapLines//adjustl(str(pos_sep(s)+1:pos_sep(e)))//IO_EOL//misc_optional(filler,'')
s = e
end if
e = e + 1
end do
IO_wrapLines = IO_wrapLines//adjustl(string(pos_sep(s)+1:))
IO_wrapLines = IO_wrapLines//adjustl(str(pos_sep(s)+1:))
end if
end function IO_wrapLines
@ -211,87 +211,87 @@ end function IO_wrapLines
!! Array size is dynamically adjusted to number of chunks found in string
!! IMPORTANT: first element contains number of chunks!
!--------------------------------------------------------------------------------------------------
pure function IO_stringPos(string)
pure function IO_strPos(str)
character(len=*), intent(in) :: string !< string in which chunk positions are searched for
integer, dimension(:), allocatable :: IO_stringPos
character(len=*), intent(in) :: str !< string in which chunk positions are searched for
integer, dimension(:), allocatable :: IO_strPos
integer :: left, right
allocate(IO_stringPos(1), source=0)
allocate(IO_strPos(1), source=0)
right = 0
do while (verify(string(right+1:),IO_WHITESPACE)>0)
left = right + verify(string(right+1:),IO_WHITESPACE)
right = left + scan(string(left:),IO_WHITESPACE) - 2
if ( string(left:left) == IO_COMMENT) exit
IO_stringPos = [IO_stringPos,left,right]
IO_stringPos(1) = IO_stringPos(1)+1
endOfString: if (right < left) then
IO_stringPos(IO_stringPos(1)*2+1) = len_trim(string)
do while (verify(str(right+1:),IO_WHITESPACE)>0)
left = right + verify(str(right+1:),IO_WHITESPACE)
right = left + scan(str(left:),IO_WHITESPACE) - 2
if ( str(left:left) == IO_COMMENT) exit
IO_strPos = [IO_strPos,left,right]
IO_strPos(1) = IO_strPos(1)+1
endOfStr: if (right < left) then
IO_strPos(IO_strPos(1)*2+1) = len_trim(str)
exit
end if endOfString
end if endOfStr
end do
end function IO_stringPos
end function IO_strPos
!--------------------------------------------------------------------------------------------------
!> @brief Read string value at myChunk from string.
!--------------------------------------------------------------------------------------------------
function IO_stringValue(string,chunkPos,myChunk)
function IO_strValue(str,chunkPos,myChunk)
character(len=*), intent(in) :: string !< 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, intent(in) :: myChunk !< position number of desired chunk
character(len=:), allocatable :: IO_stringValue
character(len=:), allocatable :: IO_strValue
validChunk: if (myChunk > chunkPos(1) .or. myChunk < 1) then
IO_stringValue = ''
call IO_error(110,'IO_stringValue: "'//trim(string)//'"',label1='chunk',ID1=myChunk)
IO_strValue = ''
call IO_error(110,'IO_strValue: "'//trim(str)//'"',label1='chunk',ID1=myChunk)
else validChunk
IO_stringValue = string(chunkPos(myChunk*2):chunkPos(myChunk*2+1))
IO_strValue = str(chunkPos(myChunk*2):chunkPos(myChunk*2+1))
end if validChunk
end function IO_stringValue
end function IO_strValue
!--------------------------------------------------------------------------------------------------
!> @brief Read integer value at myChunk from string.
!--------------------------------------------------------------------------------------------------
integer function IO_intValue(string,chunkPos,myChunk)
integer function IO_intValue(str,chunkPos,myChunk)
character(len=*), intent(in) :: string !< 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, intent(in) :: myChunk !< position number of desired chunk
IO_intValue = IO_stringAsInt(IO_stringValue(string,chunkPos,myChunk))
IO_intValue = IO_strAsInt(IO_strValue(str,chunkPos,myChunk))
end function IO_intValue
!--------------------------------------------------------------------------------------------------
!> @brief Read float value at myChunk from string.
!> @brief Read real value at myChunk from string.
!--------------------------------------------------------------------------------------------------
real(pReal) function IO_floatValue(string,chunkPos,myChunk)
real(pREAL) function IO_realValue(str,chunkPos,myChunk)
character(len=*), intent(in) :: string !< 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, intent(in) :: myChunk !< position number of desired chunk
IO_floatValue = IO_stringAsFloat(IO_stringValue(string,chunkPos,myChunk))
IO_realValue = IO_strAsReal(IO_strValue(str,chunkPos,myChunk))
end function IO_floatValue
end function IO_realValue
!--------------------------------------------------------------------------------------------------
!> @brief Convert characters in string to lower case.
!--------------------------------------------------------------------------------------------------
pure function IO_lc(string)
pure function IO_lc(str)
character(len=*), intent(in) :: string !< string to convert
character(len=len(string)) :: IO_lc
character(len=*), intent(in) :: str !< string to convert
character(len=len(str)) :: IO_lc
character(len=*), parameter :: LOWER = 'abcdefghijklmnopqrstuvwxyz'
character(len=len(LOWER)), parameter :: UPPER = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
@ -299,10 +299,10 @@ pure function IO_lc(string)
integer :: i,n
do i = 1,len(string)
n = index(UPPER,string(i:i))
do i = 1,len(str)
n = index(UPPER,str(i:i))
if (n==0) then
IO_lc(i:i) = string(i:i)
IO_lc(i:i) = str(i:i)
else
IO_lc(i:i) = LOWER(n:n)
end if
@ -336,80 +336,80 @@ end function IO_rmComment
!--------------------------------------------------------------------------------------------------
!> @brief Return given int value as string.
!--------------------------------------------------------------------------------------------------
function IO_intAsString(i)
function IO_intAsStr(i)
integer, intent(in) :: i
character(len=:), allocatable :: IO_intAsString
character(len=:), allocatable :: IO_intAsStr
allocate(character(len=merge(2,1,i<0) + floor(log10(real(abs(merge(1,i,i==0))))))::IO_intAsString)
write(IO_intAsString,'(i0)') i
allocate(character(len=merge(2,1,i<0) + floor(log10(real(abs(merge(1,i,i==0))))))::IO_intAsStr)
write(IO_intAsStr,'(i0)') i
end function IO_intAsString
end function IO_intAsStr
!--------------------------------------------------------------------------------------------------
!> @brief Return integer value from given string.
!--------------------------------------------------------------------------------------------------
integer function IO_stringAsInt(string)
integer function IO_strAsInt(str)
character(len=*), intent(in) :: string !< string for conversion to int value
character(len=*), intent(in) :: str !< string for conversion to int value
integer :: readStatus
character(len=*), parameter :: VALIDCHARS = '0123456789+- '
valid: if (verify(string,VALIDCHARS) == 0) then
read(string,*,iostat=readStatus) IO_stringAsInt
if (readStatus /= 0) call IO_error(111,string)
valid: if (verify(str,VALIDCHARS) == 0) then
read(str,*,iostat=readStatus) IO_strAsInt
if (readStatus /= 0) call IO_error(111,str)
else valid
IO_stringAsInt = 0
call IO_error(111,string)
IO_strAsInt = 0
call IO_error(111,str)
end if valid
end function IO_stringAsInt
end function IO_strAsInt
!--------------------------------------------------------------------------------------------------
!> @brief Return float value from given string.
!> @brief Return real value from given string.
!--------------------------------------------------------------------------------------------------
real(pReal) function IO_stringAsFloat(string)
real(pREAL) function IO_strAsReal(str)
character(len=*), intent(in) :: string !< string for conversion to float value
character(len=*), intent(in) :: str !< string for conversion to real value
integer :: readStatus
character(len=*), parameter :: VALIDCHARS = '0123456789eE.+- '
valid: if (verify(string,VALIDCHARS) == 0) then
read(string,*,iostat=readStatus) IO_stringAsFloat
if (readStatus /= 0) call IO_error(112,string)
valid: if (verify(str,VALIDCHARS) == 0) then
read(str,*,iostat=readStatus) IO_strAsReal
if (readStatus /= 0) call IO_error(112,str)
else valid
IO_stringAsFloat = 0.0_pReal
call IO_error(112,string)
IO_strAsReal = 0.0_pREAL
call IO_error(112,str)
end if valid
end function IO_stringAsFloat
end function IO_strAsReal
!--------------------------------------------------------------------------------------------------
!> @brief Return logical value from given string.
!--------------------------------------------------------------------------------------------------
logical function IO_stringAsBool(string)
logical function IO_strAsBool(str)
character(len=*), intent(in) :: string !< string for conversion to int value
character(len=*), intent(in) :: str !< string for conversion to int value
if (trim(adjustl(string)) == 'True' .or. trim(adjustl(string)) == 'true') then
IO_stringAsBool = .true.
elseif (trim(adjustl(string)) == 'False' .or. trim(adjustl(string)) == 'false') then
IO_stringAsBool = .false.
if (trim(adjustl(str)) == 'True' .or. trim(adjustl(str)) == 'true') then
IO_strAsBool = .true.
elseif (trim(adjustl(str)) == 'False' .or. trim(adjustl(str)) == 'false') then
IO_strAsBool = .false.
else
IO_stringAsBool = .false.
call IO_error(113,string)
IO_strAsBool = .false.
call IO_error(113,str)
end if
end function IO_stringAsBool
end function IO_strAsBool
@ -441,7 +441,7 @@ subroutine IO_error(error_ID,ext_msg,label1,ID1,label2,ID2)
case (111)
msg = 'invalid character for int:'
case (112)
msg = 'invalid character for float:'
msg = 'invalid character for real:'
case (113)
msg = 'invalid character for logical:'
case (114)
@ -647,22 +647,22 @@ end subroutine IO_warning
!--------------------------------------------------------------------------------------------------
!> @brief Convert Windows (CRLF) to Unix (LF) line endings.
!--------------------------------------------------------------------------------------------------
pure function CRLF2LF(string)
pure function CRLF2LF(str)
character(len=*), intent(in) :: string
character(len=*), intent(in) :: str
character(len=:), allocatable :: CRLF2LF
integer(pI64) :: c,n
allocate(character(len=len_trim(string,pI64))::CRLF2LF)
allocate(character(len=len_trim(str,pI64))::CRLF2LF)
if (len(CRLF2LF,pI64) == 0) return
n = 0_pI64
do c=1_pI64, len_trim(string,pI64)
CRLF2LF(c-n:c-n) = string(c:c)
if (c == len_trim(string,pI64)) exit
if (string(c:c+1_pI64) == CR//LF) n = n + 1_pI64
do c=1_pI64, len_trim(str,pI64)
CRLF2LF(c-n:c-n) = str(c:c)
if (c == len_trim(str,pI64)) exit
if (str(c:c+1_pI64) == CR//LF) n = n + 1_pI64
end do
CRLF2LF = CRLF2LF(:c-n)
@ -680,7 +680,7 @@ subroutine panel(paneltype,ID,msg,ext_msg,label1,ID1,label2,ID2)
integer, intent(in) :: ID
integer, optional, intent(in) :: ID1,ID2
character(len=pStringLen) :: formatString
character(len=pSTRLEN) :: formatString
integer, parameter :: panelwidth = 69
character(len=*), parameter :: DIVIDER = repeat('─',panelwidth)
@ -733,37 +733,37 @@ subroutine selfTest()
character(len=:), allocatable :: str,out
if (dNeq(1.0_pReal, IO_stringAsFloat('1.0'))) error stop 'IO_stringAsFloat'
if (dNeq(1.0_pReal, IO_stringAsFloat('1e0'))) error stop 'IO_stringAsFloat'
if (dNeq(0.1_pReal, IO_stringAsFloat('1e-1'))) error stop 'IO_stringAsFloat'
if (dNeq(0.1_pReal, IO_stringAsFloat('1.0e-1'))) error stop 'IO_stringAsFloat'
if (dNeq(0.1_pReal, IO_stringAsFloat('1.00e-1'))) error stop 'IO_stringAsFloat'
if (dNeq(10._pReal, IO_stringAsFloat(' 1.0e+1 '))) error stop 'IO_stringAsFloat'
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(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.00e-1'))) error stop 'IO_strAsReal'
if (dNeq(10._pREAL, IO_strAsReal(' 1.0e+1 '))) error stop 'IO_strAsReal'
if (3112019 /= IO_stringAsInt( '3112019')) error stop 'IO_stringAsInt'
if (3112019 /= IO_stringAsInt(' 3112019')) error stop 'IO_stringAsInt'
if (-3112019 /= IO_stringAsInt('-3112019')) error stop 'IO_stringAsInt'
if (3112019 /= IO_stringAsInt('+3112019 ')) error stop 'IO_stringAsInt'
if (3112019 /= IO_stringAsInt('03112019 ')) error stop 'IO_stringAsInt'
if (3112019 /= IO_stringAsInt('+03112019')) error stop 'IO_stringAsInt'
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'
if (3112019 /= IO_strAsInt('03112019 ')) error stop 'IO_strAsInt'
if (3112019 /= IO_strAsInt('+03112019')) error stop 'IO_strAsInt'
if (.not. IO_stringAsBool(' true')) error stop 'IO_stringAsBool'
if (.not. IO_stringAsBool(' True ')) error stop 'IO_stringAsBool'
if ( IO_stringAsBool(' false')) error stop 'IO_stringAsBool'
if ( IO_stringAsBool('False')) error stop 'IO_stringAsBool'
if (.not. IO_strAsBool(' true')) error stop 'IO_strAsBool'
if (.not. IO_strAsBool(' True ')) error stop 'IO_strAsBool'
if ( IO_strAsBool(' false')) error stop 'IO_strAsBool'
if ( IO_strAsBool('False')) error stop 'IO_strAsBool'
if ('1234' /= IO_intAsString(1234)) error stop 'IO_intAsString'
if ('-12' /= IO_intAsString(-0012)) error stop 'IO_intAsString'
if ('1234' /= IO_intAsStr(1234)) error stop 'IO_intAsStr'
if ('-12' /= IO_intAsStr(-0012)) error stop 'IO_intAsStr'
if (any([1,1,1] /= IO_stringPos('a'))) error stop 'IO_stringPos'
if (any([2,2,3,5,5] /= IO_stringPos(' aa b'))) error stop 'IO_stringPos'
if (any([1,1,1] /= IO_strPos('a'))) error stop 'IO_strPos'
if (any([2,2,3,5,5] /= IO_strPos(' aa b'))) error stop 'IO_strPos'
str = ' 1.0 xxx'
chunkPos = IO_stringPos(str)
if (dNeq(1.0_pReal,IO_floatValue(str,chunkPos,1))) error stop 'IO_floatValue'
chunkPos = IO_strPos(str)
if (dNeq(1.0_pREAL,IO_realValue(str,chunkPos,1))) error stop 'IO_realValue'
str = 'M 3112019 F'
chunkPos = IO_stringPos(str)
chunkPos = IO_strPos(str)
if (3112019 /= IO_intValue(str,chunkPos,2)) error stop 'IO_intValue'
if (CRLF2LF('') /= '') error stop 'CRLF2LF/0'

26
src/LAPACK_interface.f90
View File

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

46
src/Marc/DAMASK_Marc.f90
View File

@ -98,7 +98,7 @@ end function getSolverJobName
!--------------------------------------------------------------------------------------------------
logical function solverIsSymmetric()
character(len=pStringLen) :: line
character(len=pSTRLEN) :: line
integer :: myStat,fileUnit,s,e
open(newunit=fileUnit, file=getSolverJobName()//INPUTFILEEXTENSION, &
@ -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
kcus, & !< (1) layer number, (2) internal layer number
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
de, & !< increment of strain
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
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
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
eigvn, & !< i principal direction components for j eigenvalues at t=n
frotn1, & !< rotation tensor 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
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
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)
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
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
!--------------------------------------------------------------------------------------------------
@ -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)
logical :: cutBack
real(pReal), dimension(6) :: stress
real(pReal), dimension(6,6) :: ddsdde
real(pREAL), dimension(6) :: stress
real(pREAL), dimension(6,6) :: ddsdde
integer :: computationMode, i, node, CPnodeID
integer(pI32) :: defaultNumThreadsInt !< default value set by Marc
integer, save :: &
theInc = -1, & !< needs description
lastLovl = 0 !< lovl in previous call to marc hypela2
real(pReal), save :: &
theTime = 0.0_pReal, & !< needs description
theDelta = 0.0_pReal
real(pREAL), save :: &
theTime = 0.0_pREAL, & !< needs description
theDelta = 0.0_pREAL
logical, save :: &
lastIncConverged = .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)
s = stress(1:ndi+nshear)
g = 0.0_pReal
if (symmetricSolver) d = 0.5_pReal*(d+transpose(d))
g = 0.0_pREAL
if (symmetricSolver) d = 0.5_pREAL*(d+transpose(d))
call omp_set_num_threads(defaultNumThreadsInt) ! reset number of threads to stored default value
@ -368,18 +368,18 @@ subroutine flux(f,ts,n,time)
use discretization_Marc
implicit none(type,external)
real(pReal), dimension(6), intent(in) :: &
real(pREAL), dimension(6), intent(in) :: &
ts
integer(pI64), dimension(10), intent(in) :: &
n
real(pReal), intent(in) :: &
real(pREAL), intent(in) :: &
time
real(pReal), dimension(2), intent(out) :: &
real(pREAL), dimension(2), intent(out) :: &
f
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
@ -402,7 +402,7 @@ subroutine uedinc(inc,incsub)
integer :: n, nqncomp, nqdatatype
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)
@ -411,7 +411,7 @@ subroutine uedinc(inc,incsub)
do n = lbound(discretization_Marc_FEM2DAMASK_node,1), ubound(discretization_Marc_FEM2DAMASK_node,1)
if (discretization_Marc_FEM2DAMASK_node(n) /= -1) then
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 do

174
src/Marc/discretization_Marc.f90
View File

@ -20,7 +20,7 @@ module discretization_Marc
implicit none(type,external)
private
real(pReal), public, protected :: &
real(pREAL), public, protected :: &
mesh_unitlength !< physical length of one unit in mesh MD: needs systematic_name
integer, dimension(:), allocatable, public, protected :: &
@ -51,7 +51,7 @@ contains
!--------------------------------------------------------------------------------------------------
subroutine discretization_Marc_init
real(pReal), dimension(:,:), allocatable :: &
real(pREAL), dimension(:,:), allocatable :: &
node0_elem, & !< node x,y,z coordinates (initially!)
node0_cell
type(tElement) :: elem
@ -61,11 +61,11 @@ subroutine discretization_Marc_init
integer:: &
Nelems !< total number of elements in the mesh
real(pReal), dimension(:,:), allocatable :: &
real(pREAL), dimension(:,:), allocatable :: &
IP_reshaped
integer, dimension(:,:), allocatable :: &
connectivity_elem
real(pReal), dimension(:,:,:,:), allocatable :: &
real(pREAL), dimension(:,:,:,:), allocatable :: &
unscaledNormals
type(tDict), pointer :: &
@ -75,8 +75,8 @@ subroutine discretization_Marc_init
print'(/,a)', ' <<<+- discretization_Marc init -+>>>'; flush(6)
num_commercialFEM => config_numerics%get_dict('commercialFEM',defaultVal = emptyDict)
mesh_unitlength = num_commercialFEM%get_asFloat('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')
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')
call inputRead(elem,node0_elem,connectivity_elem,materialAt)
nElems = size(connectivity_elem,2)
@ -113,9 +113,9 @@ end subroutine discretization_Marc_init
!--------------------------------------------------------------------------------------------------
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)
@ -134,7 +134,7 @@ function discretization_Marc_FEM2DAMASK_cell(IP_FEM,elem_FEM) result(cell)
integer, intent(in) :: IP_FEM, elem_FEM
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
@ -155,7 +155,7 @@ subroutine writeGeometry(elem, &
integer, dimension(:,:), intent(in) :: &
connectivity_elem, &
connectivity_cell_reshaped
real(pReal), dimension(:,:), intent(in) :: &
real(pREAL), dimension(:,:), intent(in) :: &
coordinates_nodes, &
coordinates_points
@ -187,7 +187,7 @@ end subroutine writeGeometry
subroutine inputRead(elem,node0_elem,connectivity_elem,materialAt)
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!)
integer, dimension(:,:), allocatable, intent(out) :: &
connectivity_elem
@ -202,7 +202,7 @@ subroutine inputRead(elem,node0_elem,connectivity_elem,materialAt)
nElems
integer, dimension(:), allocatable :: &
matNumber !< material numbers for hypoelastic material
character(len=pStringLen), dimension(:), allocatable :: &
character(len=pSTRLEN), dimension(:), allocatable :: &
inputFile, & !< file content, separated per lines
nameElemSet
integer, dimension(:,:), allocatable :: &
@ -263,9 +263,9 @@ subroutine inputRead_fileFormat(fileFormat,fileContent)
integer :: l
do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l))
chunkPos = IO_strPos(fileContent(l))
if (chunkPos(1) < 2) cycle
if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'version') then
if (IO_lc(IO_strValue(fileContent(l),chunkPos,1)) == 'version') then
fileFormat = IO_intValue(fileContent(l),chunkPos,2)
exit
end if
@ -289,9 +289,9 @@ subroutine inputRead_tableStyles(initialcond,hypoelastic,fileContent)
hypoelastic = 0
do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l))
chunkPos = IO_strPos(fileContent(l))
if (chunkPos(1) < 6) cycle
if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'table') then
if (IO_lc(IO_strValue(fileContent(l),chunkPos,1)) == 'table') then
initialcond = IO_intValue(fileContent(l),chunkPos,4)
hypoelastic = IO_intValue(fileContent(l),chunkPos,5)
exit
@ -316,11 +316,11 @@ subroutine inputRead_matNumber(matNumber, &
do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l))
chunkPos = IO_strPos(fileContent(l))
if (chunkPos(1) < 1) cycle
if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'hypoelastic') then
if (IO_lc(IO_strValue(fileContent(l),chunkPos,1)) == 'hypoelastic') then
if (len_trim(fileContent(l+1))/=0) then
chunkPos = IO_stringPos(fileContent(l+1))
chunkPos = IO_strPos(fileContent(l+1))
data_blocks = IO_intValue(fileContent(l+1),chunkPos,1)
else
data_blocks = 1
@ -328,7 +328,7 @@ subroutine inputRead_matNumber(matNumber, &
allocate(matNumber(data_blocks), source = 0)
do i = 0, data_blocks - 1
j = i*(2+tableStyle) + 1
chunkPos = IO_stringPos(fileContent(l+1+j))
chunkPos = IO_strPos(fileContent(l+1+j))
matNumber(i+1) = IO_intValue(fileContent(l+1+j),chunkPos,1)
end do
exit
@ -354,12 +354,12 @@ subroutine inputRead_NnodesAndElements(nNodes,nElems,&
nElems = 0
do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l))
chunkPos = IO_strPos(fileContent(l))
if (chunkPos(1) < 1) cycle
if (IO_lc(IO_StringValue(fileContent(l),chunkPos,1)) == 'sizing') then
if (IO_lc(IO_StrValue(fileContent(l),chunkPos,1)) == 'sizing') then
nElems = IO_IntValue (fileContent(l),chunkPos,3)
elseif (IO_lc(IO_StringValue(fileContent(l),chunkPos,1)) == 'coordinates') then
chunkPos = IO_stringPos(fileContent(l+1))
elseif (IO_lc(IO_StrValue(fileContent(l),chunkPos,1)) == 'coordinates') then
chunkPos = IO_strPos(fileContent(l+1))
nNodes = IO_IntValue (fileContent(l+1),chunkPos,2)
end if
end do
@ -384,13 +384,13 @@ subroutine inputRead_NelemSets(nElemSets,maxNelemInSet,&
maxNelemInSet = 0
do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l))
chunkPos = IO_strPos(fileContent(l))
if (chunkPos(1) < 2) cycle
if (IO_lc(IO_StringValue(fileContent(l),chunkPos,1)) == 'define' .and. &
IO_lc(IO_StringValue(fileContent(l),chunkPos,2)) == 'element') then
if (IO_lc(IO_StrValue(fileContent(l),chunkPos,1)) == 'define' .and. &
IO_lc(IO_StrValue(fileContent(l),chunkPos,2)) == 'element') then
nElemSets = nElemSets + 1
chunkPos = IO_stringPos(fileContent(l+1))
chunkPos = IO_strPos(fileContent(l+1))
if (containsRange(fileContent(l+1),chunkPos)) then
elemInCurrentSet = 1 + abs( IO_intValue(fileContent(l+1),chunkPos,3) &
-IO_intValue(fileContent(l+1),chunkPos,1))
@ -399,9 +399,9 @@ subroutine inputRead_NelemSets(nElemSets,maxNelemInSet,&
i = 0
do while (.true.)
i = i + 1
chunkPos = IO_stringPos(fileContent(l+i))
chunkPos = IO_strPos(fileContent(l+i))
elemInCurrentSet = elemInCurrentSet + chunkPos(1) - 1 ! add line's count when assuming 'c'
if (IO_lc(IO_stringValue(fileContent(l+i),chunkPos,chunkPos(1))) /= 'c') then ! line finished, read last value
if (IO_lc(IO_strValue(fileContent(l+i),chunkPos,chunkPos(1))) /= 'c') then ! line finished, read last value
elemInCurrentSet = elemInCurrentSet + 1 ! data ended
exit
end if
@ -420,7 +420,7 @@ end subroutine inputRead_NelemSets
subroutine inputRead_mapElemSets(nameElemSet,mapElemSet,&
fileContent)
character(len=pStringLen), dimension(:), allocatable, intent(out) :: nameElemSet
character(len=pSTRLEN), dimension(:), allocatable, intent(out) :: nameElemSet
integer, dimension(:,:), allocatable, intent(out) :: mapElemSet
character(len=*), dimension(:), intent(in) :: fileContent !< file content, separated per lines
@ -434,12 +434,12 @@ subroutine inputRead_mapElemSets(nameElemSet,mapElemSet,&
elemSet = 0
do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l))
chunkPos = IO_strPos(fileContent(l))
if (chunkPos(1) < 2) cycle
if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'define' .and. &
IO_lc(IO_stringValue(fileContent(l),chunkPos,2)) == 'element') then
if (IO_lc(IO_strValue(fileContent(l),chunkPos,1)) == 'define' .and. &
IO_lc(IO_strValue(fileContent(l),chunkPos,2)) == 'element') then
elemSet = elemSet+1
nameElemSet(elemSet) = trim(IO_stringValue(fileContent(l),chunkPos,4))
nameElemSet(elemSet) = trim(IO_strValue(fileContent(l),chunkPos,4))
mapElemSet(:,elemSet) = continuousIntValues(fileContent(l+1:),size(mapElemSet,1)-1,nameElemSet,mapElemSet,size(nameElemSet))
end if
end do
@ -465,17 +465,17 @@ subroutine inputRead_mapElems(FEM2DAMASK, &
do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l))
chunkPos = IO_strPos(fileContent(l))
if (chunkPos(1) < 1) cycle
if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'connectivity') then
if (IO_lc(IO_strValue(fileContent(l),chunkPos,1)) == 'connectivity') then
j = 0
do i = 1,nElems
chunkPos = IO_stringPos(fileContent(l+1+i+j))
chunkPos = IO_strPos(fileContent(l+1+i+j))
map_unsorted(:,i) = [IO_intValue(fileContent(l+1+i+j),chunkPos,1),i]
nNodesAlreadyRead = chunkPos(1) - 2
do while(nNodesAlreadyRead < nNodesPerElem) ! read on if not all nodes in one line
j = j + 1
chunkPos = IO_stringPos(fileContent(l+1+i+j))
chunkPos = IO_strPos(fileContent(l+1+i+j))
nNodesAlreadyRead = nNodesAlreadyRead + chunkPos(1)
end do
end do
@ -509,9 +509,9 @@ subroutine inputRead_mapNodes(FEM2DAMASK, &
do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l))
chunkPos = IO_strPos(fileContent(l))
if (chunkPos(1) < 1) cycle
if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'coordinates') then
if (IO_lc(IO_strValue(fileContent(l),chunkPos,1)) == 'coordinates') then
chunkPos = [1,1,10]
do i = 1,nNodes
map_unsorted(:,i) = [IO_intValue(fileContent(l+1+i),chunkPos,1),i]
@ -535,7 +535,7 @@ end subroutine inputRead_mapNodes
subroutine inputRead_elemNodes(nodes, &
nNode,fileContent)
real(pReal), allocatable, dimension(:,:), intent(out) :: nodes
real(pREAL), allocatable, dimension(:,:), intent(out) :: nodes
integer, intent(in) :: nNode
character(len=*), dimension(:), intent(in) :: fileContent !< file content, separated per lines
@ -546,13 +546,13 @@ subroutine inputRead_elemNodes(nodes, &
allocate(nodes(3,nNode))
do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l))
chunkPos = IO_strPos(fileContent(l))
if (chunkPos(1) < 1) cycle
if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'coordinates') then
if (IO_lc(IO_strValue(fileContent(l),chunkPos,1)) == 'coordinates') then
chunkPos = [4,1,10,11,30,31,50,51,70]
do i=1,nNode
m = discretization_Marc_FEM2DAMASK_node(IO_intValue(fileContent(l+1+i),chunkPos,1))
nodes(1:3,m) = [(mesh_unitlength * IO_floatValue(fileContent(l+1+i),chunkPos,j+1),j=1,3)]
nodes(1:3,m) = [(mesh_unitlength * IO_realValue(fileContent(l+1+i),chunkPos,j+1),j=1,3)]
end do
exit
end if
@ -577,23 +577,23 @@ subroutine inputRead_elemType(elem, &
t = -1
do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l))
chunkPos = IO_strPos(fileContent(l))
if (chunkPos(1) < 1) cycle
if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'connectivity') then
if (IO_lc(IO_strValue(fileContent(l),chunkPos,1)) == 'connectivity') then
j = 0
do i=1,nElem ! read all elements
chunkPos = IO_stringPos(fileContent(l+1+i+j))
chunkPos = IO_strPos(fileContent(l+1+i+j))
if (t == -1) then
t = mapElemtype(IO_stringValue(fileContent(l+1+i+j),chunkPos,2))
t = mapElemtype(IO_strValue(fileContent(l+1+i+j),chunkPos,2))
call elem%init(t)
else
t_ = mapElemtype(IO_stringValue(fileContent(l+1+i+j),chunkPos,2))
if (t /= t_) call IO_error(191,IO_stringValue(fileContent(l+1+i+j),chunkPos,2),label1='type',ID1=t)
t_ = mapElemtype(IO_strValue(fileContent(l+1+i+j),chunkPos,2))
if (t /= t_) call IO_error(191,IO_strValue(fileContent(l+1+i+j),chunkPos,2),label1='type',ID1=t)
end if
remainingChunks = elem%nNodes - (chunkPos(1) - 2)
do while(remainingChunks > 0)
j = j + 1
chunkPos = IO_stringPos(fileContent(l+1+i+j))
chunkPos = IO_strPos(fileContent(l+1+i+j))
remainingChunks = remainingChunks - chunkPos(1)
end do
end do
@ -668,12 +668,12 @@ function inputRead_connectivityElem(nElem,nNodes,fileContent)
do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l))
chunkPos = IO_strPos(fileContent(l))
if (chunkPos(1) < 1) cycle
if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'connectivity') then
if (IO_lc(IO_strValue(fileContent(l),chunkPos,1)) == 'connectivity') then
j = 0
do i = 1,nElem
chunkPos = IO_stringPos(fileContent(l+1+i+j))
chunkPos = IO_strPos(fileContent(l+1+i+j))
e = discretization_Marc_FEM2DAMASK_elem(IO_intValue(fileContent(l+1+i+j),chunkPos,1))
if (e /= 0) then ! disregard non CP elems
do k = 1,chunkPos(1)-2
@ -683,7 +683,7 @@ function inputRead_connectivityElem(nElem,nNodes,fileContent)
nNodesAlreadyRead = chunkPos(1) - 2
do while(nNodesAlreadyRead < nNodes) ! read on if not all nodes in one line
j = j + 1
chunkPos = IO_stringPos(fileContent(l+1+i+j))
chunkPos = IO_strPos(fileContent(l+1+i+j))
do k = 1,chunkPos(1)
inputRead_connectivityElem(nNodesAlreadyRead+k,e) = &
discretization_Marc_FEM2DAMASK_node(IO_IntValue(fileContent(l+1+i+j),chunkPos,k))
@ -725,18 +725,18 @@ subroutine inputRead_material(materialAt,&
allocate(materialAt(nElem))
do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l))
chunkPos = IO_strPos(fileContent(l))
if (chunkPos(1) < 2) cycle
if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'initial' .and. &
IO_lc(IO_stringValue(fileContent(l),chunkPos,2)) == 'state') then
if (IO_lc(IO_strValue(fileContent(l),chunkPos,1)) == 'initial' .and. &
IO_lc(IO_strValue(fileContent(l),chunkPos,2)) == 'state') then
k = merge(2,1,initialcondTableStyle == 2)
chunkPos = IO_stringPos(fileContent(l+k))
chunkPos = IO_strPos(fileContent(l+k))
sv = IO_IntValue(fileContent(l+k),chunkPos,1) ! # of state variable
if (sv == 2) then ! state var 2 gives material ID
m = 1
chunkPos = IO_stringPos(fileContent(l+k+m))
do while (scan(IO_stringValue(fileContent(l+k+m),chunkPos,1),'+-',back=.true.)>1) ! is noEfloat value?
ID = nint(IO_floatValue(fileContent(l+k+m),chunkPos,1))
chunkPos = IO_strPos(fileContent(l+k+m))
do while (scan(IO_strValue(fileContent(l+k+m),chunkPos,1),'+-',back=.true.)>1) ! is no Efloat value?
ID = nint(IO_realValue(fileContent(l+k+m),chunkPos,1))
if (initialcondTableStyle == 2) m = m + 2
contInts = continuousIntValues(fileContent(l+k+m+1:),nElem,nameElemSet,mapElemSet,size(nameElemSet)) ! get affected elements
do i = 1,contInts(1)
@ -914,8 +914,8 @@ end subroutine buildCells
!--------------------------------------------------------------------------------------------------
pure function buildCellNodes(node_elem)
real(pReal), dimension(:,:), intent(in) :: node_elem !< element nodes
real(pReal), dimension(:,:), allocatable :: buildCellNodes !< cell node coordinates
real(pREAL), dimension(:,:), intent(in) :: node_elem !< element nodes
real(pREAL), dimension(:,:), allocatable :: buildCellNodes !< cell node coordinates
integer :: i, j, k, n
@ -927,13 +927,13 @@ pure function buildCellNodes(node_elem)
do i = 1, size(cellNodeDefinition)
do j = 1, size(cellNodeDefinition(i)%parents,1)
n = n+1
buildCellNodes(:,n) = 0.0_pReal
buildCellNodes(:,n) = 0.0_pREAL
do k = 1, size(cellNodeDefinition(i)%parents,2)
buildCellNodes(:,n) = buildCellNodes(:,n) &
+ buildCellNodes(:,cellNodeDefinition(i)%parents(j,k)) &
* real(cellNodeDefinition(i)%weights(j,k),pReal)
* real(cellNodeDefinition(i)%weights(j,k),pREAL)
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
@ -945,8 +945,8 @@ end function buildCellNodes
!--------------------------------------------------------------------------------------------------
pure function buildIPcoordinates(node_cell)
real(pReal), dimension(:,:), intent(in) :: node_cell !< cell node coordinates
real(pReal), dimension(:,:), allocatable :: buildIPcoordinates !< cell-center/IP coordinates
real(pREAL), dimension(:,:), intent(in) :: node_cell !< cell node coordinates
real(pREAL), dimension(:,:), allocatable :: buildIPcoordinates !< cell-center/IP coordinates
integer, dimension(:,:), allocatable :: connectivity_cell_reshaped
integer :: i, n, NcellNodesPerCell,Ncells
@ -959,12 +959,12 @@ pure function buildIPcoordinates(node_cell)
allocate(buildIPcoordinates(3,Ncells))
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)
buildIPcoordinates(:,i) = buildIPcoordinates(:,i) &
+ node_cell(:,connectivity_cell_reshaped(n,i))
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 function buildIPcoordinates
@ -978,10 +978,10 @@ end function buildIPcoordinates
pure function IPvolume(elem,node)
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(3) :: x0,x1,x2,x3,x4,x5,x6,x7
real(pREAL), dimension(elem%nIPs,size(connectivity_cell,3)) :: IPvolume
real(pREAL), dimension(3) :: x0,x1,x2,x3,x4,x5,x6,x7
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))) &
+ dot_product((x6-x0), math_cross((x7-x2)+(x5-x0),(x7-x4))) &
+ dot_product((x7-x1), math_cross((x5-x0), (x7-x4)+(x3-x0)))
IPvolume(i,e) = IPvolume(i,e)/12.0_pReal
IPvolume(i,e) = IPvolume(i,e)/12.0_pREAL
end select
end do
end do
@ -1037,11 +1037,11 @@ pure function IPareaNormal(elem,nElem,node)
type(tElement), intent(in) :: elem
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
m = size(elem%cellFace,1)
@ -1055,7 +1055,7 @@ pure function IPareaNormal(elem,nElem,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(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
IPareaNormal(1:3,f,i,e) = math_cross(nodePos(1:3,2) - 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
! 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
IPareaNormal(1:3,f,i,e) = 0.0_pReal
IPareaNormal(1:3,f,i,e) = 0.0_pREAL
do n = 1, m
IPareaNormal(1:3,f,i,e) = IPareaNormal(1:3,f,i,e) &
+ math_cross(nodePos(1:3,mod(n+0,m)+1) - nodePos(1:3,n), &
nodePos(1:3,mod(n+1,m)+1) - nodePos(1:3,n)) * 0.5_pReal
nodePos(1:3,mod(n+1,m)+1) - nodePos(1:3,n)) * 0.5_pREAL
end do
end select
end do
@ -1156,12 +1156,12 @@ function continuousIntValues(fileContent,maxN,lookupName,lookupMap,lookupMaxN)
rangeGeneration = .false.
do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l))
chunkPos = IO_strPos(fileContent(l))
if (chunkPos(1) < 1) then ! empty line
exit
elseif (verify(IO_stringValue(fileContent(l),chunkPos,1),'0123456789') > 0) then ! a non-int, i.e. set name
elseif (verify(IO_strValue(fileContent(l),chunkPos,1),'0123456789') > 0) then ! a non-int, i.e. set name
do i = 1, lookupMaxN ! loop over known set names
if (IO_stringValue(fileContent(l),chunkPos,1) == lookupName(i)) then ! found matching name
if (IO_strValue(fileContent(l),chunkPos,1) == lookupName(i)) then ! found matching name
continuousIntValues = lookupMap(:,i) ! return resp. entity list
exit
end if
@ -1180,7 +1180,7 @@ function continuousIntValues(fileContent,maxN,lookupName,lookupMap,lookupMaxN)
continuousIntValues(1) = continuousIntValues(1) + 1
continuousIntValues(1+continuousIntValues(1)) = IO_intValue(fileContent(l),chunkPos,i)
end do
if ( IO_lc(IO_stringValue(fileContent(l),chunkPos,chunkPos(1))) /= 'c' ) then ! line finished, read last value
if ( IO_lc(IO_strValue(fileContent(l),chunkPos,chunkPos(1))) /= 'c' ) then ! line finished, read last value
continuousIntValues(1) = continuousIntValues(1) + 1
continuousIntValues(1+continuousIntValues(1)) = IO_intValue(fileContent(l),chunkPos,chunkPos(1))
exit
@ -1202,7 +1202,7 @@ logical function containsRange(str,chunkPos)
containsRange = .False.
if (chunkPos(1) == 3) then
if (IO_lc(IO_stringValue(str,chunkPos,2)) == 'to') containsRange = .True.
if (IO_lc(IO_strValue(str,chunkPos,2)) == 'to') containsRange = .True.
end if
end function containsRange

48
src/Marc/materialpoint_Marc.f90
View File

@ -27,11 +27,11 @@ module materialpoint_Marc
implicit none(type,external)
private
real(pReal), dimension (:,:,:), allocatable, private :: &
real(pREAL), dimension (:,:,:), allocatable, private :: &
materialpoint_cs !< Cauchy stress
real(pReal), dimension (:,:,:,:), allocatable, private :: &
real(pREAL), dimension (:,:,:,:), allocatable, private :: &
materialpoint_dcsdE !< Cauchy stress tangent
real(pReal), dimension (:,:,:,:), allocatable, private :: &
real(pREAL), dimension (:,:,:,:), allocatable, private :: &
materialpoint_dcsdE_knownGood !< known good tangent
integer, public :: &
@ -95,9 +95,9 @@ subroutine materialpoint_init()
print'(/,1x,a)', '<<<+- materialpoint init -+>>>'; flush(IO_STDOUT)
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_knownGood(6,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_knownGood(6,6,discretization_nIPs,discretization_Nelems), source= 0.0_pREAL)
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
ip !< integration point number
real(pReal), intent(in) :: dt !< time increment
real(pReal), dimension (3,3), intent(in) :: ffn, & !< deformation gradient for t=t0
real(pREAL), intent(in) :: dt !< time increment
real(pREAL), dimension (3,3), intent(in) :: ffn, & !< deformation gradient for t=t0
ffn1 !< deformation gradient for t=t1
integer, intent(in) :: mode !< computation mode 1: regular computation plus aging of results
real(pReal), intent(in) :: temperature_inp !< temperature
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), intent(in) :: temperature_inp !< temperature
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) J_inverse, & ! inverse of Jacobian
real(pREAL) J_inverse, & ! inverse of Jacobian
rnd
real(pReal), dimension (3,3) :: Kirchhoff ! Piola-Kirchhoff stress
real(pReal), dimension (3,3,3,3) :: H_sym, &
real(pREAL), dimension (3,3) :: Kirchhoff ! Piola-Kirchhoff stress
real(pREAL), dimension (3,3,3,3) :: H_sym, &
H
integer elCP, & ! crystal plasticity element number
i, j, k, l, m, n, ph, homog, mySource,ce
real(pReal), parameter :: ODD_STRESS = 1e15_pReal, & !< return value for stress if terminallyIll
ODD_JACOBIAN = 1e50_pReal !< return value for jacobian 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
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
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_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
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_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
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.)
! 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
H(i,j,k,l) = H(i,j,k,l) &
+ homogenization_F(j,m,ce) * homogenization_F(l,n,ce) &
* homogenization_dPdF(i,m,k,n,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))
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) &
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.)
@ -193,7 +193,7 @@ subroutine materialpoint_general(mode, ffn, ffn1, temperature_inp, dt, elFE, ip,
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)
cauchyStress = materialpoint_cs (1:6, ip,elCP)
@ -219,7 +219,7 @@ end subroutine materialpoint_forward
subroutine materialpoint_result(inc,time)
integer, intent(in) :: inc
real(pReal), intent(in) :: time
real(pREAL), intent(in) :: time
call result_openJobFile()
call result_addIncrement(inc,time)

18
src/YAML_parse.f90
View File

@ -122,7 +122,7 @@ recursive function parse_flow(YAML_flow) result(node)
d = s + scan(flow_string(s+1_pI64:),':',kind=pI64)
e = d + find_end(flow_string(d+1_pI64:),'}')
key = trim(adjustl(flow_string(s+1_pI64:d-1_pI64)))
if (quotedString(key)) key = key(2:len(key)-1)
if (quotedStr(key)) key = key(2:len(key)-1)
myVal => parse_flow(flow_string(d+1_pI64:e-1_pI64)) ! parse items (recursively)
select type (node)
@ -147,7 +147,7 @@ recursive function parse_flow(YAML_flow) result(node)
allocate(tScalar::node)
select type (node)
class is (tScalar)
if (quotedString(flow_string)) then
if (quotedStr(flow_string)) then
node = trim(adjustl(flow_string(2:len(flow_string)-1)))
else
node = trim(adjustl(flow_string))
@ -191,21 +191,21 @@ end function find_end
!--------------------------------------------------------------------------------------------------
! @brief Check whether a string is enclosed with single or double quotes.
!--------------------------------------------------------------------------------------------------
logical function quotedString(line)
logical function quotedStr(line)
character(len=*), intent(in) :: line
quotedString = .false.
quotedStr = .false.
if (len(line) == 0) return
if (scan(line(:1),IO_QUOTES) == 1) then
quotedString = .true.
quotedStr = .true.
if (line(len(line):len(line)) /= line(:1)) call IO_error(710,ext_msg=line)
end if
end function quotedString
end function quotedStr
#ifdef FYAML
@ -876,7 +876,7 @@ subroutine selfTest()
if (indentDepth('a') /= 0) error stop 'indentDepth'
if (indentDepth('x ') /= 0) error stop 'indentDepth'
if (.not. quotedString("'a'")) error stop 'quotedString'
if (.not. quotedStr("'a'")) error stop 'quotedStr'
if ( isFlow(' a')) error stop 'isFLow'
if (.not. isFlow('{')) error stop 'isFlow'
@ -1025,9 +1025,9 @@ subroutine selfTest()
dct = '{a: 1, b: 2}'
list => YAML_parse_str_asList(lst//IO_EOL)
if (list%asFormattedString() /= lst) error stop 'str_asList'
if (list%asFormattedStr() /= lst) error stop 'str_asList'
dict => YAML_parse_str_asDict(dct//IO_EOL)
if (dict%asFormattedString() /= dct) error stop 'str_asDict'
if (dict%asFormattedStr() /= dct) error stop 'str_asDict'
end block parse

300
src/YAML_types.f90
View File

@ -18,8 +18,8 @@ module YAML_types
integer :: &
length = 0
contains
procedure(asFormattedString), deferred :: &
asFormattedString
procedure(asFormattedStr), deferred :: &
asFormattedStr
procedure :: &
asScalar => tNode_asScalar, &
asList => tNode_asList, &
@ -31,11 +31,11 @@ module YAML_types
value
contains
procedure :: &
asFormattedString => tScalar_asFormattedString, &
asFloat => tScalar_asFloat, &
asFormattedStr => tScalar_asFormattedStr, &
asReal => tScalar_asReal, &
asInt => tScalar_asInt, &
asBool => tScalar_asBool, &
asString => tScalar_asString
asStr => tScalar_asStr
end type tScalar
type, extends(tNode), public :: tList
@ -44,45 +44,45 @@ module YAML_types
last => NULL()
contains
procedure :: &
asFormattedString => tList_asFormattedString, &
asFormattedStr => tList_asFormattedStr, &
append => tList_append, &
as1dFloat => tList_as1dFloat, &
as2dFloat => tList_as2dFloat, &
as1dReal => tList_as1dReal, &
as2dReal => tList_as2dReal, &
as1dInt => tList_as1dInt, &
as1dBool => tList_as1dBool, &
as1dString => tList_as1dString, &
as1dStr => tList_as1dStr, &
contains => tList_contains, &
tList_get, &
tList_get_scalar, &
tList_get_list, &
tList_get_dict, &
tList_get_asFloat, &
tList_get_as1dFloat, &
tList_get_asReal, &
tList_get_as1dReal, &
tList_get_asInt, &
tList_get_as1dInt, &
tList_get_asBool, &
tList_get_as1dBool, &
tList_get_asString, &
tList_get_as1dString
tList_get_asStr, &
tList_get_as1dStr
generic :: get => tList_get
generic :: get_scalar => tList_get_scalar
generic :: get_list => tList_get_list
generic :: get_dict => tList_get_dict
generic :: get_asFloat => tList_get_asFloat
generic :: get_as1dFloat => tList_get_as1dFloat
generic :: get_asReal => tList_get_asReal
generic :: get_as1dReal => tList_get_as1dReal
generic :: get_asInt => tList_get_asInt
generic :: get_as1dInt => tList_get_as1dInt
generic :: get_asBool => tList_get_asBool
generic :: get_as1dBool => tList_get_as1dBool
generic :: get_asString => tList_get_asString
generic :: get_as1dString => tList_get_as1dString
generic :: get_asStr => tList_get_asStr
generic :: get_as1dStr => tList_get_as1dStr
final :: tList_finalize
end type tList
type, extends(tList), public :: tDict
contains
procedure :: &
asFormattedString => tDict_asFormattedString, &
asFormattedStr => tDict_asFormattedStr, &
set => tDict_set, &
index => tDict_index, &
key => tDict_key, &
@ -92,28 +92,28 @@ module YAML_types
tDict_get_scalar, &
tDict_get_list, &
tDict_get_dict, &
tDict_get_asFloat, &
tDict_get_as1dFloat, &
tDict_get_as2dFloat, &
tDict_get_asReal, &
tDict_get_as1dReal, &
tDict_get_as2dReal, &
tDict_get_asInt, &
tDict_get_as1dInt, &
tDict_get_asBool, &
tDict_get_as1dBool, &
tDict_get_asString, &
tDict_get_as1dString
tDict_get_asStr, &
tDict_get_as1dStr
generic :: get => tDict_get
generic :: get_scalar => tDict_get_scalar
generic :: get_list => tDict_get_list
generic :: get_dict => tDict_get_dict
generic :: get_asFloat => tDict_get_asFloat
generic :: get_as1dFloat => tDict_get_as1dFloat
generic :: get_as2dFloat => tDict_get_as2dFloat
generic :: get_asReal => tDict_get_asReal
generic :: get_as1dReal => tDict_get_as1dReal
generic :: get_as2dReal => tDict_get_as2dReal
generic :: get_asInt => tDict_get_asInt
generic :: get_as1dInt => tDict_get_as1dInt
generic :: get_asBool => tDict_get_asBool
generic :: get_as1dBool => tDict_get_as1dBool
generic :: get_asString => tDict_get_asString
generic :: get_as1dString => tDict_get_as1dString
generic :: get_asStr => tDict_get_asStr
generic :: get_as1dStr => tDict_get_as1dStr
end type tDict
@ -132,11 +132,11 @@ module YAML_types
abstract interface
recursive function asFormattedString(self)
recursive function asFormattedStr(self)
import tNode
character(len=:), allocatable :: asFormattedString
character(len=:), allocatable :: asFormattedStr
class(tNode), intent(in), target :: self
end function asFormattedString
end function asFormattedStr
end interface
@ -151,7 +151,7 @@ module YAML_types
public :: &
YAML_types_init, &
#ifdef __GFORTRAN__
output_as1dString, & !ToDo: Hack for GNU. Remove later
output_as1dStr, & !ToDo: Hack for GNU. Remove later
#endif
assignment(=)
@ -183,12 +183,12 @@ subroutine selfTest()
s = '1'
if (s%asInt() /= 1) error stop 'tScalar_asInt'
if (s_pointer%asInt() /= 1) error stop 'tScalar_asInt(pointer)'
if (dNeq(s%asFloat(),1.0_pReal)) error stop 'tScalar_asFloat'
if (dNeq(s%asReal(),1.0_pREAL)) error stop 'tScalar_asReal'
s = 'true'
if (.not. s%asBool()) error stop 'tScalar_asBool'
if (.not. s_pointer%asBool()) error stop 'tScalar_asBool(pointer)'
if (s%asString() /= 'true') error stop 'tScalar_asString'
if (s%asFormattedString() /= 'true') error stop 'tScalar_asFormattedString'
if (s%asStr() /= 'true') error stop 'tScalar_asStr'
if (s%asFormattedStr() /= 'true') error stop 'tScalar_asFormattedStr'
end block scalar
@ -209,16 +209,16 @@ subroutine selfTest()
call l%append(s1)
call l%append(s2)
if (l%length /= 2) error stop 'tList%len'
if (dNeq(l%get_asFloat(1),1.0_pReal)) error stop 'tList_get_asFloat'
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_asString(2) /= '2') error stop 'tList_get_asString'
if (l%get_asStr(2) /= '2') error stop 'tList_get_asStr'
if (any(l%as1dInt() /= [1,2])) error stop 'tList_as1dInt'
if (any(dNeq(l%as1dFloat(),real([1.0,2.0],pReal)))) error stop 'tList_as1dFloat'
if (any(dNeq(l%as1dReal(),real([1.0,2.0],pREAL)))) error stop 'tList_as1dReal'
s1 = 'true'
s2 = 'false'
if (any(l%as1dBool() .neqv. [.true.,.false.])) error stop 'tList_as1dBool'
if (any(l%as1dString() /= ['true ','false'])) error stop 'tList_as1dString'
if (l%asFormattedString() /= '[true, false]') error stop 'tList_asFormattedString'
if (any(l%as1dStr() /= ['true ','false'])) error stop 'tList_as1dStr'
if (l%asFormattedStr() /= '[true, false]') error stop 'tList_asFormattedStr'
if ( .not. l%contains('true') &
.or. .not. l%contains('false')) error stop 'tList_contains'
@ -250,14 +250,14 @@ subroutine selfTest()
call d%set('one-two',l)
call d%set('three',s3)
call d%set('four',s4)
if (d%asFormattedString() /= '{one-two: [1, 2], three: 3, four: 4}') &
error stop 'tDict_asFormattedString'
if (d%asFormattedStr() /= '{one-two: [1, 2], three: 3, four: 4}') &
error stop 'tDict_asFormattedStr'
if (d%get_asInt('three') /= 3) error stop 'tDict_get_asInt'
if (dNeq(d%get_asFloat('three'),3.0_pReal)) error stop 'tDict_get_asFloat'
if (d%get_asString('three') /= '3') error stop 'tDict_get_asString'
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 (any(d%get_as1dInt('one-two') /= [1,2])) error stop 'tDict_get_as1dInt'
call d%set('one-two',s4)
if (d%asFormattedString() /= '{one-two: 4, three: 3, four: 4}') &
if (d%asFormattedStr() /= '{one-two: 4, three: 3, four: 4}') &
error stop 'tDict_set overwrite'
if ( .not. d%contains('one-two') &
.or. .not. d%contains('three') &
@ -299,7 +299,7 @@ end subroutine tScalar_assign__
!--------------------------------------------------------------------------------------------------
!> @brief Format as string (YAML flow style).
!--------------------------------------------------------------------------------------------------
recursive function tScalar_asFormattedString(self) result(str)
recursive function tScalar_asFormattedStr(self) result(str)
class (tScalar), intent(in), target :: self
character(len=:), allocatable :: str
@ -307,7 +307,7 @@ recursive function tScalar_asFormattedString(self) result(str)
str = trim(self%value)
end function tScalar_asFormattedString
end function tScalar_asFormattedStr
!--------------------------------------------------------------------------------------------------
@ -324,7 +324,7 @@ function tNode_asScalar(self) result(scalar)
scalar => self
class default
nullify(scalar)
call IO_error(706,'"'//trim(self%asFormattedString())//'" is not a scalar')
call IO_error(706,'"'//trim(self%asFormattedStr())//'" is not a scalar')
end select
end function tNode_asScalar
@ -344,7 +344,7 @@ function tNode_asList(self) result(list)
list => self
class default
nullify(list)
call IO_error(706,'"'//trim(self%asFormattedString())//'" is not a list')
call IO_error(706,'"'//trim(self%asFormattedStr())//'" is not a list')
end select
end function tNode_asList
@ -364,24 +364,24 @@ function tNode_asDict(self) result(dict)
dict => self
class default
nullify(dict)
call IO_error(706,'"'//trim(self%asFormattedString())//'" is not a dict')
call IO_error(706,'"'//trim(self%asFormattedStr())//'" is not a dict')
end select
end function tNode_asDict
!--------------------------------------------------------------------------------------------------
!> @brief Convert to float.
!> @brief Convert to real.
!--------------------------------------------------------------------------------------------------
function tScalar_asFloat(self)
function tScalar_asReal(self)
class(tScalar), intent(in), target :: self
real(pReal) :: tScalar_asFloat
real(pREAL) :: tScalar_asReal
tScalar_asFloat = IO_stringAsFloat(self%value)
tScalar_asReal = IO_strAsReal(self%value)
end function tScalar_asFloat
end function tScalar_asReal
!--------------------------------------------------------------------------------------------------
@ -393,7 +393,7 @@ function tScalar_asInt(self)
integer :: tScalar_asInt
tScalar_asInt = IO_stringAsInt(self%value)
tScalar_asInt = IO_strAsInt(self%value)
end function tScalar_asInt
@ -407,7 +407,7 @@ function tScalar_asBool(self)
logical :: tScalar_asBool
tScalar_asBool = IO_stringAsBool(self%value)
tScalar_asBool = IO_strAsBool(self%value)
end function tScalar_asBool
@ -415,21 +415,21 @@ end function tScalar_asBool
!--------------------------------------------------------------------------------------------------
!> @brief Convert to string.
!--------------------------------------------------------------------------------------------------
function tScalar_asString(self)
function tScalar_asStr(self)
class(tScalar), intent(in), target :: self
character(len=:), allocatable :: tScalar_asString
character(len=:), allocatable :: tScalar_asStr
tScalar_asString = self%value
tScalar_asStr = self%value
end function tScalar_asString
end function tScalar_asStr
!--------------------------------------------------------------------------------------------------
!> @brief Format as string (YAML flow style).
!--------------------------------------------------------------------------------------------------
recursive function tList_asFormattedString(self) result(str)
recursive function tList_asFormattedStr(self) result(str)
class(tList),intent(in),target :: self
@ -440,12 +440,12 @@ recursive function tList_asFormattedString(self) result(str)
str = '['
item => self%first
do i = 2, self%length
str = str//item%node%asFormattedString()//', '
str = str//item%node%asFormattedStr()//', '
item => item%next
end do
str = str//item%node%asFormattedString()//']'
str = str//item%node%asFormattedStr()//']'
end function tList_asFormattedString
end function tList_asFormattedStr
!--------------------------------------------------------------------------------------------------
@ -476,51 +476,51 @@ end subroutine tList_append
!--------------------------------------------------------------------------------------------------
!> @brief Convert to float array (1D).
!> @brief Convert to real array (1D).
!--------------------------------------------------------------------------------------------------
function tList_as1dFloat(self)
function tList_as1dReal(self)
class(tList), intent(in), target :: self
real(pReal), dimension(:), allocatable :: tList_as1dFloat
real(pREAL), dimension(:), allocatable :: tList_as1dReal
integer :: i
type(tItem), pointer :: item
type(tScalar), pointer :: scalar
allocate(tList_as1dFloat(self%length))
allocate(tList_as1dReal(self%length))
item => self%first
do i = 1, self%length
scalar => item%node%asScalar()
tList_as1dFloat(i) = scalar%asFloat()
tList_as1dReal(i) = scalar%asReal()
item => item%next
end do
end function tList_as1dFloat
end function tList_as1dReal
!--------------------------------------------------------------------------------------------------
!> @brief Convert to float array (2D).
!> @brief Convert to real array (2D).
!--------------------------------------------------------------------------------------------------
function tList_as2dFloat(self)
function tList_as2dReal(self)
class(tList), intent(in), target :: self
real(pReal), dimension(:,:), allocatable :: tList_as2dFloat
real(pREAL), dimension(:,:), allocatable :: tList_as2dReal
integer :: i
type(tList), pointer :: row_data
row_data => self%get_list(1)
allocate(tList_as2dFloat(self%length,row_data%length))
allocate(tList_as2dReal(self%length,row_data%length))
do i = 1, self%length
row_data => self%get_list(i)
if (row_data%length /= size(tList_as2dFloat,2)) call IO_error(709,ext_msg='inconsistent column count in tList_as2dFloat')
tList_as2dFloat(i,:) = self%get_as1dFloat(i)
if (row_data%length /= size(tList_as2dReal,2)) call IO_error(709,ext_msg='inconsistent column count in tList_as2dReal')
tList_as2dReal(i,:) = self%get_as1dReal(i)
end do
end function tList_as2dFloat
end function tList_as2dReal
!--------------------------------------------------------------------------------------------------
@ -574,13 +574,13 @@ end function tList_as1dBool
!--------------------------------------------------------------------------------------------------
!> @brief Convert to string array (1D).
!--------------------------------------------------------------------------------------------------
function tList_as1dString(self)
function tList_as1dStr(self)
class(tList), intent(in), target :: self
#ifdef __GFORTRAN__
character(len=pStringLen), allocatable, dimension(:) :: tList_as1dString
character(len=pSTRLEN), allocatable, dimension(:) :: tList_as1dStr
#else
character(len=:), allocatable, dimension(:) :: tList_as1dString
character(len=:), allocatable, dimension(:) :: tList_as1dStr
#endif
integer :: j
@ -589,27 +589,27 @@ function tList_as1dString(self)
#ifdef __GFORTRAN__
allocate(tList_as1dString(self%length))
allocate(tList_as1dStr(self%length))
#else
integer :: len_max
len_max = 0
item => self%first
do j = 1, self%length
scalar => item%node%asScalar()
len_max = max(len_max, len_trim(scalar%asString()))
len_max = max(len_max, len_trim(scalar%asStr()))
item => item%next
end do
allocate(character(len=len_max) :: tList_as1dString(self%length))
allocate(character(len=len_max) :: tList_as1dStr(self%length))
#endif
item => self%first
do j = 1, self%length
scalar => item%node%asScalar()
tList_as1dString(j) = scalar%asString()
tList_as1dStr(j) = scalar%asStr()
item => item%next
end do
end function tList_as1dString
end function tList_as1dStr
!-------------------------------------------------------------------------------------------------
@ -652,8 +652,8 @@ function tList_get(self,i) result(node)
integer :: j
if (i < 1 .or. i > self%length) call IO_error(150,ext_msg='tList_get @ '//IO_intAsString(i) &
//' of '//IO_intAsString(self%length) )
if (i < 1 .or. i > self%length) call IO_error(150,ext_msg='tList_get @ '//IO_intAsStr(i) &
//' of '//IO_intAsStr(self%length) )
item => self%first
do j = 2, i
item => item%next
@ -718,39 +718,39 @@ end function tList_get_dict
!--------------------------------------------------------------------------------------------------
!> @brief Get scalar by index and convert to float.
!> @brief Get scalar by index and convert to real.
!--------------------------------------------------------------------------------------------------
function tList_get_asFloat(self,i) result(nodeAsFloat)
function tList_get_asReal(self,i) result(nodeAsReal)
class(tList), intent(in) :: self
integer, intent(in) :: i
real(pReal) :: nodeAsFloat
real(pREAL) :: nodeAsReal
class(tScalar), pointer :: scalar
scalar => self%get_scalar(i)
nodeAsFloat = scalar%asFloat()
nodeAsReal = scalar%asReal()
end function tList_get_asFloat
end function tList_get_asReal
!--------------------------------------------------------------------------------------------------
!> @brief Get list by index and convert to float array (1D).
!> @brief Get list by index and convert to real array (1D).
!--------------------------------------------------------------------------------------------------
function tList_get_as1dFloat(self,i) result(nodeAs1dFloat)
function tList_get_as1dReal(self,i) result(nodeAs1dReal)
class(tList), intent(in) :: self
integer, intent(in) :: i
real(pReal), dimension(:), allocatable :: nodeAs1dFloat
real(pREAL), dimension(:), allocatable :: nodeAs1dReal
class(tList), pointer :: list
list => self%get_list(i)
nodeAs1dFloat = list%as1dFloat()
nodeAs1dReal = list%as1dReal()
end function tList_get_as1dFloat
end function tList_get_as1dReal
!--------------------------------------------------------------------------------------------------
@ -828,37 +828,37 @@ end function tList_get_as1dBool
!--------------------------------------------------------------------------------------------------
!> @brief Get scalar by index and convert to string.
!--------------------------------------------------------------------------------------------------
function tList_get_asString(self,i) result(nodeAsString)
function tList_get_asStr(self,i) result(nodeAsStr)
class(tList), intent(in) :: self
integer, intent(in) :: i
character(len=:), allocatable :: nodeAsString
character(len=:), allocatable :: nodeAsStr
class(tScalar), pointer :: scalar
scalar => self%get_scalar(i)
nodeAsString = scalar%asString()
nodeAsStr = scalar%asStr()
end function tList_get_asString
end function tList_get_asStr
!--------------------------------------------------------------------------------------------------
!> @brief Get list by index and convert to string array (1D).
!--------------------------------------------------------------------------------------------------
function tList_get_as1dString(self,i) result(nodeAs1dString)
function tList_get_as1dStr(self,i) result(nodeAs1dStr)
class(tList), intent(in) :: self
integer, intent(in) :: i
character(len=:), allocatable, dimension(:) :: nodeAs1dString
character(len=:), allocatable, dimension(:) :: nodeAs1dStr
type(tList), pointer :: list
list => self%get_list(i)
nodeAs1dString = list%as1dString()
nodeAs1dStr = list%as1dStr()
end function tList_get_as1dString
end function tList_get_as1dStr
!--------------------------------------------------------------------------------------------------
@ -876,7 +876,7 @@ end subroutine tList_finalize
!--------------------------------------------------------------------------------------------------
!> @brief Format as string (YAML flow style).
!--------------------------------------------------------------------------------------------------
recursive function tDict_asFormattedString(self) result(str)
recursive function tDict_asFormattedStr(self) result(str)
class(tDict),intent(in),target :: self
@ -888,12 +888,12 @@ recursive function tDict_asFormattedString(self) result(str)
str = '{'
item => self%first
do i = 2, self%length
str = str//trim(item%key)//': '//item%node%asFormattedString()//', '
str = str//trim(item%key)//': '//item%node%asFormattedStr()//', '
item => item%next
end do
str = str//trim(item%key)//': '//item%node%asFormattedString()//'}'
str = str//trim(item%key)//': '//item%node%asFormattedStr()//'}'
end function tDict_asFormattedString
end function tDict_asFormattedStr
!--------------------------------------------------------------------------------------------------
@ -967,8 +967,8 @@ function tDict_key(self,i) result(key)
type(tItem), pointer :: item
if (i < 1 .or. i > self%length) call IO_error(150,ext_msg='tDict_key @ '//IO_intAsString(i) &
//' of '//IO_intAsString(self%length) )
if (i < 1 .or. i > self%length) call IO_error(150,ext_msg='tDict_key @ '//IO_intAsStr(i) &
//' of '//IO_intAsStr(self%length) )
item => self%first
do j = 2, i
item => item%next
@ -987,7 +987,7 @@ function tDict_keys(self) result(keys)
class(tDict), intent(in) :: self
character(len=:), dimension(:), allocatable :: keys
character(len=pStringLen), dimension(:), allocatable :: temp
character(len=pSTRLEN), dimension(:), allocatable :: temp
integer :: j, l
@ -1118,88 +1118,88 @@ end function tDict_get_dict
!--------------------------------------------------------------------------------------------------
!> @brief Get scalar by key and convert to float.
!> @brief Get scalar by key and convert to real.
!--------------------------------------------------------------------------------------------------
function tDict_get_asFloat(self,k,defaultVal) result(nodeAsFloat)
function tDict_get_asReal(self,k,defaultVal) result(nodeAsReal)
class(tDict), intent(in) :: self
character(len=*), intent(in) :: k
real(pReal), intent(in), optional :: defaultVal
real(pReal) :: nodeAsFloat
real(pREAL), intent(in), optional :: defaultVal
real(pREAL) :: nodeAsReal
type(tScalar), pointer :: scalar
if (self%contains(k)) then
scalar => self%get_scalar(k)
nodeAsFloat = scalar%asFloat()
nodeAsReal = scalar%asReal()
elseif (present(defaultVal)) then
nodeAsFloat = defaultVal
nodeAsReal = defaultVal
else
call IO_error(143,ext_msg=k)
end if
end function tDict_get_asFloat
end function tDict_get_asReal
!--------------------------------------------------------------------------------------------------
!> @brief Get list by key and convert to float array (1D).
!> @brief Get list by key and convert to real array (1D).
!--------------------------------------------------------------------------------------------------
function tDict_get_as1dFloat(self,k,defaultVal,requiredSize) result(nodeAs1dFloat)
function tDict_get_as1dReal(self,k,defaultVal,requiredSize) result(nodeAs1dReal)
class(tDict), intent(in) :: self
character(len=*), intent(in) :: k
real(pReal), intent(in), dimension(:), optional :: defaultVal
real(pREAL), intent(in), dimension(:), optional :: defaultVal
integer, intent(in), optional :: requiredSize
real(pReal), dimension(:), allocatable :: nodeAs1dFloat
real(pREAL), dimension(:), allocatable :: nodeAs1dReal
type(tList), pointer :: list
if (self%contains(k)) then
list => self%get_list(k)
nodeAs1dFloat = list%as1dFloat()
nodeAs1dReal = list%as1dReal()
elseif (present(defaultVal)) then
nodeAs1dFloat = defaultVal
nodeAs1dReal = defaultVal
else
call IO_error(143,ext_msg=k)
end if
if (present(requiredSize)) then
if (requiredSize /= size(nodeAs1dFloat)) call IO_error(146,ext_msg=k)
if (requiredSize /= size(nodeAs1dReal)) call IO_error(146,ext_msg=k)
end if
end function tDict_get_as1dFloat
end function tDict_get_as1dReal
!--------------------------------------------------------------------------------------------------
!> @brief Get list of lists by key and convert to float array (2D).
!> @brief Get list of lists by key and convert to real array (2D).
!--------------------------------------------------------------------------------------------------
function tDict_get_as2dFloat(self,k,defaultVal,requiredShape) result(nodeAs2dFloat)
function tDict_get_as2dReal(self,k,defaultVal,requiredShape) result(nodeAs2dReal)
class(tDict), intent(in) :: self
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
real(pReal), dimension(:,:), allocatable :: nodeAs2dFloat
real(pREAL), dimension(:,:), allocatable :: nodeAs2dReal
type(tList), pointer :: list
if (self%contains(k)) then
list => self%get_list(k)
nodeAs2dFloat = list%as2dFloat()
nodeAs2dReal = list%as2dReal()
elseif (present(defaultVal)) then
nodeAs2dFloat = defaultVal
nodeAs2dReal = defaultVal
else
call IO_error(143,ext_msg=k)
end if
if (present(requiredShape)) then
if (any(requiredShape /= shape(nodeAs2dFloat))) call IO_error(146,ext_msg=k)
if (any(requiredShape /= shape(nodeAs2dReal))) call IO_error(146,ext_msg=k)
end if
end function tDict_get_as2dFloat
end function tDict_get_as2dReal
!--------------------------------------------------------------------------------------------------
@ -1310,61 +1310,61 @@ end function tDict_get_as1dBool
!--------------------------------------------------------------------------------------------------
!> @brief Get scalar by key and convert to string.
!--------------------------------------------------------------------------------------------------
function tDict_get_asString(self,k,defaultVal) result(nodeAsString)
function tDict_get_asStr(self,k,defaultVal) result(nodeAsStr)
class(tDict), intent(in) :: self
character(len=*), intent(in) :: k
character(len=*), intent(in), optional :: defaultVal
character(len=:), allocatable :: nodeAsString
character(len=:), allocatable :: nodeAsStr
type(tScalar), pointer :: scalar
if (self%contains(k)) then
scalar => self%get_scalar(k)
nodeAsString = scalar%asString()
nodeAsStr = scalar%asStr()
elseif (present(defaultVal)) then
nodeAsString = defaultVal
nodeAsStr = defaultVal
else
call IO_error(143,ext_msg=k)
end if
end function tDict_get_asString
end function tDict_get_asStr
!--------------------------------------------------------------------------------------------------
!> @brief Get list by key and convert to string array (1D).
!--------------------------------------------------------------------------------------------------
function tDict_get_as1dString(self,k,defaultVal) result(nodeAs1dString)
function tDict_get_as1dStr(self,k,defaultVal) result(nodeAs1dStr)
class(tDict), intent(in) :: self
character(len=*), intent(in) :: k
character(len=*), intent(in), dimension(:), optional :: defaultVal
character(len=:), allocatable, dimension(:) :: nodeAs1dString
character(len=:), allocatable, dimension(:) :: nodeAs1dStr
type(tList), pointer :: list
if (self%contains(k)) then
list => self%get_list(k)
nodeAs1dString = list%as1dString()
nodeAs1dStr = list%as1dStr()
elseif (present(defaultVal)) then
nodeAs1dString = defaultVal
nodeAs1dStr = defaultVal
else
call IO_error(143,ext_msg=k)
end if
end function tDict_get_as1dString
end function tDict_get_as1dStr
#ifdef __GFORTRAN__
!--------------------------------------------------------------------------------------------------
!> @brief Returns string output array (1D) (hack for GNU).
!--------------------------------------------------------------------------------------------------
function output_as1dString(self) result(output)
function output_as1dStr(self) result(output)
class(tDict), pointer,intent(in) :: self
character(len=pStringLen), allocatable, dimension(:) :: output
character(len=pSTRLEN), allocatable, dimension(:) :: output
type(tList), pointer :: output_list
integer :: o
@ -1372,10 +1372,10 @@ function output_as1dString(self) result(output)
output_list => self%get_list('output',defaultVal=emptyList)
allocate(output(output_list%length))
do o = 1, output_list%length
output(o) = output_list%get_asString(o)
output(o) = output_list%get_asStr(o)
end do
end function output_as1dString
end function output_as1dStr
#endif

2
src/config.f90
View File

@ -83,7 +83,7 @@ function config_listReferences(config,indent) result(references)
else
references = 'references:'
do r = 1, ref%length
references = references//IO_EOL//filler//'- '//IO_wrapLines(ref%get_asString(r),filler=filler//' ')
references = references//IO_EOL//filler//'- '//IO_wrapLines(ref%get_asStr(r),filler=filler//' ')
end do
end if

8
src/constants.f90
View File

@ -8,9 +8,9 @@ module constants
implicit none(type,external)
public
real(pReal), parameter :: &
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)
N_A = 6.02214076e23_pReal !< Avogadro constant in 1/mol (https://doi.org/10.1351/goldbook)
real(pREAL), parameter :: &
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)
N_A = 6.02214076e23_pREAL !< Avogadro constant in 1/mol (https://doi.org/10.1351/goldbook)
end module constants

10
src/discretization.f90
View File

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

18
src/geometry_plastic_nonlocal.f90
View File

@ -18,13 +18,13 @@ module geometry_plastic_nonlocal
integer, dimension(:,:,:,:), allocatable, protected :: &
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!)
real(pReal), dimension(:,:,:), allocatable, protected :: &
real(pREAL), dimension(:,:,:), allocatable, protected :: &
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!)
@ -54,7 +54,7 @@ end subroutine geometry_plastic_nonlocal_setIPneighborhood
!---------------------------------------------------------------------------------------------------
subroutine geometry_plastic_nonlocal_setIPvolume(IPvolume)
real(pReal), dimension(:,:), intent(in) :: IPvolume
real(pREAL), dimension(:,:), intent(in) :: IPvolume
geometry_plastic_nonlocal_IPvolume0 = IPvolume
@ -67,7 +67,7 @@ end subroutine geometry_plastic_nonlocal_setIPvolume
!---------------------------------------------------------------------------------------------------
subroutine geometry_plastic_nonlocal_setIParea(IParea)
real(pReal), dimension(:,:,:), intent(in) :: IParea
real(pREAL), dimension(:,:,:), intent(in) :: IParea
geometry_plastic_nonlocal_IParea0 = IParea
@ -80,7 +80,7 @@ end subroutine geometry_plastic_nonlocal_setIParea
!---------------------------------------------------------------------------------------------------
subroutine geometry_plastic_nonlocal_setIPareaNormal(IPareaNormal)
real(pReal), dimension(:,:,:,:), intent(in) :: IPareaNormal
real(pREAL), dimension(:,:,:,:), intent(in) :: IPareaNormal
geometry_plastic_nonlocal_IPareaNormal0 = IPareaNormal
@ -117,7 +117,7 @@ subroutine geometry_plastic_nonlocal_result()
call result_openJobFile()
writeVolume: block
real(pReal), dimension(:), allocatable :: temp
real(pREAL), dimension(:), allocatable :: temp
shp = shape(geometry_plastic_nonlocal_IPvolume0)
temp = reshape(geometry_plastic_nonlocal_IPvolume0,[shp(1)*shp(2)])
call result_writeDataset(temp,'geometry','v_0',&
@ -125,7 +125,7 @@ subroutine geometry_plastic_nonlocal_result()
end block writeVolume
writeAreas: block
real(pReal), dimension(:,:), allocatable :: temp
real(pREAL), dimension(:,:), allocatable :: temp
shp = shape(geometry_plastic_nonlocal_IParea0)
temp = reshape(geometry_plastic_nonlocal_IParea0,[shp(1),shp(2)*shp(3)])
call result_writeDataset(temp,'geometry','a_0',&
@ -133,7 +133,7 @@ subroutine geometry_plastic_nonlocal_result()
end block writeAreas
writeNormals: block
real(pReal), dimension(:,:,:), allocatable :: temp
real(pREAL), dimension(:,:,:), allocatable :: temp
shp = shape(geometry_plastic_nonlocal_IPareaNormal0)
temp = reshape(geometry_plastic_nonlocal_IPareaNormal0,[shp(1),shp(2),shp(3)*shp(4)])
call result_writeDataset(temp,'geometry','n_0',&

64
src/grid/DAMASK_grid.f90
View File

@ -40,7 +40,7 @@ program DAMASK_grid
type(tRotation) :: rot !< rotation of BC
type(tBoundaryCondition) :: stress, & !< stress BC
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
integer :: N, & !< number of increments
f_out, & !< frequency of result writes
@ -63,12 +63,12 @@ program DAMASK_grid
! loop variables, convergence etc.
integer, parameter :: &
subStepFactor = 2 !< for each substep, divide the last time increment by 2.0
real(pReal) :: &
t = 0.0_pReal, & !< elapsed time
t_0 = 0.0_pReal, & !< begin of interval
Delta_t = 1.0_pReal, & !< current time interval
Delta_t_prev = 0.0_pReal, & !< previous time interval
t_remaining = 0.0_pReal !< remaining time of current load case
real(pREAL) :: &
t = 0.0_pREAL, & !< elapsed time
t_0 = 0.0_pREAL, & !< begin of interval
Delta_t = 1.0_pREAL, & !< current time interval
Delta_t_prev = 0.0_pREAL, & !< previous time interval
t_remaining = 0.0_pREAL !< remaining time of current load case
logical :: &
guess, & !< guess along former trajectory
stagIterate, &
@ -88,7 +88,7 @@ program DAMASK_grid
maxCutBack, & !< max number of cut backs
stagItMax !< max number of field level staggered iterations
integer(MPI_INTEGER_KIND) :: err_MPI
character(len=pStringLen) :: &
character(len=pSTRLEN) :: &
incInfo
type(tLoadCase), allocatable, dimension(:) :: loadCases !< array of all load cases
@ -158,7 +158,7 @@ program DAMASK_grid
! assign mechanics solver depending on selected type
nActiveFields = 1
select case (solver%get_asString('mechanical'))
select case (solver%get_asStr('mechanical'))
case ('spectral_basic')
mechanical_init => grid_mechanical_spectral_basic_init
mechanical_forward => grid_mechanical_spectral_basic_forward
@ -181,25 +181,25 @@ program DAMASK_grid
mechanical_restartWrite => grid_mechanical_FEM_restartWrite
case default
call IO_error(error_ID = 891, ext_msg = trim(solver%get_asString('mechanical')))
call IO_error(error_ID = 891, ext_msg = trim(solver%get_asStr('mechanical')))
end select
!--------------------------------------------------------------------------------------------------
! initialize field solver information
if (solver%get_asString('thermal',defaultVal = 'n/a') == 'spectral') nActiveFields = nActiveFields + 1
if (solver%get_asString('damage', defaultVal = 'n/a') == 'spectral') nActiveFields = nActiveFields + 1
if (solver%get_asStr('thermal',defaultVal = 'n/a') == 'spectral') nActiveFields = nActiveFields + 1
if (solver%get_asStr('damage', defaultVal = 'n/a') == 'spectral') nActiveFields = nActiveFields + 1
allocate(solres(nActiveFields))
allocate( ID(nActiveFields))
field = 1
ID(field) = FIELD_MECH_ID ! mechanical active by default
thermalActive: if (solver%get_asString('thermal',defaultVal = 'n/a') == 'spectral') then
thermalActive: if (solver%get_asStr('thermal',defaultVal = 'n/a') == 'spectral') then
field = field + 1
ID(field) = FIELD_THERMAL_ID
end if thermalActive
damageActive: if (solver%get_asString('damage',defaultVal = 'n/a') == 'spectral') then
damageActive: if (solver%get_asStr('damage',defaultVal = 'n/a') == 'spectral') then
field = field + 1
ID(field) = FIELD_DAMAGE_ID
end if damageActive
@ -234,17 +234,17 @@ program DAMASK_grid
call getMaskedTensor(loadCases(l)%stress%values,loadCases(l)%stress%mask,step_mech%get_list(m))
#endif
end select
call loadCases(l)%rot%fromAxisAngle(step_mech%get_as1dFloat('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
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')
loadCases(l)%t = step_discretization%get_asFloat('t')
loadCases(l)%t = step_discretization%get_asReal('t')
loadCases(l)%N = step_discretization%get_asInt ('N')
loadCases(l)%r = step_discretization%get_asFloat('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))
if (load_step%get_asString('f_out',defaultVal='n/a') == 'none') then
if (load_step%get_asStr('f_out',defaultVal='n/a') == 'none') then
loadCases(l)%f_out = huge(0)
else
loadCases(l)%f_out = load_step%get_asInt('f_out', defaultVal=1)
@ -279,7 +279,7 @@ program DAMASK_grid
if (loadCases(l)%stress%mask(i,j)) then
write(IO_STDOUT,'(2x,12a)',advance='no') ' x '
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 do; write(IO_STDOUT,'(/)',advance='no')
end do
@ -288,13 +288,13 @@ program DAMASK_grid
write(IO_STDOUT,'(2x,a,/,3(3(3x,f12.7,1x)/))',advance='no') 'R:',&
transpose(loadCases(l)%rot%asMatrix())
if (loadCases(l)%r <= 0.0_pReal) errorID = 833
if (loadCases(l)%t < 0.0_pReal) errorID = 834
if (loadCases(l)%r <= 0.0_pREAL) errorID = 833
if (loadCases(l)%t < 0.0_pREAL) errorID = 834
if (loadCases(l)%N < 1) errorID = 835
if (loadCases(l)%f_out < 1) errorID = 836
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)'
else
print'(2x,a,1x,f0.3)', 'r:', loadCases(l)%r
@ -345,7 +345,7 @@ program DAMASK_grid
writeUndeformed: if (CLI_restartInc < 1) then
print'(/,1x,a)', '... writing initial configuration to file .................................'
flush(IO_STDOUT)
call materialpoint_result(0,0.0_pReal)
call materialpoint_result(0,0.0_pREAL)
end if writeUndeformed
loadCaseLooping: do l = 1, size(loadCases)
@ -358,13 +358,13 @@ program DAMASK_grid
!--------------------------------------------------------------------------------------------------
! forwarding time
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
Delta_t = loadCases(l)%t/real(loadCases(l)%N,pReal)
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)
else
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
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?
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
cutBackLevel = cutBackLevel + 1
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 '
else ! no more options to continue
if (worldrank == 0) close(statUnit)
@ -513,7 +513,7 @@ contains
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
type(tList), pointer :: tensor
@ -521,12 +521,12 @@ subroutine getMaskedTensor(values,mask,tensor)
integer :: i,j
values = 0.0_pReal
values = 0.0_pREAL
do i = 1,3
row => tensor%get_list(i)
do j = 1,3
mask(i,j) = row%get_asString(j) == 'x'
if (.not. mask(i,j)) values(i,j) = row%get_asFloat(j)
mask(i,j) = row%get_asStr(j) == 'x'
if (.not. mask(i,j)) values(i,j) = row%get_asReal(j)
end do
end do

32
src/grid/VTI.f90
View File

@ -50,7 +50,7 @@ function VTI_readDataset_real(fileContent,label) result(dataset)
character(len=*), intent(in) :: &
label, &
fileContent
real(pReal), dimension(:), allocatable :: &
real(pREAL), dimension(:), allocatable :: &
dataset
character(len=:), allocatable :: dataType, headerType, base64Str
@ -143,7 +143,7 @@ subroutine VTI_readCellsSizeOrigin(cells,geomSize,origin, &
integer, dimension(3), intent(out) :: &
cells ! # of cells (across all processes!)
real(pReal), dimension(3), intent(out) :: &
real(pREAL), dimension(3), intent(out) :: &
geomSize, & ! size (across all processes!)
origin ! origin (across all processes!)
character(len=*), intent(in) :: &
@ -156,7 +156,7 @@ subroutine VTI_readCellsSizeOrigin(cells,geomSize,origin, &
cells = -1
geomSize = -1.0_pReal
geomSize = -1.0_pREAL
inFile = .false.
inImage = .false.
@ -198,11 +198,11 @@ end subroutine VTI_readCellsSizeOrigin
subroutine cellsSizeOrigin(c,s,o,header)
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=:), allocatable :: temp
real(pReal), dimension(3) :: delta
real(pREAL), dimension(3) :: delta
integer :: i
@ -211,16 +211,16 @@ subroutine cellsSizeOrigin(c,s,o,header)
call IO_error(error_ID = 844, ext_msg = 'coordinate order')
temp = getXMLValue(header,'WholeExtent')
if (any([(IO_intValue(temp,IO_stringPos(temp),i),i=1,5,2)] /= 0)) &
if (any([(IO_intValue(temp,IO_strPos(temp),i),i=1,5,2)] /= 0)) &
call IO_error(error_ID = 844, ext_msg = 'coordinate start')
c = [(IO_intValue(temp,IO_stringPos(temp),i),i=2,6,2)]
c = [(IO_intValue(temp,IO_strPos(temp),i),i=2,6,2)]
temp = getXMLValue(header,'Spacing')
delta = [(IO_floatValue(temp,IO_stringPos(temp),i),i=1,3)]
s = delta * real(c,pReal)
delta = [(IO_realValue(temp,IO_strPos(temp),i),i=1,3)]
s = delta * real(c,pREAL)
temp = getXMLValue(header,'Origin')
o = [(IO_floatValue(temp,IO_stringPos(temp),i),i=1,3)]
o = [(IO_realValue(temp,IO_strPos(temp),i),i=1,3)]
end subroutine cellsSizeOrigin
@ -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)
@ -264,18 +264,18 @@ function as_real(base64Str,headerType,compressed,dataType)
dataType ! data type (Int32, Int64, Float32, Float64)
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)
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')
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')
as_real = real(prec_bytesToC_FLOAT (asBytes(base64Str,headerType,compressed)),pReal)
as_real = real(prec_bytesToC_FLOAT (asBytes(base64Str,headerType,compressed)),pREAL)
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
call IO_error(844,ext_msg='unknown data type: '//trim(dataType))
end select

52
src/grid/discretization_grid.f90
View File

@ -35,9 +35,9 @@ module discretization_grid
integer, public, protected :: &
cells3, & !< (local) cells 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
real(pReal), public, protected :: &
real(pREAL), public, protected :: &
size3, & !< (local) size in 3rd direction
size3offset !< (local) size offset in 3rd direction
@ -55,7 +55,7 @@ subroutine discretization_grid_init(restart)
logical, intent(in) :: restart
real(pReal), dimension(3) :: &
real(pREAL), dimension(3) :: &
mySize, & !< domain size of this process
origin !< (global) distance to origin
integer, dimension(3) :: &
@ -119,8 +119,8 @@ subroutine discretization_grid_init(restart)
cells3 = int(z)
cells3Offset = int(z_offset)
size3 = geomSize(3)*real(cells3,pReal) /real(cells(3),pReal)
size3Offset = geomSize(3)*real(cells3Offset,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)
myGrid = [cells(1:2),cells3]
mySize = [geomSize(1:2),size3]
@ -156,7 +156,7 @@ subroutine discretization_grid_init(restart)
!--------------------------------------------------------------------------------------------------
! 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)]))
call geometry_plastic_nonlocal_setIParea (cellSurfaceArea(mySize,myGrid))
call geometry_plastic_nonlocal_setIPareaNormal (cellSurfaceNormal(product(myGrid)))
@ -171,10 +171,10 @@ end subroutine discretization_grid_init
function IPcoordinates0(cells,geomSize,cells3Offset)
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
real(pReal), dimension(3,product(cells)) :: ipCoordinates0
real(pREAL), dimension(3,product(cells)) :: ipCoordinates0
integer :: &
a,b,c, &
@ -184,7 +184,7 @@ function IPcoordinates0(cells,geomSize,cells3Offset)
i = 0
do c = 1, cells(3); do b = 1, cells(2); do a = 1, cells(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 function IPcoordinates0
@ -196,10 +196,10 @@ end function IPcoordinates0
pure function nodes0(cells,geomSize,cells3Offset)
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
real(pReal), dimension(3,product(cells+1)) :: nodes0
real(pREAL), dimension(3,product(cells+1)) :: nodes0
integer :: &
a,b,c, &
@ -208,7 +208,7 @@ pure function nodes0(cells,geomSize,cells3Offset)
n = 0
do c = 0, cells3; do b = 0, cells(2); do a = 0, cells(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 function nodes0
@ -219,15 +219,15 @@ end function nodes0
!--------------------------------------------------------------------------------------------------
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!)
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(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(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(5:6,1,:) = geomSize(1)/real(cells(1),pREAL) * geomSize(2)/real(cells(2),pREAL)
end function cellSurfaceArea
@ -239,14 +239,14 @@ pure function cellSurfaceNormal(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,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,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,6,1,:) = spread([ 0.0_pReal, 0.0_pReal,-1.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,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,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)
end function cellSurfaceNormal
@ -314,9 +314,9 @@ end function IPneighborhood
function discretization_grid_getInitialCondition(label) result(ic)
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, dimension(worldsize) :: &

46
src/grid/grid_damage_spectral.f90
View File

@ -35,7 +35,7 @@ module grid_damage_spectral
type :: tNumerics
integer :: &
itmax !< maximum number of iterations
real(pReal) :: &
real(pREAL) :: &
phi_min, & !< non-zero residual damage
eps_damage_atol, & !< absolute tolerance for damage evolution
eps_damage_rtol !< relative tolerance for damage evolution
@ -48,7 +48,7 @@ module grid_damage_spectral
! PETSc data
SNES :: SNES_damage
Vec :: solution_vec
real(pReal), dimension(:,:,:), allocatable :: &
real(pREAL), dimension(:,:,:), allocatable :: &
phi, & !< field of current damage
phi_lastInc, & !< field of previous damage
phi_stagInc !< field of staggered damage
@ -56,8 +56,8 @@ module grid_damage_spectral
!--------------------------------------------------------------------------------------------------
! reference diffusion tensor, mobility etc.
integer :: totalIter = 0 !< total iteration in current increment
real(pReal), dimension(3,3) :: K_ref
real(pReal) :: mu_ref
real(pREAL), dimension(3,3) :: K_ref
real(pREAL) :: mu_ref
public :: &
grid_damage_spectral_init, &
@ -75,16 +75,16 @@ subroutine grid_damage_spectral_init()
PetscInt, dimension(0:worldsize-1) :: localK
integer :: i, j, k, ce
DM :: damage_grid
real(pReal), dimension(:,:,:), pointer :: phi_PETSc
real(pREAL), dimension(:,:,:), pointer :: phi_PETSc
Vec :: uBound, lBound
integer(MPI_INTEGER_KIND) :: err_MPI
PetscErrorCode :: err_PETSc
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 :: &
num_grid, &
num_generic
character(len=pStringLen) :: &
character(len=pSTRLEN) :: &
snes_type
print'(/,1x,a)', '<<<+- grid_spectral_damage init -+>>>'
@ -98,23 +98,23 @@ subroutine grid_damage_spectral_init()
! read numerical parameters and do sanity checks
num_grid => config_numerics%get_dict('grid',defaultVal=emptyDict)
num%itmax = num_grid%get_asInt ('itmax',defaultVal=250)
num%eps_damage_atol = num_grid%get_asFloat ('eps_damage_atol',defaultVal=1.0e-2_pReal)
num%eps_damage_rtol = num_grid%get_asFloat ('eps_damage_rtol',defaultVal=1.0e-6_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_generic => config_numerics%get_dict('generic',defaultVal=emptyDict)
num%phi_min = num_generic%get_asFloat('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%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_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')
!--------------------------------------------------------------------------------------------------
! set default and user defined options for PETSc
call PetscOptionsInsertString(PETSC_NULL_OPTIONS,'-damage_snes_type newtonls -damage_snes_mf &
&-damage_snes_ksp_ew -damage_ksp_type fgmres',err_PETSc)
CHKERRQ(err_PETSc)
call PetscOptionsInsertString(PETSC_NULL_OPTIONS,num_grid%get_asString('petsc_options',defaultVal=''),err_PETSc)
call PetscOptionsInsertString(PETSC_NULL_OPTIONS,num_grid%get_asStr('petsc_options',defaultVal=''),err_PETSc)
CHKERRQ(err_PETSc)
!--------------------------------------------------------------------------------------------------
@ -162,9 +162,9 @@ subroutine grid_damage_spectral_init()
CHKERRQ(err_PETSc)
call DMGetGlobalVector(damage_grid,uBound,err_PETSc)
CHKERRQ(err_PETSc)
call VecSet(lBound,0.0_pReal,err_PETSc)
call VecSet(lBound,0.0_pREAL,err_PETSc)
CHKERRQ(err_PETSc)
call VecSet(uBound,1.0_pReal,err_PETSc)
call VecSet(uBound,1.0_pREAL,err_PETSc)
CHKERRQ(err_PETSc)
call SNESVISetVariableBounds(SNES_damage,lBound,uBound,err_PETSc) ! variable bounds for variational inequalities
CHKERRQ(err_PETSc)
@ -208,7 +208,7 @@ end subroutine grid_damage_spectral_init
!--------------------------------------------------------------------------------------------------
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
integer :: i, j, k, ce
type(tSolutionState) :: solution
@ -275,7 +275,7 @@ subroutine grid_damage_spectral_forward(cutBack)
integer :: i, j, k, ce
DM :: dm_local
real(pReal), dimension(:,:,:), pointer :: phi_PETSc
real(pREAL), dimension(:,:,:), pointer :: phi_PETSc
PetscErrorCode :: err_PETSc
@ -341,15 +341,15 @@ subroutine formResidual(residual_subdomain,x_scal,r,dummy,err_PETSc)
DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: &
residual_subdomain
real(pReal), dimension(cells(1),cells(2),cells3), intent(in) :: &
real(pREAL), dimension(cells(1),cells(2),cells3), intent(in) :: &
x_scal
real(pReal), dimension(cells(1),cells(2),cells3), intent(out) :: &
real(pREAL), dimension(cells(1),cells(2),cells3), intent(out) :: &
r !< residual
PetscObject :: dummy
PetscErrorCode, intent(out) :: err_PETSc
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
@ -384,8 +384,8 @@ subroutine updateReference()
integer(MPI_INTEGER_KIND) :: err_MPI
K_ref = 0.0_pReal
mu_ref = 0.0_pReal
K_ref = 0.0_pREAL
mu_ref = 0.0_pREAL
do ce = 1, product(cells(1:2))*cells3
K_ref = K_ref + homogenization_K_phi(ce)
mu_ref = mu_ref + homogenization_mu_phi(ce)

170
src/grid/grid_mech_FEM.f90
View File

@ -41,7 +41,7 @@ module grid_mechanical_FEM
integer :: &
itmin, & !< minimum number of iterations
itmax !< maximum number of iterations
real(pReal) :: &
real(pREAL) :: &
eps_div_atol, & !< absolute tolerance for equilibrium
eps_div_rtol, & !< relative tolerance for equilibrium
eps_stress_atol, & !< absolute tolerance for fullfillment of stress BC
@ -58,27 +58,27 @@ module grid_mechanical_FEM
!--------------------------------------------------------------------------------------------------
! common pointwise data
real(pReal), dimension(:,:,:,:,:), allocatable :: F, P_current, F_lastInc
real(pReal) :: detJ
real(pReal), dimension(3) :: delta
real(pReal), dimension(3,8) :: BMat
real(pReal), dimension(8,8) :: HGMat
real(pREAL), dimension(:,:,:,:,:), allocatable :: F, P_current, F_lastInc
real(pREAL) :: detJ
real(pREAL), dimension(3) :: delta
real(pREAL), dimension(3,8) :: BMat
real(pREAL), dimension(8,8) :: HGMat
!--------------------------------------------------------------------------------------------------
! stress, stiffness and compliance average etc.
real(pReal), dimension(3,3) :: &
F_aimDot = 0.0_pReal, & !< assumed rate of average deformation gradient
real(pREAL), dimension(3,3) :: &
F_aimDot = 0.0_pREAL, & !< assumed rate of average deformation gradient
F_aim = math_I3, & !< current prescribed deformation gradient
F_aim_lastInc = math_I3, & !< previous average deformation gradient
P_av = 0.0_pReal, & !< average 1st Piola--Kirchhoff stress
P_aim = 0.0_pReal
P_av = 0.0_pREAL, & !< average 1st Piola--Kirchhoff stress
P_aim = 0.0_pREAL
character(len=:), allocatable :: incInfo !< time and increment information
real(pReal), dimension(3,3,3,3) :: &
C_volAvg = 0.0_pReal, & !< current volume average stiffness
C_volAvgLastInc = 0.0_pReal, & !< previous volume average stiffness
S = 0.0_pReal !< current compliance (filled up with zeros)
real(pREAL), dimension(3,3,3,3) :: &
C_volAvg = 0.0_pREAL, & !< current volume average stiffness
C_volAvgLastInc = 0.0_pREAL, & !< previous volume average stiffness
S = 0.0_pREAL !< current compliance (filled up with zeros)
real(pReal) :: &
real(pREAL) :: &
err_BC !< deviation from stress BC
integer :: &
@ -98,19 +98,19 @@ contains
!--------------------------------------------------------------------------------------------------
subroutine grid_mechanical_FEM_init
real(pReal), parameter :: HGCoeff = 0.0e-2_pReal
real(pReal), parameter, dimension(4,8) :: &
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], [4,8])
real(pReal), dimension(3,3,3,3) :: devNull
real(pReal), dimension(3,3,product(cells(1:2))*cells3) :: temp33n
real(pReal), dimension(3,product(cells(1:2))*cells3) :: temp3n
real(pREAL), parameter :: HGCoeff = 0.0e-2_pREAL
real(pREAL), parameter, dimension(4,8) :: &
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], [4,8])
real(pREAL), dimension(3,3,3,3) :: devNull
real(pREAL), dimension(3,3,product(cells(1:2))*cells3) :: temp33n
real(pREAL), dimension(3,product(cells(1:2))*cells3) :: temp3n
PetscErrorCode :: err_PETSc
integer(MPI_INTEGER_KIND) :: err_MPI
PetscScalar, pointer, dimension(:,:,:,:) :: &
@ -119,7 +119,7 @@ subroutine grid_mechanical_FEM_init
integer(HID_T) :: fileHandle, groupHandle
type(tDict), pointer :: &
num_grid
character(len=pStringLen) :: &
character(len=pSTRLEN) :: &
extmsg = ''
@ -129,17 +129,17 @@ subroutine grid_mechanical_FEM_init
! read numerical parameters and do sanity checks
num_grid => config_numerics%get_dict('grid',defaultVal=emptyDict)
num%eps_div_atol = num_grid%get_asFloat('eps_div_atol', defaultVal=1.0e-4_pReal)
num%eps_div_rtol = num_grid%get_asFloat('eps_div_rtol', defaultVal=5.0e-4_pReal)
num%eps_stress_atol = num_grid%get_asFloat('eps_stress_atol',defaultVal=1.0e3_pReal)
num%eps_stress_rtol = num_grid%get_asFloat('eps_stress_rtol',defaultVal=1.0e-3_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_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%itmin = num_grid%get_asInt ('itmin',defaultVal=1)
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_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_rtol < 0.0_pReal) extmsg = trim(extmsg)//' eps_stress_rtol'
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_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%itmax <= 1) extmsg = trim(extmsg)//' itmax'
if (num%itmin > num%itmax .or. num%itmin < 1) extmsg = trim(extmsg)//' itmin'
@ -152,14 +152,14 @@ subroutine grid_mechanical_FEM_init
&-mechanical_ksp_max_it 25', &
err_PETSc)
CHKERRQ(err_PETSc)
call PetscOptionsInsertString(PETSC_NULL_OPTIONS,num_grid%get_asString('petsc_options',defaultVal=''),err_PETSc)
call PetscOptionsInsertString(PETSC_NULL_OPTIONS,num_grid%get_asStr('petsc_options',defaultVal=''),err_PETSc)
CHKERRQ(err_PETSc)
!--------------------------------------------------------------------------------------------------
! allocate global fields
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(F_lastInc (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(F_lastInc (3,3,cells(1),cells(2),cells3),source = 0.0_pREAL)
!--------------------------------------------------------------------------------------------------
! initialize solver specific parts of PETSc
@ -184,7 +184,7 @@ subroutine grid_mechanical_FEM_init
CHKERRQ(err_PETSc)
call DMsetUp(mechanical_grid,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)
call DMCreateGlobalVector(mechanical_grid,solution_current,err_PETSc)
CHKERRQ(err_PETSc)
@ -207,18 +207,18 @@ subroutine grid_mechanical_FEM_init
!--------------------------------------------------------------------------------------------------
! init fields
call VecSet(solution_current,0.0_pReal,err_PETSc)
call VecSet(solution_current,0.0_pREAL,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)
call VecSet(solution_rate ,0.0_pReal,err_PETSc)
call VecSet(solution_rate ,0.0_pREAL,err_PETSc)
CHKERRQ(err_PETSc)
call DMDAVecGetArrayF90(mechanical_grid,solution_current,u,err_PETSc)
CHKERRQ(err_PETSc)
call DMDAVecGetArrayF90(mechanical_grid,solution_lastInc,u_lastInc,err_PETSc)
CHKERRQ(err_PETSc)
delta = geomSize/real(cells,pReal) ! grid spacing
delta = geomSize/real(cells,pREAL) ! grid spacing
detJ = product(delta) ! cell volume
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)],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) &
* 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
@ -271,7 +271,7 @@ subroutine grid_mechanical_FEM_init
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
F, & ! target F
0.0_pReal) ! time increment
0.0_pREAL) ! time increment
call DMDAVecRestoreArrayF90(mechanical_grid,solution_current,u,err_PETSc)
CHKERRQ(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) :: &
cutBack, &
guess
real(pReal), intent(in) :: &
real(pREAL), intent(in) :: &
Delta_t_old, &
Delta_t, &
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
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
!-----------------------------------------------------------------------------------------------
! calculate rate for aim
if (deformation_BC%myType=='L') then ! calculate F_aimDot from given L and current F
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
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
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
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)
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)
else
call VecSet(solution_rate,0.0_pReal,err_PETSc)
call VecSet(solution_rate,0.0_pREAL,err_PETSc)
CHKERRQ(err_PETSc)
end if
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
F_aim = F_aim_lastInc + F_aimDot * Delta_t
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 &
+ 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)
CHKERRQ(err_PETSc)
@ -493,7 +493,7 @@ subroutine converged(snes_local,PETScIter,devNull1,devNull2,fnorm,reason,dummy,e
SNESConvergedReason :: reason
PetscObject :: dummy
PetscErrorCode :: err_PETSc
real(pReal) :: &
real(pREAL) :: &
err_div, &
divTol, &
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)
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
reason = 1
elseif (totalIter >= num%itmax) then
@ -534,14 +534,14 @@ subroutine formResidual(da_local,x_local, &
PetscObject :: dummy
PetscErrorCode :: err_PETSc
real(pReal), pointer,dimension(:,:,:,:) :: x_scal, r
real(pReal), dimension(8,3) :: x_elem, f_elem
real(pREAL), pointer,dimension(:,:,:,:) :: x_scal, r
real(pREAL), dimension(8,3) :: x_elem, f_elem
PetscInt :: i, ii, j, jj, k, kk, ctr, ele
PetscInt :: &
PETScIter, &
nfuncs
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)
CHKERRQ(err_PETSc)
@ -556,7 +556,7 @@ subroutine formResidual(da_local,x_local, &
newIteration: if (totalIter <= PETScIter) then
totalIter = totalIter + 1
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))', &
'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))', &
@ -590,7 +590,7 @@ subroutine formResidual(da_local,x_local, &
!--------------------------------------------------------------------------------------------------
! stress BC handling
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
@ -599,7 +599,7 @@ subroutine formResidual(da_local,x_local, &
call DMDAVecGetArrayF90(da_local,x_local,x_scal,err_PETSc)
CHKERRQ(err_PETSc)
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)
ctr = 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 + &
matmul(HGMat,x_elem)*(homogenization_dPdF(1,1,1,1,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
do kk = -1, 0; do jj = -1, 0; do ii = -1, 0
ctr = ctr + 1
@ -623,16 +623,16 @@ subroutine formResidual(da_local,x_local, &
!--------------------------------------------------------------------------------------------------
! applying boundary conditions
if (cells3Offset == 0) then
r(0:2,0, 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,cells(1),cells(2),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,0, cells(2),0) = 0.0_pREAL
r(0:2,cells(1),cells(2),0) = 0.0_pREAL
end if
if (cells3+cells3Offset == cells(3)) then
r(0:2,0, 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,cells(1),cells(2),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,0, cells(2),cells(3)) = 0.0_pREAL
r(0:2,cells(1),cells(2),cells(3)) = 0.0_pREAL
end if
call DMDAVecRestoreArrayF90(da_local,f_local,r,err_PETSc)
CHKERRQ(err_PETSc)
@ -652,17 +652,17 @@ subroutine formJacobian(da_local,x_local,Jac_pre,Jac,dummy,err_PETSc)
PetscErrorCode :: err_PETSc
MatStencil,dimension(4,24) :: row, col
real(pReal),pointer,dimension(:,:,:,:) :: x_scal
real(pReal),dimension(24,24) :: K_ele
real(pReal),dimension(9,24) :: BMatFull
real(pREAL),pointer,dimension(:,:,:,:) :: x_scal
real(pREAL),dimension(24,24) :: K_ele
real(pREAL),dimension(9,24) :: BMatFull
PetscInt :: i, ii, j, jj, k, kk, ctr, ce
PetscInt,dimension(3),parameter :: rows = [0, 1, 2]
real(pReal) :: diag
real(pREAL) :: diag
MatNullSpace :: matnull
Vec :: coordinates
BMatFull = 0.0_pReal
BMatFull = 0.0_pREAL
BMatFull(1:3,1 :8 ) = BMat
BMatFull(4:6,9 :16) = 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
row = col
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) + &
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) + &
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) + &
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 + &
matmul(transpose(BMatFull), &
matmul(reshape(reshape(homogenization_dPdF(1:3,1:3,1:3,1:3,ce), &

96
src/grid/grid_mech_spectral_basic.f90
View File

@ -40,7 +40,7 @@ module grid_mechanical_spectral_basic
integer :: &
itmin, & !< minimum number of iterations
itmax !< maximum number of iterations
real(pReal) :: &
real(pREAL) :: &
eps_div_atol, & !< absolute tolerance for equilibrium
eps_div_rtol, & !< relative tolerance for equilibrium
eps_stress_atol, & !< absolute tolerance for fullfillment of stress BC
@ -57,28 +57,28 @@ module grid_mechanical_spectral_basic
!--------------------------------------------------------------------------------------------------
! common pointwise data
real(pReal), dimension(:,:,:,:,:), allocatable :: &
real(pREAL), dimension(:,:,:,:,:), allocatable :: &
F_lastInc, & !< field of previous compatible deformation gradients
Fdot !< field of assumed rate of compatible deformation gradient
!--------------------------------------------------------------------------------------------------
! stress, stiffness and compliance average etc.
real(pReal), dimension(3,3) :: &
F_aimDot = 0.0_pReal, & !< assumed rate of average deformation gradient
real(pREAL), dimension(3,3) :: &
F_aimDot = 0.0_pREAL, & !< assumed rate of average deformation gradient
F_aim = math_I3, & !< current prescribed deformation gradient
F_aim_lastInc = math_I3, & !< previous average deformation gradient
P_av = 0.0_pReal, & !< average 1st Piola--Kirchhoff stress
P_aim = 0.0_pReal
P_av = 0.0_pREAL, & !< average 1st Piola--Kirchhoff stress
P_aim = 0.0_pREAL
character(len=:), allocatable :: incInfo !< time and increment information
real(pReal), dimension(3,3,3,3) :: &
C_volAvg = 0.0_pReal, & !< current volume average stiffness
C_volAvgLastInc = 0.0_pReal, & !< previous volume average stiffness
C_minMaxAvg = 0.0_pReal, & !< current (min+max)/2 stiffness
C_minMaxAvgLastInc = 0.0_pReal, & !< previous (min+max)/2 stiffness
C_minMaxAvgRestart = 0.0_pReal, & !< (min+max)/2 stiffnes (restart)
S = 0.0_pReal !< current compliance (filled up with zeros)
real(pREAL), dimension(3,3,3,3) :: &
C_volAvg = 0.0_pREAL, & !< current volume average stiffness
C_volAvgLastInc = 0.0_pREAL, & !< previous volume average stiffness
C_minMaxAvg = 0.0_pREAL, & !< current (min+max)/2 stiffness
C_minMaxAvgLastInc = 0.0_pREAL, & !< previous (min+max)/2 stiffness
C_minMaxAvgRestart = 0.0_pREAL, & !< (min+max)/2 stiffnes (restart)
S = 0.0_pREAL !< current compliance (filled up with zeros)
real(pReal) :: &
real(pREAL) :: &
err_BC, & !< deviation from stress BC
err_div !< RMS of div of P
@ -105,17 +105,17 @@ contains
!--------------------------------------------------------------------------------------------------
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
integer(MPI_INTEGER_KIND) :: err_MPI
real(pReal), pointer, dimension(:,:,:,:) :: &
real(pREAL), pointer, dimension(:,:,:,:) :: &
F ! pointer to solution data
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
type(tDict), pointer :: &
num_grid
character(len=pStringLen) :: &
character(len=pSTRLEN) :: &
extmsg = ''
@ -131,18 +131,18 @@ subroutine grid_mechanical_spectral_basic_init()
! read numerical parameters and do sanity checks
num_grid => config_numerics%get_dict('grid',defaultVal=emptyDict)
num%update_gamma = num_grid%get_asBool ('update_gamma', defaultVal=.false.)
num%eps_div_atol = num_grid%get_asFloat('eps_div_atol', defaultVal=1.0e-4_pReal)
num%eps_div_rtol = num_grid%get_asFloat('eps_div_rtol', defaultVal=5.0e-4_pReal)
num%eps_stress_atol = num_grid%get_asFloat('eps_stress_atol',defaultVal=1.0e3_pReal)
num%eps_stress_rtol = num_grid%get_asFloat('eps_stress_rtol',defaultVal=1.0e-3_pReal)
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_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_rtol = num_grid%get_asReal('eps_stress_rtol',defaultVal=1.0e-3_pREAL)
num%itmin = num_grid%get_asInt ('itmin',defaultVal=1)
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_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_rtol < 0.0_pReal) extmsg = trim(extmsg)//' eps_stress_rtol'
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_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%itmax <= 1) extmsg = trim(extmsg)//' itmax'
if (num%itmin > num%itmax .or. num%itmin < 1) extmsg = trim(extmsg)//' itmin'
@ -152,13 +152,13 @@ subroutine grid_mechanical_spectral_basic_init()
! set default and user defined options for PETSc
call PetscOptionsInsertString(PETSC_NULL_OPTIONS,'-mechanical_snes_type ngmres',err_PETSc)
CHKERRQ(err_PETSc)
call PetscOptionsInsertString(PETSC_NULL_OPTIONS,num_grid%get_asString('petsc_options',defaultVal=''),err_PETSc)
call PetscOptionsInsertString(PETSC_NULL_OPTIONS,num_grid%get_asStr('petsc_options',defaultVal=''),err_PETSc)
CHKERRQ(err_PETSc)
!--------------------------------------------------------------------------------------------------
! allocate global fields
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(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)
!--------------------------------------------------------------------------------------------------
! 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_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
0.0_pReal) ! time increment
0.0_pREAL) ! time increment
call DMDAVecRestoreArrayF90(da,solution_vec,F,err_PETSc) ! deassociate pointer
CHKERRQ(err_PETSc)
@ -305,7 +305,7 @@ subroutine grid_mechanical_spectral_basic_forward(cutBack,guess,Delta_t,Delta_t_
logical, intent(in) :: &
cutBack, &
guess
real(pReal), intent(in) :: &
real(pREAL), intent(in) :: &
Delta_t_old, &
Delta_t, &
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) :: &
rotation_BC
PetscErrorCode :: err_PETSc
real(pReal), pointer, dimension(:,:,:,:) :: F
real(pREAL), pointer, dimension(:,:,:,:) :: F
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_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
!-----------------------------------------------------------------------------------------------
! calculate rate for aim
if (deformation_BC%myType=='L') then ! calculate F_aimDot from given L and current F
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
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
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
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
F_aim = F_aim_lastInc + F_aimDot * Delta_t
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 &
+ 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
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
PetscErrorCode :: err_PETSc
real(pReal), dimension(:,:,:,:), pointer :: F
real(pREAL), dimension(:,:,:,:), pointer :: F
call DMDAVecGetArrayF90(da,solution_vec,F,err_PETSc)
CHKERRQ(err_PETSc)
@ -398,7 +398,7 @@ subroutine grid_mechanical_spectral_basic_restartWrite
PetscErrorCode :: err_PETSc
integer(HID_T) :: fileHandle, groupHandle
real(pReal), dimension(:,:,:,:), pointer :: F
real(pREAL), dimension(:,:,:,:), pointer :: F
call DMDAVecGetArrayF90(da,solution_vec,F,err_PETSc)
CHKERRQ(err_PETSc)
@ -448,14 +448,14 @@ subroutine converged(snes_local,PETScIter,devNull1,devNull2,devNull3,reason,dumm
SNESConvergedReason :: reason
PetscObject :: dummy
PetscErrorCode :: err_PETSc
real(pReal) :: &
real(pREAL) :: &
divTol, &
BCTol
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)
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
reason = 1
elseif (totalIter >= num%itmax) then
@ -484,14 +484,14 @@ subroutine formResidual(residual_subdomain, F, &
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,cells(1),cells(2),cells3), intent(in) :: &
real(pREAL), dimension(3,3,cells(1),cells(2),cells3), intent(in) :: &
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
PetscObject :: dummy
PetscErrorCode :: err_PETSc
real(pReal), dimension(3,3) :: &
real(pREAL), dimension(3,3) :: &
deltaF_aim
PetscInt :: &
PETScIter, &
@ -509,7 +509,7 @@ subroutine formResidual(residual_subdomain, F, &
newIteration: if (totalIter <= PETScIter) then
totalIter = totalIter + 1
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))', &
'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))', &
@ -528,7 +528,7 @@ subroutine formResidual(residual_subdomain, F, &
deltaF_aim = math_mul3333xx33(S, P_av - P_aim) ! S = 0.0 for no bc
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.))

130
src/grid/grid_mech_spectral_polarisation.f90
View File

@ -40,14 +40,14 @@ module grid_mechanical_spectral_polarisation
integer :: &
itmin, & !< minimum number of iterations
itmax !< maximum number of iterations
real(pReal) :: &
real(pREAL) :: &
eps_div_atol, & !< absolute tolerance for equilibrium
eps_div_rtol, & !< relative tolerance for equilibrium
eps_curl_atol, & !< absolute tolerance for compatibility
eps_curl_rtol, & !< relative tolerance for compatibility
eps_stress_atol, & !< absolute 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
beta !< polarization scheme parameter 0.0 < beta < 2.0. beta = 1.0 ==> AL scheme, beta = 2.0 ==> accelerated scheme
end type tNumerics
@ -62,7 +62,7 @@ module grid_mechanical_spectral_polarisation
!--------------------------------------------------------------------------------------------------
! common pointwise data
real(pReal), dimension(:,:,:,:,:), allocatable :: &
real(pREAL), dimension(:,:,:,:,:), allocatable :: &
F_lastInc, & !< field of previous compatible deformation gradients
F_tau_lastInc, & !< field of previous incompatible 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.
real(pReal), dimension(3,3) :: &
F_aimDot = 0.0_pReal, & !< assumed rate of average deformation gradient
real(pREAL), dimension(3,3) :: &
F_aimDot = 0.0_pREAL, & !< assumed rate of average deformation gradient
F_aim = math_I3, & !< current prescribed deformation gradient
F_aim_lastInc = math_I3, & !< previous average deformation gradient
F_av = 0.0_pReal, & !< average incompatible def grad field
P_av = 0.0_pReal, & !< average 1st Piola--Kirchhoff stress
P_aim = 0.0_pReal
F_av = 0.0_pREAL, & !< average incompatible def grad field
P_av = 0.0_pREAL, & !< average 1st Piola--Kirchhoff stress
P_aim = 0.0_pREAL
character(len=:), allocatable :: incInfo !< time and increment information
real(pReal), dimension(3,3,3,3) :: &
C_volAvg = 0.0_pReal, & !< current volume average stiffness
C_volAvgLastInc = 0.0_pReal, & !< previous volume average stiffness
C_minMaxAvg = 0.0_pReal, & !< current (min+max)/2 stiffness
C_minMaxAvgLastInc = 0.0_pReal, & !< previous (min+max)/2 stiffness
C_minMaxAvgRestart = 0.0_pReal, & !< (min+max)/2 stiffnes (restart)
S = 0.0_pReal, & !< current compliance (filled up with zeros)
C_scale = 0.0_pReal, &
S_scale = 0.0_pReal
real(pREAL), dimension(3,3,3,3) :: &
C_volAvg = 0.0_pREAL, & !< current volume average stiffness
C_volAvgLastInc = 0.0_pREAL, & !< previous volume average stiffness
C_minMaxAvg = 0.0_pREAL, & !< current (min+max)/2 stiffness
C_minMaxAvgLastInc = 0.0_pREAL, & !< previous (min+max)/2 stiffness
C_minMaxAvgRestart = 0.0_pREAL, & !< (min+max)/2 stiffnes (restart)
S = 0.0_pREAL, & !< current compliance (filled up with zeros)
C_scale = 0.0_pREAL, &
S_scale = 0.0_pREAL
real(pReal) :: &
real(pREAL) :: &
err_BC, & !< deviation from stress BC
err_curl, & !< RMS of curl of F
err_div !< RMS of div of P
@ -116,19 +116,19 @@ contains
!--------------------------------------------------------------------------------------------------
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
integer(MPI_INTEGER_KIND) :: err_MPI
real(pReal), pointer, dimension(:,:,:,:) :: &
real(pREAL), pointer, dimension(:,:,:,:) :: &
FandF_tau, & ! overall pointer to solution data
F, & ! specific (sub)pointer
F_tau ! specific (sub)pointer
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
type(tDict), pointer :: &
num_grid
character(len=pStringLen) :: &
character(len=pSTRLEN) :: &
extmsg = ''
@ -142,28 +142,28 @@ subroutine grid_mechanical_spectral_polarisation_init()
! read numerical parameters and do sanity checks
num_grid => config_numerics%get_dict('grid',defaultVal=emptyDict)
num%update_gamma = num_grid%get_asBool ('update_gamma', defaultVal=.false.)
num%eps_div_atol = num_grid%get_asFloat('eps_div_atol', defaultVal=1.0e-4_pReal)
num%eps_div_rtol = num_grid%get_asFloat('eps_div_rtol', defaultVal=5.0e-4_pReal)
num%eps_curl_atol = num_grid%get_asFloat('eps_curl_atol', defaultVal=1.0e-10_pReal)
num%eps_curl_rtol = num_grid%get_asFloat('eps_curl_rtol', defaultVal=5.0e-4_pReal)
num%eps_stress_atol = num_grid%get_asFloat('eps_stress_atol',defaultVal=1.0e3_pReal)
num%eps_stress_rtol = num_grid%get_asFloat('eps_stress_rtol',defaultVal=1.0e-3_pReal)
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_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_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_rtol = num_grid%get_asReal('eps_stress_rtol',defaultVal=1.0e-3_pREAL)
num%itmin = num_grid%get_asInt ('itmin', defaultVal=1)
num%itmax = num_grid%get_asInt ('itmax', defaultVal=250)
num%alpha = num_grid%get_asFloat('alpha', defaultVal=1.0_pReal)
num%beta = num_grid%get_asFloat('beta', 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)
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_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_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_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_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_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%itmax <= 1) extmsg = trim(extmsg)//' itmax'
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%beta < 0.0_pReal .or. num%beta > 2.0_pReal) extmsg = trim(extmsg)//' beta'
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 (extmsg /= '') call IO_error(301,ext_msg=trim(extmsg))
@ -171,15 +171,15 @@ subroutine grid_mechanical_spectral_polarisation_init()
! set default and user defined options for PETSc
call PetscOptionsInsertString(PETSC_NULL_OPTIONS,'-mechanical_snes_type ngmres',err_PETSc)
CHKERRQ(err_PETSc)
call PetscOptionsInsertString(PETSC_NULL_OPTIONS,num_grid%get_asString('petsc_options',defaultVal=''),err_PETSc)
call PetscOptionsInsertString(PETSC_NULL_OPTIONS,num_grid%get_asStr('petsc_options',defaultVal=''),err_PETSc)
CHKERRQ(err_PETSc)
!--------------------------------------------------------------------------------------------------
! allocate global fields
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(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_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(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)
!--------------------------------------------------------------------------------------------------
! initialize solver specific parts of PETSc
@ -252,15 +252,15 @@ subroutine grid_mechanical_spectral_polarisation_init()
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 = reshape(F_lastInc,[9,cells(1),cells(2),cells3])
F_tau = 2.0_pReal*F
F_tau_lastInc = 2.0_pReal*F_lastInc
F_tau = 2.0_pREAL*F
F_tau_lastInc = 2.0_pREAL*F_lastInc
end if restartRead
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_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
0.0_pReal) ! time increment
0.0_pREAL) ! time increment
call DMDAVecRestoreArrayF90(da,solution_vec,FandF_tau,err_PETSc) ! deassociate pointer
CHKERRQ(err_PETSc)
@ -340,7 +340,7 @@ subroutine grid_mechanical_spectral_polarisation_forward(cutBack,guess,Delta_t,D
logical, intent(in) :: &
cutBack, &
guess
real(pReal), intent(in) :: &
real(pREAL), intent(in) :: &
Delta_t_old, &
Delta_t, &
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) :: &
rotation_BC
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
real(pReal), dimension(3,3) :: F_lambda33
real(pREAL), dimension(3,3) :: F_lambda33
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_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
!-----------------------------------------------------------------------------------------------
! calculate rate for aim
if (deformation_BC%myType=='L') then ! calculate F_aimDot from given L and current F
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
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
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
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
F_aim = F_aim_lastInc + F_aimDot * Delta_t
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 &
+ 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
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)
F_lambda33 = reshape(F_tau(1:9,i,j,k)-F(1:9,i,j,k),[3,3])
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)))
F_tau(1:9,i,j,k) = reshape(F_lambda33,[9])+F(1:9,i,j,k)
end do; end do; end do
@ -437,7 +437,7 @@ end subroutine grid_mechanical_spectral_polarisation_forward
subroutine grid_mechanical_spectral_polarisation_updateCoords
PetscErrorCode :: err_PETSc
real(pReal), dimension(:,:,:,:), pointer :: FandF_tau
real(pREAL), dimension(:,:,:,:), pointer :: FandF_tau
call DMDAVecGetArrayF90(da,solution_vec,FandF_tau,err_PETSc)
CHKERRQ(err_PETSc)
@ -455,7 +455,7 @@ subroutine grid_mechanical_spectral_polarisation_restartWrite
PetscErrorCode :: err_PETSc
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)
CHKERRQ(err_PETSc)
@ -509,7 +509,7 @@ subroutine converged(snes_local,PETScIter,devNull1,devNull2,devNull3,reason,dumm
SNESConvergedReason :: reason
PetscObject :: dummy
PetscErrorCode :: err_PETSc
real(pReal) :: &
real(pREAL) :: &
curlTol, &
divTol, &
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)
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
reason = 1
elseif (totalIter >= num%itmax) then
@ -548,14 +548,14 @@ subroutine formResidual(residual_subdomain, FandF_tau, &
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)
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
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
PetscObject :: dummy
PetscErrorCode :: err_PETSc
real(pReal), pointer, dimension(:,:,:,:,:) :: &
real(pREAL), pointer, dimension(:,:,:,:,:) :: &
F, &
F_tau, &
r_F, &
@ -587,7 +587,7 @@ subroutine formResidual(residual_subdomain, FandF_tau, &
newIteration: if (totalIter <= PETScIter) then
totalIter = totalIter + 1
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))', &
'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))', &

42
src/grid/grid_thermal_spectral.f90
View File

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

366
src/grid/spectral_utilities.f90
View File

@ -32,8 +32,8 @@ module spectral_utilities
!--------------------------------------------------------------------------------------------------
! grid related information
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 :: wgt !< weighting factor 1/Nelems
real(pREAL), protected, public, dimension(3) :: scaledGeomSize !< scaled geometry size for calculation of divergence
integer :: &
cells1Red, & !< cells(1)/2+1
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 :: vectorField_fourier !< vector 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 :: xi1st !< wave vector field for first derivatives
complex(pReal), dimension(:,:,:,:), allocatable :: xi2nd !< wave vector field for second derivatives
real(pReal), dimension(3,3,3,3) :: C_ref !< mechanic reference stiffness
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 :: xi2nd !< wave vector field for second derivatives
real(pREAL), dimension(3,3,3,3) :: C_ref !< mechanic reference stiffness
!--------------------------------------------------------------------------------------------------
@ -76,16 +76,16 @@ module spectral_utilities
end type tSolutionState
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.
character(len=:), allocatable :: myType
end type tBoundaryCondition
type, public :: tSolutionParams
real(pReal), dimension(3,3) :: stress_BC
real(pREAL), dimension(3,3) :: stress_BC
logical, dimension(3,3) :: stress_mask
type(tRotation) :: rotation_BC
real(pReal) :: Delta_t
real(pREAL) :: Delta_t
end type tSolutionParams
type :: tNumerics
@ -168,11 +168,11 @@ subroutine spectral_utilities_init()
call PetscOptionsClear(PETSC_NULL_OPTIONS,err_PETSc)
CHKERRQ(err_PETSc)
call PetscOptionsInsertString(PETSC_NULL_OPTIONS,&
num_grid%get_asString('PETSc_options',defaultVal=''),err_PETSc)
num_grid%get_asStr('PETSc_options',defaultVal=''),err_PETSc)
CHKERRQ(err_PETSc)
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%divergence_correction = num_grid%get_asInt('divergence_correction', defaultVal=2)
@ -180,7 +180,7 @@ subroutine spectral_utilities_init()
if (num%divergence_correction < 0 .or. num%divergence_correction > 2) &
call IO_error(301,ext_msg='divergence_correction')
select case (num_grid%get_asString('derivative',defaultVal='continuous'))
select case (num_grid%get_asStr('derivative',defaultVal='continuous'))
case ('continuous')
spectral_derivative_ID = DERIVATIVE_CONTINUOUS_ID
case ('central_difference')
@ -188,7 +188,7 @@ subroutine spectral_utilities_init()
case ('FWBW_difference')
spectral_derivative_ID = DERIVATIVE_FWBW_DIFF_ID
case default
call IO_error(892,ext_msg=trim(num_grid%get_asString('derivative')))
call IO_error(892,ext_msg=trim(num_grid%get_asStr('derivative')))
end select
!--------------------------------------------------------------------------------------------------
@ -201,15 +201,15 @@ subroutine spectral_utilities_init()
end do
elseif (num%divergence_correction == 2) then
do j = 1, 3
if ( j /= int(minloc(geomSize/real(cells,pReal),1)) &
.and. j /= int(maxloc(geomSize/real(cells,pReal),1))) &
scaledGeomSize = geomSize/geomSize(j)*real(cells(j),pReal)
if ( j /= int(minloc(geomSize/real(cells,pREAL),1)) &
.and. j /= int(maxloc(geomSize/real(cells,pREAL),1))) &
scaledGeomSize = geomSize/geomSize(j)*real(cells(j),pREAL)
end do
else
scaledGeomSize = geomSize
end if
select case(IO_lc(num_grid%get_asString('fftw_plan_mode',defaultVal='FFTW_MEASURE')))
select case(IO_lc(num_grid%get_asStr('fftw_plan_mode',defaultVal='FFTW_MEASURE')))
case('fftw_estimate') ! ordered from slow execution (but fast plan creation) to fast execution
FFTW_planner_flag = FFTW_ESTIMATE
case('fftw_measure')
@ -219,14 +219,14 @@ subroutine spectral_utilities_init()
case('fftw_exhaustive')
FFTW_planner_flag = FFTW_EXHAUSTIVE
case default
call IO_warning(47,'using default FFTW_MEASURE instead of "'//trim(num_grid%get_asString('fftw_plan_mode'))//'"')
call IO_warning(47,'using default FFTW_MEASURE instead of "'//trim(num_grid%get_asStr('fftw_plan_mode'))//'"')
FFTW_planner_flag = FFTW_MEASURE
end select
!--------------------------------------------------------------------------------------------------
! 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'
call fftw_set_timelimit(num_grid%get_asFloat('fftw_timelimit',defaultVal=300.0_pReal))
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))
print'(/,1x,a)', 'FFTW initialized'; flush(IO_STDOUT)
@ -268,8 +268,8 @@ subroutine spectral_utilities_init()
!--------------------------------------------------------------------------------------------------
! 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 (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 (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
!--------------------------------------------------------------------------------------------------
! tensor MPI fftw plans
@ -321,16 +321,16 @@ subroutine spectral_utilities_init()
xi2nd(1:3,i,k,j-cells2Offset) = utilities_getFreqDerivative(k_s)
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
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
xi1st(1:3,i,k,j-cells2Offset) = xi2nd(1:3,i,k,j-cells2Offset)
endwhere
end do; end do; end do
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
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
call selfTest()
@ -346,10 +346,10 @@ end subroutine spectral_utilities_init
!---------------------------------------------------------------------------------------------------
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
real(pReal), dimension(6,6) :: A, A_inv
complex(pREAL), dimension(3,3) :: temp33_cmplx, xiDyad_cmplx
real(pREAL), dimension(6,6) :: A, A_inv
integer :: &
i, j, k, &
l, m, n, o
@ -359,7 +359,7 @@ subroutine utilities_updateGamma(C)
C_ref = C/wgt
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)
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
@ -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)
end do
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
#else
forall(l = 1:3, m = 1:3) &
xiDyad_cmplx(l,m) = conjg(-xi1st(l,i,k,j-cells2Offset))*xi1st(m,i,k,j-cells2Offset)
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
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
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)
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
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)
@ -404,12 +404,12 @@ end subroutine utilities_updateGamma
!--------------------------------------------------------------------------------------------------
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) :: fieldAim !< desired average value of the field after convolution
real(pReal), dimension(3,3,cells(1),cells(2),cells3) :: gammaField
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), dimension(3,3,cells(1),cells(2),cells3) :: gammaField
complex(pReal), dimension(3,3) :: temp33_cmplx, xiDyad_cmplx
real(pReal), dimension(6,6) :: A, A_inv
complex(pREAL), dimension(3,3) :: temp33_cmplx, xiDyad_cmplx
real(pREAL), dimension(6,6) :: A, A_inv
integer :: &
i, j, k, &
l, m, n, o
@ -419,7 +419,7 @@ function utilities_GammaConvolution(field, fieldAim) result(gammaField)
print'(/,1x,a)', '... doing gamma convolution ...............................................'
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
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)
end do
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
#else
forall(l = 1:3, m = 1:3) &
xiDyad_cmplx(l,m) = conjg(-xi1st(l,i,k,j))*xi1st(m,i,k,j)
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
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
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)
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
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)
@ -460,7 +460,7 @@ function utilities_GammaConvolution(field, fieldAim) result(gammaField)
#endif
tensorField_fourier(1:3,1:3,i,k,j) = temp33_cmplx
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 do; end do; end do
@ -481,7 +481,7 @@ function utilities_GammaConvolution(field, fieldAim) result(gammaField)
!$OMP END PARALLEL DO
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)
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)
real(pReal), intent(in), dimension(cells(1),cells(2),cells3) :: field
real(pReal), dimension(3,3), intent(in) :: D_ref
real(pReal), intent(in) :: mu_ref, Delta_t
real(pReal), dimension(cells(1),cells(2),cells3) :: greenField
real(pREAL), intent(in), dimension(cells(1),cells(2),cells3) :: field
real(pREAL), dimension(3,3), intent(in) :: D_ref
real(pREAL), intent(in) :: mu_ref, Delta_t
real(pREAL), dimension(cells(1),cells(2),cells3) :: greenField
complex(pReal) :: GreenOp_hat
complex(pREAL) :: GreenOp_hat
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
call fftw_mpi_execute_dft_r2c(planScalarForth,scalarField_real,scalarField_fourier)
!$OMP PARALLEL DO PRIVATE(GreenOp_hat)
do j = 1, cells2; do k = 1, cells(3); do i = 1, cells1Red
GreenOp_hat = cmplx(wgt,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))))
GreenOp_hat = cmplx(wgt,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))))
scalarField_fourier(i,k,j) = scalarField_fourier(i,k,j)*GreenOp_hat
end do; end do; end do
!$OMP END PARALLEL DO
@ -525,28 +525,28 @@ end function utilities_GreenConvolution
!--------------------------------------------------------------------------------------------------
!> @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(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
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
utilities_divergenceRMS = 0.0_pReal
utilities_divergenceRMS = 0.0_pREAL
do j = 1, cells2; do k = 1, cells(3)
do i = 2, cells1Red -1 ! Has somewhere a conj. complex counterpart. Therefore count it twice.
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
+sum(aimag(matmul(tensorField_fourier(1:3,1:3,i,k,j),&
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)
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
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
@ -572,25 +572,25 @@ end function utilities_divergenceRMS
!--------------------------------------------------------------------------------------------------
!> @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(MPI_INTEGER_KIND) :: err_MPI
complex(pReal), dimension(3,3) :: curl_fourier
complex(pReal), dimension(3) :: rescaledGeom
complex(pREAL), dimension(3,3) :: curl_fourier
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
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
utilities_curlRMS = 0.0_pReal
utilities_curlRMS = 0.0_pREAL
do j = 1, cells2; do k = 1, cells(3);
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))
end do
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
do l = 1, 3
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)
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
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
@ -640,22 +640,22 @@ end function utilities_curlRMS
!--------------------------------------------------------------------------------------------------
function utilities_maskedCompliance(rot_BC,mask_stress,C)
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), dimension(3,3,3,3) :: utilities_maskedCompliance !< masked compliance
real(pREAL), intent(in), dimension(3,3,3,3) :: C !< current average stiffness
type(tRotation), intent(in) :: rot_BC !< rotation of load frame
logical, intent(in), dimension(3,3) :: mask_stress !< mask of stress BC
integer :: i, j
logical, dimension(9) :: mask_stressVector
logical, dimension(9,9) :: mask
real(pReal), dimension(9,9) :: temp99_real
real(pREAL), dimension(9,9) :: temp99_real
integer :: size_reduced = 0
real(pReal), dimension(:,:), allocatable :: &
real(pREAL), dimension(:,:), allocatable :: &
s_reduced, & !< reduced compliance matrix (depending on number of stress BC)
c_reduced, & !< reduced stiffness (depending on number of stress BC)
sTimesC !< temp variable to check inversion
logical :: errmatinv
character(len=pStringLen):: formatString
character(len=pSTRLEN):: formatString
mask_stressVector = .not. reshape(transpose(mask_stress), [9])
size_reduced = count(mask_stressVector)
@ -674,7 +674,7 @@ function utilities_maskedCompliance(rot_BC,mask_stress,C)
!--------------------------------------------------------------------------------------------------
! check if inversion was successful
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
write(formatString, '(i2)') size_reduced
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)
if (errmatinv) error stop 'matrix inversion error'
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
temp99_real = 0.0_pReal
temp99_real = 0.0_pREAL
end if
utilities_maskedCompliance = math_99to3333(temp99_Real)
@ -697,13 +697,13 @@ end function utilities_maskedCompliance
!--------------------------------------------------------------------------------------------------
function utilities_scalarGradient(field) result(grad)
real(pReal), intent(in), dimension( cells(1),cells(2),cells3) :: field
real(pReal), dimension(3,cells(1),cells(2),cells3) :: grad
real(pREAL), intent(in), dimension( cells(1),cells(2),cells3) :: field
real(pREAL), dimension(3,cells(1),cells(2),cells3) :: grad
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
call fftw_mpi_execute_dft_r2c(planScalarForth,scalarField_real,scalarField_fourier)
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)
real(pReal), intent(in), dimension(3,cells(1),cells(2),cells3) :: field
real(pReal), dimension( cells(1),cells(2),cells3) :: div
real(pREAL), intent(in), dimension(3,cells(1),cells(2),cells3) :: field
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
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) &
@ -741,19 +741,19 @@ end function utilities_vectorDivergence
subroutine utilities_constitutiveResponse(P,P_av,C_volAvg,C_minmaxAvg,&
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) :: P_av !< average 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) :: Delta_t !< loading time
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,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) :: Delta_t !< loading time
type(tRotation), intent(in), optional :: rotation_BC !< rotation of load frame
integer :: i
integer(MPI_INTEGER_KIND) :: err_MPI
real(pReal), dimension(3,3,3,3) :: dPdF_max, dPdF_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(3,3,3,3) :: dPdF_max, dPdF_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
print'(/,1x,a)', '... evaluating constitutive response ......................................'
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)
if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
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))', &
'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)
end if
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)
dPdF_max = 0.0_pReal
dPdF_norm_max = 0.0_pReal
dPdF_min = huge(1.0_pReal)
dPdF_norm_min = huge(1.0_pReal)
dPdF_max = 0.0_pREAL
dPdF_norm_max = 0.0_pREAL
dPdF_min = huge(1.0_pREAL)
dPdF_norm_min = huge(1.0_pREAL)
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
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 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)
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)
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)
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)
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)
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)
real(pReal), intent(in), dimension(3,3) :: &
real(pREAL), intent(in), dimension(3,3) :: &
avRate !< homogeneous addon
real(pReal), intent(in) :: &
real(pREAL), intent(in) :: &
dt !< Delta_t between field0 and field
logical, intent(in) :: &
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
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
@ -849,17 +849,17 @@ end function utilities_calculateRate
!--------------------------------------------------------------------------------------------------
function utilities_forwardField(Delta_t,field_lastInc,rate,aim)
real(pReal), intent(in) :: &
real(pREAL), intent(in) :: &
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
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
real(pReal), dimension(3,3,cells(1),cells(2),cells3) :: &
real(pREAL), dimension(3,3,cells(1),cells(2),cells3) :: &
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
@ -885,42 +885,42 @@ pure function utilities_getFreqDerivative(k_s)
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)
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)
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)
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)
case (DERIVATIVE_FWBW_DIFF_ID)
utilities_getFreqDerivative(1) = &
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)* &
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)* &
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)/ &
cmplx(4.0_pReal*geomSize(1)/real(cells(1),pReal), 0.0_pReal, 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)* &
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)* &
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)/ &
cmplx(4.0_pREAL*geomSize(1)/real(cells(1),pREAL), 0.0_pREAL, pREAL)
utilities_getFreqDerivative(2) = &
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)* &
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)* &
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)/ &
cmplx(4.0_pReal*geomSize(2)/real(cells(2),pReal), 0.0_pReal, 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)* &
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)* &
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)/ &
cmplx(4.0_pREAL*geomSize(2)/real(cells(2),pREAL), 0.0_pREAL, pREAL)
utilities_getFreqDerivative(3) = &
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)* &
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)* &
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)/ &
cmplx(4.0_pReal*geomSize(3)/real(cells(3),pReal), 0.0_pReal, 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)* &
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)* &
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)/ &
cmplx(4.0_pREAL*geomSize(3)/real(cells(3),pREAL), 0.0_pREAL, pREAL)
end select
end function utilities_getFreqDerivative
@ -932,11 +932,11 @@ end function utilities_getFreqDerivative
!--------------------------------------------------------------------------------------------------
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),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),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)+1,cells(2)+1,cells3+1) :: x_n !< Node coordinates
integer :: &
i,j,k,n, &
c
@ -950,8 +950,8 @@ subroutine utilities_updateCoords(F)
integer, dimension(4) :: request
integer, dimension(MPI_STATUS_SIZE,4) :: status
#endif
real(pReal), dimension(3) :: step
real(pReal), dimension(3,3) :: Favg
real(pREAL), dimension(3) :: step
real(pREAL), dimension(3,3) :: Favg
integer, dimension(3) :: me
integer, dimension(3,8) :: &
neighbor = reshape([ &
@ -965,10 +965,10 @@ subroutine utilities_updateCoords(F)
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,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)
!--------------------------------------------------------------------------------------------------
@ -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)) &
/ sum(conjg(-xi2nd(1:3,i,k,j))*xi2nd(1:3,i,k,j))
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 do; end do; end do
!$OMP END PARALLEL DO
@ -1021,13 +1021,13 @@ subroutine utilities_updateCoords(F)
!--------------------------------------------------------------------------------------------------
! 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)
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
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) &
+ 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; end do; end do
@ -1035,7 +1035,7 @@ subroutine utilities_updateCoords(F)
! calculate cell center/point positions
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) &
+ 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
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()
real(pReal), allocatable, dimension(:,:,:,:,:) :: tensorField_real_
real(pReal), allocatable, dimension(:,:,:,:) :: vectorField_real_
real(pReal), allocatable, dimension(:,:,:) :: scalarField_real_
real(pReal), dimension(3,3) :: tensorSum
real(pReal), dimension(3) :: vectorSum
real(pReal) :: scalarSum
real(pReal), dimension(3,3) :: r
real(pREAL), allocatable, dimension(:,:,:,:,:) :: tensorField_real_
real(pREAL), allocatable, dimension(:,:,:,:) :: vectorField_real_
real(pREAL), allocatable, dimension(:,:,:) :: scalarField_real_
real(pREAL), dimension(3,3) :: tensorSum
real(pREAL), dimension(3) :: vectorSum
real(pREAL) :: scalarSum
real(pREAL), dimension(3,3) :: r
integer(MPI_INTEGER_KIND) :: err_MPI
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
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, &
MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI)
if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
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'
end if
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
if (maxval(abs(tensorField_real_ - tensorField_real*wgt))>5.0e-15_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) &
error stop 'mismatch tensorField FFT/invFFT <-> 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
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, &
MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI)
if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
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'
end if
call fftw_mpi_execute_dft_c2r(planVectorBack,vectorField_fourier,vectorField_real)
vectorField_real(1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pReal
if (maxval(abs(vectorField_real_ - vectorField_real*wgt))>5.0e-15_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) &
error stop 'mismatch vectorField FFT/invFFT <-> 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
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, &
MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI)
if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
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'
end if
call fftw_mpi_execute_dft_c2r(planScalarBack,scalarField_fourier,scalarField_real)
scalarField_real(cells(1)+1:cells1Red*2,:,:) = 0.0_pReal
if (maxval(abs(scalarField_real_ - scalarField_real*wgt))>5.0e-15_pReal) &
scalarField_real(cells(1)+1:cells1Red*2,:,:) = 0.0_pREAL
if (maxval(abs(scalarField_real_ - scalarField_real*wgt))>5.0e-15_pREAL) &
error stop 'mismatch scalarField FFT/invFFT <-> real'
call random_number(r)
@ -1112,54 +1112,54 @@ subroutine selfTest()
if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
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)
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)
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_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 (cells(1) > 2 .and. spectral_derivative_ID == DERIVATIVE_CONTINUOUS_ID) then
scalarField_real_ = spread(spread(planeCosine(cells(1)),2,cells(2)),3,cells3)
vectorField_real_ = utilities_scalarGradient(scalarField_real_)/TAU*geomSize(1)
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)
vectorField_real_ = utilities_scalarGradient(scalarField_real_)/TAU*geomSize(1)
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)
scalarField_real_ = utilities_vectorDivergence(vectorField_real_)/TAU*geomSize(1)
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'
vectorField_real_(2:3,:,:,:) = 0.0_pReal
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_(1,:,:,:) = spread(spread(planeSine( cells(1)),2,cells(2)),3,cells3)
scalarField_real_ = utilities_vectorDivergence(vectorField_real_)/TAU*geomSize(1)
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
contains
function planeCosine(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
function planeSine(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

48
src/homogenization.f90
View File

@ -25,7 +25,7 @@ module homogenization
integer :: &
sizeState = 0 !< size of state
! 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, &
state
end type
@ -51,12 +51,12 @@ module homogenization
!--------------------------------------------------------------------------------------------------
! 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_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
real(pReal), dimension(:,:,:,:,:), allocatable, public :: & !, protected :: &
real(pREAL), dimension(:,:,:,:,:), allocatable, public :: & !, protected :: &
homogenization_dPdF !< tangent of first P--K stress at IP
@ -81,7 +81,7 @@ module homogenization
end subroutine damage_init
module subroutine mechanical_partition(subF,ce)
real(pReal), intent(in), dimension(3,3) :: &
real(pREAL), intent(in), dimension(3,3) :: &
subF
integer, intent(in) :: &
ce
@ -96,7 +96,7 @@ module homogenization
end subroutine damage_partition
module subroutine mechanical_homogenize(Delta_t,ce)
real(pReal), intent(in) :: Delta_t
real(pREAL), intent(in) :: Delta_t
integer, intent(in) :: &
ce !< cell
end subroutine mechanical_homogenize
@ -117,9 +117,9 @@ module homogenization
end subroutine thermal_result
module function mechanical_updateState(subdt,subF,ce) result(doneAndHappy)
real(pReal), intent(in) :: &
real(pREAL), intent(in) :: &
subdt !< current time step
real(pReal), intent(in), dimension(3,3) :: &
real(pREAL), intent(in), dimension(3,3) :: &
subF
integer, intent(in) :: &
ce !< cell
@ -132,22 +132,22 @@ module homogenization
module function homogenization_mu_T(ce) result(mu)
integer, intent(in) :: ce
real(pReal) :: mu
real(pREAL) :: mu
end function homogenization_mu_T
module function homogenization_K_T(ce) result(K)
integer, intent(in) :: ce
real(pReal), dimension(3,3) :: K
real(pREAL), dimension(3,3) :: K
end function homogenization_K_T
module function homogenization_f_T(ce) result(f)
integer, intent(in) :: ce
real(pReal) :: f
real(pREAL) :: f
end function homogenization_f_T
module subroutine homogenization_thermal_setField(T,dot_T, ce)
integer, intent(in) :: ce
real(pReal), intent(in) :: T, dot_T
real(pREAL), intent(in) :: T, dot_T
end subroutine homogenization_thermal_setField
module function homogenization_damage_active() result(active)
@ -156,23 +156,23 @@ module homogenization
module function homogenization_mu_phi(ce) result(mu)
integer, intent(in) :: ce
real(pReal) :: mu
real(pREAL) :: mu
end function homogenization_mu_phi
module function homogenization_K_phi(ce) result(K)
integer, intent(in) :: ce
real(pReal), dimension(3,3) :: K
real(pREAL), dimension(3,3) :: K
end function homogenization_K_phi
module function homogenization_f_phi(phi,ce) result(f)
integer, intent(in) :: ce
real(pReal), intent(in) :: phi
real(pReal) :: f
real(pREAL), intent(in) :: phi
real(pREAL) :: f
end function homogenization_f_phi
module subroutine homogenization_set_phi(phi,ce)
integer, intent(in) :: ce
real(pReal), intent(in) :: &
real(pREAL), intent(in) :: &
phi
end subroutine homogenization_set_phi
@ -235,7 +235,7 @@ end subroutine homogenization_init
!--------------------------------------------------------------------------------------------------
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) :: &
cell_start, cell_end
integer :: &
@ -293,7 +293,7 @@ end subroutine homogenization_mechanical_response
!--------------------------------------------------------------------------------------------------
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) :: &
cell_start, cell_end
integer :: &
@ -321,7 +321,7 @@ end subroutine homogenization_thermal_response
!--------------------------------------------------------------------------------------------------
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 :: &
ip, & !< integration point number
@ -482,7 +482,7 @@ subroutine parseHomogenization
if (homog%contains('thermal')) then
homogThermal => homog%get_dict('thermal')
select case (homogThermal%get_asString('type'))
select case (homogThermal%get_asStr('type'))
case('pass')
thermal_type(h) = THERMAL_PASS_ID
thermal_active(h) = .true.
@ -490,17 +490,17 @@ subroutine parseHomogenization
thermal_type(h) = THERMAL_ISOTEMPERATURE_ID
thermal_active(h) = .true.
case default
call IO_error(500,ext_msg=homogThermal%get_asString('type'))
call IO_error(500,ext_msg=homogThermal%get_asStr('type'))
end select
end if
if (homog%contains('damage')) then
homogDamage => homog%get_dict('damage')
select case (homogDamage%get_asString('type'))
select case (homogDamage%get_asStr('type'))
case('pass')
damage_active(h) = .true.
case default
call IO_error(500,ext_msg=homogDamage%get_asString('type'))
call IO_error(500,ext_msg=homogDamage%get_asStr('type'))
end select
end if
end do

28
src/homogenization_damage.f90
View File

@ -11,13 +11,13 @@ submodule(homogenization) damage
end interface
type :: tDataContainer
real(pReal), dimension(:), allocatable :: phi
real(pREAL), dimension(:), allocatable :: phi
end type tDataContainer
type(tDataContainer), dimension(:), allocatable :: current
type :: tParameters
character(len=pStringLen), allocatable, dimension(:) :: &
character(len=pSTRLEN), allocatable, dimension(:) :: &
output
end type tParameters
@ -48,21 +48,21 @@ module subroutine damage_init()
do ho = 1, configHomogenizations%length
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)
associate(prm => param(ho))
if (configHomogenization%contains('damage')) then
configHomogenizationDamage => configHomogenization%get_dict('damage')
#if defined (__GFORTRAN__)
prm%output = output_as1dString(configHomogenizationDamage)
prm%output = output_as1dStr(configHomogenizationDamage)
#else
prm%output = configHomogenizationDamage%get_as1dString('output',defaultVal=emptyStringArray)
prm%output = configHomogenizationDamage%get_as1dStr('output',defaultVal=emptyStrArray)
#endif
damageState_h(ho)%sizeState = 1
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)%state0(1,Nmembers), source=1.0_pREAL)
allocate(damageState_h(ho)%state (1,Nmembers), source=1.0_pREAL)
else
prm%output = emptyStringArray
prm%output = emptyStrArray
end if
end associate
end do
@ -91,7 +91,7 @@ module subroutine damage_partition(ce)
integer, intent(in) :: ce
real(pReal) :: phi
real(pREAL) :: phi
integer :: co
@ -111,7 +111,7 @@ end subroutine damage_partition
module function homogenization_mu_phi(ce) result(mu)
integer, intent(in) :: ce
real(pReal) :: mu
real(pREAL) :: mu
mu = phase_mu_phi(1,ce)
@ -125,7 +125,7 @@ end function homogenization_mu_phi
module function homogenization_K_phi(ce) result(K)
integer, intent(in) :: ce
real(pReal), dimension(3,3) :: K
real(pREAL), dimension(3,3) :: K
K = phase_K_phi(1,ce)
@ -139,8 +139,8 @@ end function homogenization_K_phi
module function homogenization_f_phi(phi,ce) result(f)
integer, intent(in) :: ce
real(pReal), intent(in) :: phi
real(pReal) :: f
real(pREAL), intent(in) :: phi
real(pREAL) :: f
f = phase_f_phi(phi, 1, ce)
@ -154,7 +154,7 @@ end function homogenization_f_phi
module subroutine homogenization_set_phi(phi,ce)
integer, intent(in) :: ce
real(pReal), intent(in) :: phi
real(pREAL), intent(in) :: phi
integer :: &
ho, &

46
src/homogenization_mechanical.f90
View File

@ -18,13 +18,13 @@ submodule(homogenization) mechanical
module subroutine isostrain_partitionDeformation(F,avgF)
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 (:,:,:), intent(out) :: F !< partitioned deformation gradient
real(pREAL), dimension (3,3), intent(in) :: avgF !< average deformation gradient at material point
end subroutine isostrain_partitionDeformation
module subroutine RGC_partitionDeformation(F,avgF,ce)
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 (:,:,:), intent(out) :: F !< partitioned deformation gradient
real(pREAL), dimension (3,3), intent(in) :: avgF !< average deformation gradient at material point
integer, intent(in) :: &
ce
end subroutine RGC_partitionDeformation
@ -32,12 +32,12 @@ submodule(homogenization) mechanical
module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy)
logical, dimension(2) :: doneAndHappy
real(pReal), dimension(:,:,:), intent(in) :: &
real(pREAL), dimension(:,:,:), intent(in) :: &
P,& !< partitioned stresses
F !< partitioned deformation gradients
real(pReal), dimension(:,:,:,:,:), intent(in) :: dPdF !< partitioned stiffnesses
real(pReal), dimension(3,3), intent(in) :: avgF !< average F
real(pReal), intent(in) :: dt !< time increment
real(pREAL), dimension(:,:,:,:,:), intent(in) :: dPdF !< partitioned stiffnesses
real(pREAL), dimension(3,3), intent(in) :: avgF !< average F
real(pREAL), intent(in) :: dt !< time increment
integer, intent(in) :: &
ce !< cell
end function RGC_updateState
@ -51,7 +51,7 @@ submodule(homogenization) mechanical
end interface
type :: tOutput !< requested output (per phase)
character(len=pStringLen), allocatable, dimension(:) :: &
character(len=pSTRLEN), allocatable, dimension(:) :: &
label
end type tOutput
type(tOutput), allocatable, dimension(:) :: output_mechanical
@ -76,10 +76,10 @@ module subroutine mechanical_init()
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_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_ISOSTRAIN_ID)) call isostrain_init()
@ -93,13 +93,13 @@ end subroutine mechanical_init
!--------------------------------------------------------------------------------------------------
module subroutine mechanical_partition(subF,ce)
real(pReal), intent(in), dimension(3,3) :: &
real(pREAL), intent(in), dimension(3,3) :: &
subF
integer, intent(in) :: &
ce
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)))
@ -128,7 +128,7 @@ end subroutine mechanical_partition
!--------------------------------------------------------------------------------------------------
module subroutine mechanical_homogenize(Delta_t,ce)
real(pReal), intent(in) :: Delta_t
real(pREAL), intent(in) :: Delta_t
integer, intent(in) :: ce
integer :: co
@ -152,18 +152,18 @@ end subroutine mechanical_homogenize
!--------------------------------------------------------------------------------------------------
module function mechanical_updateState(subdt,subF,ce) result(doneAndHappy)
real(pReal), intent(in) :: &
real(pREAL), intent(in) :: &
subdt !< current time step
real(pReal), intent(in), dimension(3,3) :: &
real(pREAL), intent(in), dimension(3,3) :: &
subF
integer, intent(in) :: &
ce
logical, dimension(2) :: doneAndHappy
integer :: co
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) :: Ps(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) :: Ps(3,3,homogenization_Nconstituents(material_ID_homogenization(ce)))
if (mechanical_type(material_ID_homogenization(ce)) == MECHANICAL_RGC_ID) then
@ -239,11 +239,11 @@ subroutine parseMechanical()
homog => material_homogenization%get_dict(ho)
mechanical => homog%get_dict('mechanical')
#if defined(__GFORTRAN__)
output_mechanical(ho)%label = output_as1dString(mechanical)
output_mechanical(ho)%label = output_as1dStr(mechanical)
#else
output_mechanical(ho)%label = mechanical%get_as1dString('output',defaultVal=emptyStringArray)
output_mechanical(ho)%label = mechanical%get_as1dStr('output',defaultVal=emptyStrArray)
#endif
select case (mechanical%get_asString('type'))
select case (mechanical%get_asStr('type'))
case('pass')
mechanical_type(ho) = MECHANICAL_PASS_ID
case('isostrain')
@ -251,7 +251,7 @@ subroutine parseMechanical()
case('RGC')
mechanical_type(ho) = MECHANICAL_RGC_ID
case default
call IO_error(500,ext_msg=mechanical%get_asString('type'))
call IO_error(500,ext_msg=mechanical%get_asStr('type'))
end select
end do

248
src/homogenization_mechanical_RGC.f90
View File

@ -13,34 +13,34 @@ submodule(homogenization:mechanical) RGC
type :: tParameters
integer, dimension(:), allocatable :: &
N_constituents
real(pReal) :: &
real(pREAL) :: &
xi_alpha, &
c_Alpha
real(pReal), dimension(:), allocatable :: &
real(pREAL), dimension(:), allocatable :: &
D_alpha, &
a_g
character(len=pStringLen), allocatable, dimension(:) :: &
character(len=pSTRLEN), allocatable, dimension(:) :: &
output
end type tParameters
type :: tRGCstate
real(pReal), pointer, dimension(:,:) :: &
real(pREAL), pointer, dimension(:,:) :: &
relaxationVector
end type tRGCstate
type :: tRGCdependentState
real(pReal), allocatable, dimension(:) :: &
real(pREAL), allocatable, dimension(:) :: &
volumeDiscrepancy, &
relaxationRate_avg, &
relaxationRate_max
real(pReal), allocatable, dimension(:,:) :: &
real(pREAL), allocatable, dimension(:,:) :: &
mismatch
real(pReal), allocatable, dimension(:,:,:) :: &
real(pREAL), allocatable, dimension(:,:,:) :: &
orientation
end type tRGCdependentState
type :: tNumerics_RGC
real(pReal) :: &
real(pREAL) :: &
atol, & !< absolute tolerance of RGC residuum
rtol, & !< relative tolerance 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_RGC => num_mechanical%get_dict('RGC',defaultVal=emptyDict)
num%atol = num_RGC%get_asFloat('atol', defaultVal=1.0e+4_pReal)
num%rtol = num_RGC%get_asFloat('rtol', defaultVal=1.0e-3_pReal)
num%absMax = num_RGC%get_asFloat('amax', defaultVal=1.0e+10_pReal)
num%relMax = num_RGC%get_asFloat('rmax', defaultVal=1.0e+2_pReal)
num%pPert = num_RGC%get_asFloat('perturbpenalty', defaultVal=1.0e-7_pReal)
num%xSmoo = num_RGC%get_asFloat('relvantmismatch', defaultVal=1.0e-5_pReal)
num%viscPower = num_RGC%get_asFloat('viscositypower', defaultVal=1.0e+0_pReal)
num%viscModus = num_RGC%get_asFloat('viscositymodulus', defaultVal=0.0e+0_pReal)
num%refRelaxRate = num_RGC%get_asFloat('refrelaxationrate', defaultVal=1.0e-3_pReal)
num%maxdRelax = num_RGC%get_asFloat('maxrelaxationrate', defaultVal=1.0e+0_pReal)
num%maxVolDiscr = num_RGC%get_asFloat('maxvoldiscrepancy', defaultVal=1.0e-5_pReal)
num%volDiscrMod = num_RGC%get_asFloat('voldiscrepancymod', defaultVal=1.0e+12_pReal)
num%volDiscrPow = num_RGC%get_asFloat('dicrepancypower', defaultVal=5.0_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%absMax = num_RGC%get_asReal('amax', defaultVal=1.0e+10_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%xSmoo = num_RGC%get_asReal('relvantmismatch', defaultVal=1.0e-5_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%refRelaxRate = num_RGC%get_asReal('refrelaxationrate', defaultVal=1.0e-3_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%volDiscrMod = num_RGC%get_asReal('voldiscrepancymod', defaultVal=1.0e+12_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%rtol <= 0.0_pReal) call IO_error(301,ext_msg='relTol_RGC')
if (num%absMax <= 0.0_pReal) call IO_error(301,ext_msg='absMax_RGC')
if (num%relMax <= 0.0_pReal) call IO_error(301,ext_msg='relMax_RGC')
if (num%pPert <= 0.0_pReal) call IO_error(301,ext_msg='pPert_RGC')
if (num%xSmoo <= 0.0_pReal) call IO_error(301,ext_msg='xSmoo_RGC')
if (num%viscPower < 0.0_pReal) call IO_error(301,ext_msg='viscPower_RGC')
if (num%viscModus < 0.0_pReal) call IO_error(301,ext_msg='viscModus_RGC')
if (num%refRelaxRate <= 0.0_pReal) call IO_error(301,ext_msg='refRelaxRate_RGC')
if (num%maxdRelax <= 0.0_pReal) call IO_error(301,ext_msg='maxdRelax_RGC')
if (num%maxVolDiscr <= 0.0_pReal) call IO_error(301,ext_msg='maxVolDiscr_RGC')
if (num%volDiscrMod < 0.0_pReal) call IO_error(301,ext_msg='volDiscrMod_RGC')
if (num%volDiscrPow <= 0.0_pReal) call IO_error(301,ext_msg='volDiscrPw_RGC')
if (num%atol <= 0.0_pREAL) call IO_error(301,ext_msg='absTol_RGC')
if (num%rtol <= 0.0_pREAL) call IO_error(301,ext_msg='relTol_RGC')
if (num%absMax <= 0.0_pREAL) call IO_error(301,ext_msg='absMax_RGC')
if (num%relMax <= 0.0_pREAL) call IO_error(301,ext_msg='relMax_RGC')
if (num%pPert <= 0.0_pREAL) call IO_error(301,ext_msg='pPert_RGC')
if (num%xSmoo <= 0.0_pREAL) call IO_error(301,ext_msg='xSmoo_RGC')
if (num%viscPower < 0.0_pREAL) call IO_error(301,ext_msg='viscPower_RGC')
if (num%viscModus < 0.0_pREAL) call IO_error(301,ext_msg='viscModus_RGC')
if (num%refRelaxRate <= 0.0_pREAL) call IO_error(301,ext_msg='refRelaxRate_RGC')
if (num%maxdRelax <= 0.0_pREAL) call IO_error(301,ext_msg='maxdRelax_RGC')
if (num%maxVolDiscr <= 0.0_pREAL) call IO_error(301,ext_msg='maxVolDiscr_RGC')
if (num%volDiscrMod < 0.0_pREAL) call IO_error(301,ext_msg='volDiscrMod_RGC')
if (num%volDiscrPow <= 0.0_pREAL) call IO_error(301,ext_msg='volDiscrPw_RGC')
do ho = 1, size(mechanical_type)
@ -147,20 +147,20 @@ module subroutine RGC_init()
dst => dependentState(ho))
#if defined (__GFORTRAN__)
prm%output = output_as1dString(homogMech)
prm%output = output_as1dStr(homogMech)
#else
prm%output = homogMech%get_as1dString('output',defaultVal=emptyStringArray)
prm%output = homogMech%get_as1dStr('output',defaultVal=emptyStrArray)
#endif
prm%N_constituents = homogMech%get_as1dInt('cluster_size',requiredSize=3)
if (homogenization_Nconstituents(ho) /= product(prm%N_constituents)) &
call IO_error(211,ext_msg='N_constituents (RGC)')
prm%xi_alpha = homogMech%get_asFloat('xi_alpha')
prm%c_alpha = homogMech%get_asFloat('c_alpha')
prm%xi_alpha = homogMech%get_asReal('xi_alpha')
prm%c_alpha = homogMech%get_asReal('c_alpha')
prm%D_alpha = homogMech%get_as1dFloat('D_alpha', requiredSize=3)
prm%a_g = homogMech%get_as1dFloat('a_g', requiredSize=3)
prm%D_alpha = homogMech%get_as1dReal('D_alpha', requiredSize=3)
prm%a_g = homogMech%get_as1dReal('a_g', requiredSize=3)
Nmembers = count(material_ID_homogenization == ho)
nIntFaceTot = 3*( (prm%N_constituents(1)-1)*prm%N_constituents(2)*prm%N_constituents(3) &
@ -169,16 +169,16 @@ module subroutine RGC_init()
sizeState = nIntFaceTot
homogState(ho)%sizeState = sizeState
allocate(homogState(ho)%state0 (sizeState,Nmembers), source=0.0_pReal)
allocate(homogState(ho)%state (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)
stt%relaxationVector => homogState(ho)%state(1:nIntFaceTot,:)
st0%relaxationVector => homogState(ho)%state0(1:nIntFaceTot,:)
allocate(dst%volumeDiscrepancy( 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%mismatch( 3,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_max( Nmembers), source=0.0_pREAL)
allocate(dst%mismatch( 3,Nmembers), source=0.0_pREAL)
!--------------------------------------------------------------------------------------------------
! assigning cluster orientations
@ -197,13 +197,13 @@ end subroutine RGC_init
!--------------------------------------------------------------------------------------------------
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) :: &
ce
real(pReal), dimension(3) :: aVect,nVect
real(pREAL), dimension(3) :: aVect,nVect
integer, dimension(4) :: intFace
integer, dimension(3) :: iGrain3
integer :: iGrain,iFace,i,j,ho,en
@ -214,7 +214,7 @@ module subroutine RGC_partitionDeformation(F,avgF,ce)
en = material_entry_homogenization(ce)
!--------------------------------------------------------------------------------------------------
! 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)
iGrain3 = grain1to3(iGrain,prm%N_constituents)
do iFace = 1,6
@ -238,25 +238,25 @@ end subroutine RGC_partitionDeformation
!--------------------------------------------------------------------------------------------------
module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy)
logical, dimension(2) :: doneAndHappy
real(pReal), dimension(:,:,:), intent(in) :: &
real(pREAL), dimension(:,:,:), intent(in) :: &
P,& !< partitioned stresses
F !< partitioned deformation gradients
real(pReal), dimension(:,:,:,:,:), intent(in) :: dPdF !< partitioned stiffnesses
real(pReal), dimension(3,3), intent(in) :: avgF !< average F
real(pReal), intent(in) :: dt !< time increment
real(pREAL), dimension(:,:,:,:,:), intent(in) :: dPdF !< partitioned stiffnesses
real(pREAL), dimension(3,3), intent(in) :: avgF !< average F
real(pREAL), intent(in) :: dt !< time increment
integer, intent(in) :: &
ce !< cell
integer, dimension(4) :: intFaceN,intFaceP,faceID
integer, dimension(3) :: nGDim,iGr3N,iGr3P
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,size(P,3)) :: NN,devNull
real(pReal), dimension(3) :: normP,normN,mornP,mornN
real(pReal) :: residMax,stresMax
real(pREAL), dimension(3,3,size(P,3)) :: R,pF,pR,D,pD
real(pREAL), dimension(3,size(P,3)) :: NN,devNull
real(pREAL), dimension(3) :: normP,normN,mornP,mornN
real(pREAL) :: residMax,stresMax
logical :: error
real(pReal), dimension(:,:), allocatable :: tract,jmatrix,jnverse,smatrix,pmatrix,rmatrix
real(pReal), dimension(:), allocatable :: resid,relax,p_relax,p_resid,drelax
real(pREAL), dimension(:,:), allocatable :: tract,jmatrix,jnverse,smatrix,pmatrix,rmatrix
real(pREAL), dimension(:), allocatable :: resid,relax,p_relax,p_resid,drelax
zeroTimeStep: if (dEq0(dt)) then
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(resid(3*nIntFaceTot), source=0.0_pReal)
allocate(tract(nIntFaceTot,3), source=0.0_pReal)
allocate(resid(3*nIntFaceTot), source=0.0_pREAL)
allocate(tract(nIntFaceTot,3), source=0.0_pREAL)
relax = stt%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
doneAndHappy = .true.
dst%mismatch(1:3,en) = sum(NN,2)/real(nGrain,pReal)
dst%relaxationRate_avg(en) = sum(abs(drelax))/dt/real(3*nIntFaceTot,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_max(en) = maxval(abs(drelax))/dt
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"
allocate(smatrix(3*nIntFaceTot,3*nIntFaceTot), source=0.0_pReal)
allocate(smatrix(3*nIntFaceTot,3*nIntFaceTot), source=0.0_pREAL)
do iNum = 1,nIntFaceTot
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
! perturbation method) "pmatrix"
allocate(pmatrix(3*nIntFaceTot,3*nIntFaceTot), source=0.0_pReal)
allocate(p_relax(3*nIntFaceTot), source=0.0_pReal)
allocate(p_resid(3*nIntFaceTot), source=0.0_pReal)
allocate(pmatrix(3*nIntFaceTot,3*nIntFaceTot), source=0.0_pREAL)
allocate(p_relax(3*nIntFaceTot), source=0.0_pREAL)
allocate(p_resid(3*nIntFaceTot), source=0.0_pREAL)
do ipert = 1,3*nIntFaceTot
p_relax = relax
@ -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
p_resid = 0.0_pReal
p_resid = 0.0_pREAL
do iNum = 1,nIntFaceTot
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"
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
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
@ -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
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)
!--------------------------------------------------------------------------------------------------
! 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
drelax(i) = drelax(i) - jnverse(i,j)*resid(j) ! Calculate the correction for the state variable
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)
real(pReal), dimension (:,:,:), intent(out) :: rPen !< stress-like penalty
real(pReal), dimension (:,:), intent(out) :: nMis !< total amount of mismatch
real(pREAL), dimension (:,:,:), intent(out) :: rPen !< stress-like penalty
real(pREAL), dimension (:,:), intent(out) :: nMis !< total amount of mismatch
real(pReal), dimension (:,:,:), intent(in) :: fDef !< deformation gradients
real(pReal), dimension (3,3), intent(in) :: avgF !< initial effective stretch tensor
real(pREAL), dimension (:,:,:), intent(in) :: fDef !< deformation gradients
real(pREAL), dimension (3,3), intent(in) :: avgF !< initial effective stretch tensor
integer, intent(in) :: ho, en
integer, dimension (4) :: intFace
integer, dimension (3) :: iGrain3,iGNghb3,nGDim
real(pReal), dimension (3,3) :: gDef,nDef
real(pReal), dimension (3) :: nVect,surfCorr
real(pREAL), dimension (3,3) :: gDef,nDef
real(pREAL), dimension (3) :: nVect,surfCorr
integer :: iGrain,iGNghb,iFace,i,j,k,l
real(pReal) :: muGrain,muGNghb,nDefNorm
real(pReal), parameter :: &
nDefToler = 1.0e-10_pReal, &
b = 2.5e-10_pReal ! Length of Burgers vector
real(pREAL) :: muGrain,muGNghb,nDefNorm
real(pREAL), parameter :: &
nDefToler = 1.0e-10_pREAL, &
b = 2.5e-10_pREAL ! Length of Burgers vector
nGDim = param(ho)%N_constituents
rPen = 0.0_pReal
nMis = 0.0_pReal
rPen = 0.0_pREAL
nMis = 0.0_pREAL
!----------------------------------------------------------------------------------------------
! 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)
iGNghb3 = iGrain3 ! identify the neighboring grain across the interface
iGNghb3(abs(intFace(1))) = iGNghb3(abs(intFace(1))) &
+ int(real(intFace(1),pReal)/real(abs(intFace(1)),pReal))
+ int(real(intFace(1),pREAL)/real(abs(intFace(1)),pREAL))
where(iGNghb3 < 1) iGNghb3 = nGDim
where(iGNghb3 >nGDim) iGNghb3 = 1
iGNghb = grain3to1(iGNghb3,prm%N_constituents) ! get the ID of the neighboring grain
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
nDefNorm = 0.0_pReal
nDef = 0.0_pReal
nDefNorm = 0.0_pREAL
nDef = 0.0_pREAL
do i = 1,3; do j = 1,3
do k = 1,3; do l = 1,3
nDef(i,j) = nDef(i,j) - nVect(k)*gDef(i,l)*math_LeviCivita(j,k,l) ! compute the interface mismatch tensor from the jump of deformation gradient
@ -556,10 +556,10 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy)
!-------------------------------------------------------------------------------------------
! compute the stress penalty of all interfaces
do i = 1,3; do j = 1,3; do k = 1,3; do l = 1,3
rPen(i,j,iGrain) = rPen(i,j,iGrain) + 0.5_pReal*(muGrain*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))) &
*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)
end do; end do;end do; end do
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)
real(pReal), dimension (:,:,:), intent(out) :: vPen ! stress-like penalty due to volume
real(pReal), intent(out) :: vDiscrep ! total volume discrepancy
real(pREAL), dimension (:,:,:), intent(out) :: vPen ! stress-like penalty due to volume
real(pREAL), intent(out) :: vDiscrep ! total volume discrepancy
real(pReal), dimension (:,:,:), intent(in) :: fDef ! deformation gradients
real(pReal), dimension (3,3), intent(in) :: fAvg ! overall deformation gradient
real(pREAL), dimension (:,:,:), intent(in) :: fDef ! deformation gradients
real(pREAL), dimension (3,3), intent(in) :: fAvg ! overall deformation gradient
integer, intent(in) :: &
Ngrain
real(pReal), dimension(size(vPen,3)) :: gVol
real(pREAL), dimension(size(vPen,3)) :: gVol
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
do i = 1,nGrain
gVol(i) = math_det33(fDef(1:3,1:3,i)) ! compute the volume of individual grains
vDiscrep = vDiscrep - gVol(i)/real(nGrain,pReal) ! calculate the difference/dicrepancy between
vDiscrep = vDiscrep - gVol(i)/real(nGrain,pREAL) ! calculate the difference/dicrepancy between
! the volume of the cluster and the the total volume of grains
end do
!----------------------------------------------------------------------------------------------
! calculate the stress and penalty due to volume discrepancy
vPen = 0.0_pReal
vPen = 0.0_pREAL
do i = 1,nGrain
vPen(:,:,i) = -real(nGrain,pReal)**(-1)*num%volDiscrMod*num%volDiscrPow/num%maxVolDiscr &
* sign((abs(vDiscrep)/num%maxVolDiscr)**(num%volDiscrPow - 1.0_pReal),vDiscrep) &
vPen(:,:,i) = -real(nGrain,pREAL)**(-1)*num%volDiscrMod*num%volDiscrPow/num%maxVolDiscr &
* sign((abs(vDiscrep)/num%maxVolDiscr)**(num%volDiscrPow - 1.0_pREAL),vDiscrep) &
* gVol(i)*transpose(math_inv33(fDef(:,:,i)))
end do
@ -615,21 +615,21 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy)
!--------------------------------------------------------------------------------------------------
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) :: &
ho, &
en
real(pReal), dimension(3,3) :: invC
real(pReal), dimension(3) :: nVect
real(pReal) :: detF
real(pREAL), dimension(3,3) :: invC
real(pREAL), dimension(3) :: nVect
real(pREAL) :: detF
integer :: i,j,iBase
logical :: error
call math_invert33(invC,detF,error,matmul(transpose(avgF),avgF))
surfaceCorrection = 0.0_pReal
surfaceCorrection = 0.0_pREAL
do iBase = 1,3
nVect = interfaceNormal([iBase,1,1,1],ho,en)
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
!-------------------------------------------------------------------------------------------------
real(pReal) function equivalentMu(co,ce)
real(pREAL) function equivalentMu(co,ce)
integer, intent(in) :: &
co,&
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!
@ -665,14 +665,14 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy)
!-------------------------------------------------------------------------------------------------
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) :: &
ho, &
en
real(pReal), dimension(3) :: aVect,nVect
real(pREAL), dimension(3) :: aVect,nVect
integer, dimension(4) :: intFace
integer, dimension(3) :: iGrain3
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))
F = 0.0_pReal
F = 0.0_pREAL
do iGrain = 1,product(prm%N_constituents)
iGrain3 = grain1to3(iGrain,prm%N_constituents)
do iFace = 1,6
@ -739,7 +739,7 @@ end subroutine RGC_result
!--------------------------------------------------------------------------------------------------
pure function relaxationVector(intFace,ho,en)
real(pReal), dimension (3) :: relaxationVector
real(pREAL), dimension (3) :: relaxationVector
integer, intent(in) :: ho,en
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
relaxationVector = stt%relaxationVector((3*iNum-2):(3*iNum),en)
else
relaxationVector = 0.0_pReal
relaxationVector = 0.0_pREAL
end if
end associate
@ -769,7 +769,7 @@ end function relaxationVector
!--------------------------------------------------------------------------------------------------
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, intent(in) :: &
ho, &
@ -778,8 +778,8 @@ pure function interfaceNormal(intFace,ho,en) result(n)
associate (dst => dependentState(ho))
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 = 0.0_pREAL
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)
@ -800,7 +800,7 @@ pure function getInterface(iFace,iGrain3) result(i)
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]
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
interface1to4(1) = 1
interface1to4(3) = mod((iFace1D-1),nGDim(2))+1
interface1to4(4) = mod(int(real(iFace1D-1,pReal)/real(nGDim(2),pReal)),nGDim(3))+1
interface1to4(2) = int(real(iFace1D-1,pReal)/real(nGDim(2),pReal)/real(nGDim(3),pReal))+1
interface1to4(4) = mod(int(real(iFace1D-1,pREAL)/real(nGDim(2),pREAL)),nGDim(3))+1
interface1to4(2) = int(real(iFace1D-1,pREAL)/real(nGDim(2),pREAL)/real(nGDim(3),pREAL))+1
elseif (iFace1D > nIntFace(1) .and. iFace1D <= (nIntFace(2) + nIntFace(1))) then ! interface with normal || e2
interface1to4(1) = 2
interface1to4(4) = mod((iFace1D-nIntFace(1)-1),nGDim(3))+1
interface1to4(2) = mod(int(real(iFace1D-nIntFace(1)-1,pReal)/real(nGDim(3),pReal)),nGDim(1))+1
interface1to4(3) = int(real(iFace1D-nIntFace(1)-1,pReal)/real(nGDim(3),pReal)/real(nGDim(1),pReal))+1
interface1to4(2) = mod(int(real(iFace1D-nIntFace(1)-1,pREAL)/real(nGDim(3),pREAL)),nGDim(1))+1
interface1to4(3) = int(real(iFace1D-nIntFace(1)-1,pREAL)/real(nGDim(3),pREAL)/real(nGDim(1),pREAL))+1
elseif (iFace1D > nIntFace(2) + nIntFace(1) .and. iFace1D <= (nIntFace(3) + nIntFace(2) + nIntFace(1))) then ! interface with normal || e3
interface1to4(1) = 3
interface1to4(2) = mod((iFace1D-nIntFace(2)-nIntFace(1)-1),nGDim(1))+1
interface1to4(3) = mod(int(real(iFace1D-nIntFace(2)-nIntFace(1)-1,pReal)/real(nGDim(1),pReal)),nGDim(2))+1
interface1to4(4) = int(real(iFace1D-nIntFace(2)-nIntFace(1)-1,pReal)/real(nGDim(1),pReal)/real(nGDim(2),pReal))+1
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
end if
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)
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))

24
src/homogenization_thermal.f90
View File

@ -14,13 +14,13 @@ submodule(homogenization) thermal
end interface
type :: tDataContainer
real(pReal), dimension(:), allocatable :: T, dot_T
real(pREAL), dimension(:), allocatable :: T, dot_T
end type tDataContainer
type(tDataContainer), dimension(:), allocatable :: current
type :: tParameters
character(len=pStringLen), allocatable, dimension(:) :: &
character(len=pSTRLEN), allocatable, dimension(:) :: &
output
end type tParameters
@ -51,18 +51,18 @@ module subroutine thermal_init()
do ho = 1, configHomogenizations%length
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)
associate(prm => param(ho))
if (configHomogenization%contains('thermal')) then
configHomogenizationThermal => configHomogenization%get_dict('thermal')
#if defined (__GFORTRAN__)
prm%output = output_as1dString(configHomogenizationThermal)
prm%output = output_as1dStr(configHomogenizationThermal)
#else
prm%output = configHomogenizationThermal%get_as1dString('output',defaultVal=emptyStringArray)
prm%output = configHomogenizationThermal%get_as1dStr('output',defaultVal=emptyStrArray)
#endif
select case (configHomogenizationThermal%get_asString('type'))
select case (configHomogenizationThermal%get_asStr('type'))
case ('pass')
call pass_init()
@ -72,7 +72,7 @@ module subroutine thermal_init()
end select
else
prm%output = emptyStringArray
prm%output = emptyStrArray
end if
end associate
@ -100,7 +100,7 @@ module subroutine thermal_partition(ce)
integer, intent(in) :: ce
real(pReal) :: T, dot_T
real(pREAL) :: T, dot_T
integer :: co
@ -119,7 +119,7 @@ end subroutine thermal_partition
module function homogenization_mu_T(ce) result(mu)
integer, intent(in) :: ce
real(pReal) :: mu
real(pREAL) :: mu
integer :: co
@ -138,7 +138,7 @@ end function homogenization_mu_T
module function homogenization_K_T(ce) result(K)
integer, intent(in) :: ce
real(pReal), dimension(3,3) :: K
real(pREAL), dimension(3,3) :: K
integer :: co
@ -157,7 +157,7 @@ end function homogenization_K_T
module function homogenization_f_T(ce) result(f)
integer, intent(in) :: ce
real(pReal) :: f
real(pREAL) :: f
integer :: co
@ -176,7 +176,7 @@ end function homogenization_f_T
module subroutine homogenization_thermal_setField(T,dot_T, 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

382
src/lattice.f90
View File

@ -38,7 +38,7 @@ module lattice
CF_NTRANS = sum(CF_NTRANSSYSTEM), & !< total # of transformation 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([&
! <110>{111} systems
0, 1,-1, 1, 1, 1, & ! B2
@ -60,9 +60,9 @@ module lattice
1, 0,-1, 1, 0, 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( [&
! <112>{111} systems
-2, 1, 1, 1, 1, 1, &
@ -77,7 +77,7 @@ module lattice
2, 1,-1, -1, 1,-1, &
-1,-2,-1, -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 :: &
lattice_CF_TWINNUCLEATIONSLIPPAIR = reshape( [&
@ -95,13 +95,13 @@ module lattice
10,11 &
],shape(lattice_CF_TWINNUCLEATIONSLIPPAIR))
real(pReal), dimension(3+3,CF_NCLEAVAGE), parameter :: &
real(pREAL), dimension(3+3,CF_NCLEAVAGE), parameter :: &
CF_SYSTEMCLEAVAGE = reshape(real([&
! <001>{001} systems
0, 1, 0, 1, 0, 0, &
0, 0, 1, 0, 1, 0, &
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)
@ -120,7 +120,7 @@ module lattice
CI_NTWIN = sum(CI_NTWINSYSTEM), & !< total # of twin 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([&
! <111>{110} systems
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 &
],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([&
! <111>{112} systems
-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 &
],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([&
! <001>{001} systems
0, 1, 0, 1, 0, 0, &
0, 0, 1, 0, 1, 0, &
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)
@ -213,7 +213,7 @@ module lattice
HP_NSLIP = sum(HP_NSLIPSYSTEM), & !< total # of slip 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([&
! <-1-1.0>{00.1}/basal systems (independent of c/a-ratio)
2, -1, -1, 0, 0, 0, 0, 1, &
@ -250,9 +250,9 @@ module lattice
1, 1, -2, 3, -1, -1, 2, 2, &
-1, 2, -1, 3, 1, -2, 1, 2, &
-2, 1, 1, 3, 2, -1, -1, 2 &
],pReal),shape(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([&
! <-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
@ -286,7 +286,7 @@ module lattice
-1, -1, 2, -3, -1, -1, 2, 2, &
1, -2, 1, -3, 1, -2, 1, 2, &
2, -1, -1, -3, 2, -1, -1, 2 &
],pReal),shape(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)
@ -297,7 +297,7 @@ module lattice
integer, parameter :: &
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([&
! {100)<001] systems
0, 0, 1, 1, 0, 0, &
@ -364,7 +364,7 @@ module lattice
1,-1, 1, -2,-1, 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
@ -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
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol)
real(pReal), intent(in) :: cOverA !< c/a ratio
real(pReal), dimension(sum(Ntwin)) :: characteristicShear
real(pREAL), intent(in) :: cOverA !< c/a ratio
real(pREAL), dimension(sum(Ntwin)) :: characteristicShear
integer :: &
a, & !< index of active system
@ -467,20 +467,20 @@ function lattice_characteristicShear_Twin(Ntwin,lattice,CoverA) result(character
a = a + 1
select case(lattice)
case('cF','cI')
characteristicShear(a) = 0.5_pReal*sqrt(2.0_pReal)
characteristicShear(a) = 0.5_pREAL*sqrt(2.0_pREAL)
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')
p = sum(HP_NTWINSYSTEM(1:f-1))+s
select case(HP_SHEARTWIN(p)) ! from Christian & Mahajan 1995 p.29
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}
characteristicShear(a) = 1.0_pReal/cOverA
characteristicShear(a) = 1.0_pREAL/cOverA
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}
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
case default
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
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol)
real(pReal), dimension(6,6), intent(in) :: C66 !< unrotated parent stiffness matrix
real(pReal), intent(in) :: cOverA !< c/a ratio
real(pReal), dimension(6,6,sum(Ntwin)) :: lattice_C66_twin
real(pREAL), dimension(6,6), intent(in) :: C66 !< unrotated parent stiffness matrix
real(pREAL), intent(in) :: cOverA !< c/a ratio
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
integer :: i
@ -510,10 +510,10 @@ function lattice_C66_twin(Ntwin,C66,lattice,CoverA)
select case(lattice)
case('cF')
coordinateSystem = buildCoordinateSystem(Ntwin,CF_NSLIPSYSTEM,CF_SYSTEMTWIN,&
lattice,0.0_pReal)
lattice,0.0_pREAL)
case('cI')
coordinateSystem = buildCoordinateSystem(Ntwin,CI_NSLIPSYSTEM,CI_SYSTEMTWIN,&
lattice,0.0_pReal)
lattice,0.0_pREAL)
case('hP')
coordinateSystem = buildCoordinateSystem(Ntwin,HP_NSLIPSYSTEM,HP_SYSTEMTWIN,&
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
character(len=*), intent(in) :: lattice_target !< Bravais lattice (Pearson symbol)
real(pReal), dimension(6,6), intent(in) :: C_parent66
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), intent(in) :: C_parent66
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) :: C_bar66, C_target_unrotated66
real(pReal), dimension(3,3,sum(Ntrans)) :: Q,S
real(pREAL), dimension(6,6) :: C_bar66, C_target_unrotated66
real(pREAL), dimension(3,3,sum(Ntrans)) :: Q,S
type(tRotation) :: R
integer :: i
@ -551,24 +551,24 @@ function lattice_C66_trans(Ntrans,C_parent66,lattice_target, &
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.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))
C_bar66(1,1) = (C_parent66(1,1) + C_parent66(1,2) + 2.0_pReal*C_parent66(4,4))/2.0_pReal
C_bar66(1,2) = (C_parent66(1,1) + 5.0_pReal*C_parent66(1,2) - 2.0_pReal*C_parent66(4,4))/6.0_pReal
C_bar66(3,3) = (C_parent66(1,1) + 2.0_pReal*C_parent66(1,2) + 4.0_pReal*C_parent66(4,4))/3.0_pReal
C_bar66(1,3) = (C_parent66(1,1) + 2.0_pReal*C_parent66(1,2) - 2.0_pReal*C_parent66(4,4))/3.0_pReal
C_bar66(4,4) = (C_parent66(1,1) - C_parent66(1,2) + C_parent66(4,4))/3.0_pReal
C_bar66(1,4) = (C_parent66(1,1) - C_parent66(1,2) - 2.0_pReal*C_parent66(4,4)) /(3.0_pReal*sqrt(2.0_pReal))
C_bar66(1,1) = (C_parent66(1,1) + C_parent66(1,2) + 2.0_pREAL*C_parent66(4,4))/2.0_pREAL
C_bar66(1,2) = (C_parent66(1,1) + 5.0_pREAL*C_parent66(1,2) - 2.0_pREAL*C_parent66(4,4))/6.0_pREAL
C_bar66(3,3) = (C_parent66(1,1) + 2.0_pREAL*C_parent66(1,2) + 4.0_pREAL*C_parent66(4,4))/3.0_pREAL
C_bar66(1,3) = (C_parent66(1,1) + 2.0_pREAL*C_parent66(1,2) - 2.0_pREAL*C_parent66(4,4))/3.0_pREAL
C_bar66(4,4) = (C_parent66(1,1) - C_parent66(1,2) + C_parent66(4,4))/3.0_pREAL
C_bar66(1,4) = (C_parent66(1,1) - C_parent66(1,2) - 2.0_pREAL*C_parent66(4,4)) /(3.0_pREAL*sqrt(2.0_pREAL))
C_target_unrotated66 = 0.0_pReal
C_target_unrotated66 = 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,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(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')
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))
C_target_unrotated66 = C_parent66
else
@ -598,26 +598,26 @@ function lattice_C66_trans(Ntrans,C_parent66,lattice_target, &
function lattice_nonSchmidMatrix(Nslip,nonSchmidCoefficients,sense) result(nonSchmidMatrix)
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)
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(3) :: direction, normal, np
real(pREAL), dimension(1:3,1:3,sum(Nslip)) :: coordinateSystem !< coordinate system of slip system
real(pREAL), dimension(3) :: direction, normal, np
type(tRotation) :: R
integer :: i
if (abs(sense) /= 1) error stop 'Sense in lattice_nonSchmidMatrix'
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
nonSchmidMatrix = lattice_SchmidMatrix_slip(Nslip,'cI',0.0_pReal) ! Schmid contribution
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
nonSchmidMatrix = lattice_SchmidMatrix_slip(Nslip,'cI',0.0_pREAL) ! Schmid contribution
do i = 1,sum(Nslip)
direction = coordinateSystem(1:3,1,i)
normal = coordinateSystem(1:3,2,i)
call R%fromAxisAngle([direction,60.0_pReal],degrees=.true.,P=1)
call R%fromAxisAngle([direction,60.0_pREAL],degrees=.true.,P=1)
np = R%rotate(normal)
if (size(nonSchmidCoefficients)>0) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) &
@ -647,9 +647,9 @@ end function lattice_nonSchmidMatrix
function lattice_interaction_SlipBySlip(Nslip,interactionValues,lattice) result(interactionMatrix)
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)
real(pReal), dimension(sum(Nslip),sum(Nslip)) :: interactionMatrix
real(pREAL), dimension(sum(Nslip),sum(Nslip)) :: interactionMatrix
integer, dimension(:), allocatable :: NslipMax
integer, dimension(:,:), allocatable :: interactionTypes
@ -965,9 +965,9 @@ end function lattice_interaction_SlipBySlip
function lattice_interaction_TwinByTwin(Ntwin,interactionValues,lattice) result(interactionMatrix)
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)
real(pReal), dimension(sum(Ntwin),sum(Ntwin)) :: interactionMatrix
real(pREAL), dimension(sum(Ntwin),sum(Ntwin)) :: interactionMatrix
integer, dimension(:), allocatable :: NtwinMax
integer, dimension(:,:), allocatable :: interactionTypes
@ -1064,9 +1064,9 @@ end function lattice_interaction_TwinByTwin
function lattice_interaction_TransByTrans(Ntrans,interactionValues,lattice) result(interactionMatrix)
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)
real(pReal), dimension(sum(Ntrans),sum(Ntrans)) :: interactionMatrix
real(pREAL), dimension(sum(Ntrans),sum(Ntrans)) :: interactionMatrix
integer, dimension(:), allocatable :: NtransMax
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
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)
real(pReal), dimension(sum(Nslip),sum(Ntwin)) :: interactionMatrix
real(pREAL), dimension(sum(Nslip),sum(Ntwin)) :: interactionMatrix
integer, dimension(:), allocatable :: NslipMax, &
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
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)
real(pReal), dimension(sum(Nslip),sum(Ntrans)) :: interactionMatrix
real(pREAL), dimension(sum(Nslip),sum(Ntrans)) :: interactionMatrix
integer, dimension(:), allocatable :: NslipMax, &
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
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)
real(pReal), dimension(sum(Ntwin),sum(Nslip)) :: interactionMatrix
real(pREAL), dimension(sum(Ntwin),sum(Nslip)) :: interactionMatrix
integer, dimension(:), allocatable :: NtwinMax, &
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
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol)
real(pReal), intent(in) :: cOverA
real(pReal), dimension(3,3,sum(Nslip)) :: SchmidMatrix
real(pREAL), intent(in) :: cOverA
real(pREAL), dimension(3,3,sum(Nslip)) :: SchmidMatrix
real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem
real(pReal), dimension(:,:), allocatable :: slipSystems
real(pREAL), dimension(3,3,sum(Nslip)) :: coordinateSystem
real(pREAL), dimension(:,:), allocatable :: slipSystems
integer, dimension(:), allocatable :: NslipMax
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
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol)
real(pReal), intent(in) :: cOverA !< c/a ratio
real(pReal), dimension(3,3,sum(Ntwin)) :: SchmidMatrix
real(pREAL), intent(in) :: cOverA !< c/a ratio
real(pREAL), dimension(3,3,sum(Ntwin)) :: SchmidMatrix
real(pReal), dimension(3,3,sum(Ntwin)) :: coordinateSystem
real(pReal), dimension(:,:), allocatable :: twinSystems
real(pREAL), dimension(3,3,sum(Ntwin)) :: coordinateSystem
real(pREAL), dimension(:,:), allocatable :: twinSystems
integer, dimension(:), allocatable :: NtwinMax
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
character(len=*), intent(in) :: lattice_target !< Bravais lattice (Pearson symbol)
real(pReal), optional, intent(in) :: cOverA, a_cI, a_cF
real(pReal), dimension(3,3,sum(Ntrans)) :: SchmidMatrix
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)) :: devNull
real(pREAL), dimension(3,3,sum(Ntrans)) :: devNull
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 buildTransformationSystem(devNull,SchmidMatrix,Ntrans,cOverA=cOverA)
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 buildTransformationSystem(devNull,SchmidMatrix,Ntrans,a_cF=a_cF,a_cI=a_cI)
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
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol)
real(pReal), intent(in) :: cOverA !< c/a ratio
real(pReal), dimension(3,3,3,sum(Ncleavage)) :: SchmidMatrix
real(pREAL), intent(in) :: cOverA !< c/a ratio
real(pREAL), dimension(3,3,3,sum(Ncleavage)) :: SchmidMatrix
real(pReal), dimension(3,3,sum(Ncleavage)) :: coordinateSystem
real(pReal), dimension(:,:), allocatable :: cleavageSystems
real(pREAL), dimension(3,3,sum(Ncleavage)) :: coordinateSystem
real(pREAL), dimension(:,:), allocatable :: cleavageSystems
integer, dimension(:), allocatable :: NcleavageMax
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
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol)
real(pReal), intent(in) :: cOverA !< c/a ratio
real(pReal), dimension(3,sum(Nslip)) :: d
real(pREAL), intent(in) :: cOverA !< c/a ratio
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)
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
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol)
real(pReal), intent(in) :: cOverA !< c/a ratio
real(pReal), dimension(3,sum(Nslip)) :: n
real(pREAL), intent(in) :: cOverA !< c/a ratio
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)
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
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol)
real(pReal), intent(in) :: cOverA !< c/a ratio
real(pReal), dimension(3,sum(Nslip)) :: t
real(pREAL), intent(in) :: cOverA !< c/a ratio
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)
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
real(pReal), dimension(:,:), allocatable :: slipSystems
real(pREAL), dimension(:,:), allocatable :: slipSystems
integer, dimension(:), allocatable :: NslipMax
select case(lattice)
@ -1658,13 +1658,13 @@ end function lattice_labels_slip
!--------------------------------------------------------------------------------------------------
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)
T_sym = 0.0_pReal
T_sym = 0.0_pREAL
select case(lattice)
case('cF','cI')
@ -1686,15 +1686,15 @@ end function lattice_symmetrize_33
!--------------------------------------------------------------------------------------------------
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)
integer :: i,j
C66_sym = 0.0_pReal
C66_sym = 0.0_pREAL
select case(lattice)
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,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(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')
C66_sym(1,1) = C66(1,1); C66_sym(2,2) = C66(1,1)
C66_sym(3,3) = C66(3,3)
@ -1737,7 +1737,7 @@ function lattice_labels_twin(Ntwin,lattice) result(labels)
character(len=:), dimension(:), allocatable :: labels
real(pReal), dimension(:,:), allocatable :: twinSystems
real(pREAL), dimension(:,:), allocatable :: twinSystems
integer, dimension(:), allocatable :: NtwinMax
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
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol)
real(pReal), intent(in) :: cOverA !< c/a ratio
real(pReal), dimension(sum(Nslip),sum(Nslip)) :: projection
real(pREAL), intent(in) :: cOverA !< c/a ratio
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
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
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol)
real(pReal), intent(in) :: cOverA !< c/a ratio
real(pReal), dimension(sum(Nslip),sum(Nslip)) :: projection
real(pREAL), intent(in) :: cOverA !< c/a ratio
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
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
character(len=*), intent(in) :: lattice !< Bravais lattice (Pearson symbol)
real(pReal), intent(in) :: cOverA !< c/a ratio
real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem
real(pREAL), intent(in) :: cOverA !< c/a ratio
real(pREAL), dimension(3,3,sum(Nslip)) :: coordinateSystem
real(pReal), dimension(:,:), allocatable :: slipSystems
real(pREAL), dimension(:,:), allocatable :: slipSystems
integer, dimension(:), allocatable :: NslipMax
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
reacting_max, & !< max # of reacting 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
real(pReal), dimension(sum(reacting_used),sum(acting_used)) :: buildInteraction
real(pREAL), dimension(sum(reacting_used),sum(acting_used)) :: buildInteraction
integer :: &
acting_family_index, acting_family, acting_system, &
@ -1906,16 +1906,16 @@ function buildCoordinateSystem(active,potential,system,lattice,cOverA)
integer, dimension(:), intent(in) :: &
active, & !< # of active systems per family
potential !< # of potential systems per family
real(pReal), dimension(:,:), intent(in) :: &
real(pREAL), dimension(:,:), intent(in) :: &
system
character(len=*), intent(in) :: &
lattice !< Bravais lattice (Pearson symbol)
real(pReal), intent(in) :: &
real(pREAL), intent(in) :: &
cOverA
real(pReal), dimension(3,3,sum(active)) :: &
real(pREAL), dimension(3,3,sum(active)) :: &
buildCoordinateSystem
real(pReal), dimension(3) :: &
real(pREAL), dimension(3) :: &
direction, normal
integer :: &
a, & !< index of active system
@ -1923,9 +1923,9 @@ function buildCoordinateSystem(active,potential,system,lattice,cOverA)
f, & !< index of my 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))
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))
a = 0
@ -1941,11 +1941,11 @@ function buildCoordinateSystem(active,potential,system,lattice,cOverA)
normal = system(4:6,p)
case ('hP')
direction = [ system(1,p)*1.5_pReal, &
(system(1,p)+2.0_pReal*system(2,p))*sqrt(0.75_pReal), &
direction = [ system(1,p)*1.5_pREAL, &
(system(1,p)+2.0_pREAL*system(2,p))*sqrt(0.75_pREAL), &
system(4,p)*cOverA ] ! direction [uvtw]->[3u/2 (u+2v)*sqrt(3)/2 w*(p/a)])
normal = [ system(5,p), &
(system(5,p)+2.0_pReal*system(6,p))/sqrt(3.0_pReal), &
(system(5,p)+2.0_pREAL*system(6,p))/sqrt(3.0_pREAL), &
system(8,p)/cOverA ] ! plane (hkil)->(h (h+2k)/sqrt(3) l/(p/a))
case default
@ -1974,10 +1974,10 @@ subroutine buildTransformationSystem(Q,S,Ntrans,cOverA,a_cF,a_cI)
integer, dimension(:), intent(in) :: &
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
S !< Eigendeformation tensor for phase transformation
real(pReal), optional, intent(in) :: &
real(pREAL), optional, intent(in) :: &
cOverA, & !< c/a for target hP lattice
a_cF, & !< lattice parameter a for cF target 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) :: &
R, & !< Pitsch rotation
B !< Rotation of cF to Bain coordinate system
real(pReal), dimension(3,3) :: &
real(pREAL), dimension(3,3) :: &
U, & !< Bain deformation
ss, sd
real(pReal), dimension(3) :: &
real(pREAL), dimension(3) :: &
x, y, z
integer :: &
i
real(pReal), dimension(3+3,CF_NTRANS), parameter :: &
real(pREAL), dimension(3+3,CF_NTRANS), parameter :: &
CFTOHP_SYSTEMTRANS = reshape(real( [&
-2, 1, 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, &
-1,-2,-1, -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([&
0.0, 1.0, 0.0, 10.26, & ! Pitsch OR (Ma & Hartmaier 2014, Table 3)
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, &
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 :: &
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 &
],shape(CFTOCI_BAINVARIANT))
real(pReal), dimension(4,cF_Ntrans), parameter :: &
real(pREAL), dimension(4,cF_Ntrans), parameter :: &
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, &
@ -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 &
],shape(CFTOCI_BAINROT)),pReal)
],shape(CFTOCI_BAINROT)),pREAL)
if (present(a_cI) .and. present(a_cF)) then
do i = 1,sum(Ntrans)
call R%fromAxisAngle(CFTOCI_SYSTEMTRANS(:,i),degrees=.true.,P=1)
call B%fromAxisAngle(CFTOCI_BAINROT(:,i), degrees=.true.,P=1)
x = real(CFTOCI_BAINVARIANT(1:3,i),pReal)
y = real(CFTOCI_BAINVARIANT(4:6,i),pReal)
z = real(CFTOCI_BAINVARIANT(7:9,i),pReal)
x = real(CFTOCI_BAINVARIANT(1:3,i),pREAL)
y = real(CFTOCI_BAINVARIANT(4:6,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())
S(1:3,1:3,i) = matmul(R%asMatrix(),U) - MATH_I3
end do
else if (present(cOverA)) then
ss = MATH_I3
sd = MATH_I3
ss(1,3) = sqrt(2.0_pReal)/4.0_pReal
sd(3,3) = cOverA/sqrt(8.0_pReal/3.0_pReal)
ss(1,3) = sqrt(2.0_pREAL)/4.0_pREAL
sd(3,3) = cOverA/sqrt(8.0_pREAL/3.0_pREAL)
do i = 1,sum(Ntrans)
x = 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) :: &
active, & !< # of active systems per family
potential !< # of potential systems per family
real(pReal), dimension(:,:), intent(in) :: &
real(pREAL), dimension(:,:), intent(in) :: &
system
character(len=:), dimension(:), allocatable :: labels
@ -2152,28 +2152,28 @@ end function getlabels
!--------------------------------------------------------------------------------------------------
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=*), optional, intent(in) :: lattice
real(pReal) :: nu
real(pREAL) :: nu
real(pReal) :: K, mu
real(pREAL) :: K, mu
logical :: error
real(pReal), dimension(6,6) :: S
real(pREAL), dimension(6,6) :: S
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
call math_invert(S,error,C)
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
error stop 'invalid assumption'
end if
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
@ -2185,36 +2185,36 @@ end function lattice_isotropic_nu
!--------------------------------------------------------------------------------------------------
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=*), optional, intent(in) :: lattice
real(pReal) :: mu
real(pREAL) :: mu
logical :: error
real(pReal), dimension(6,6) :: S
real(pREAL), dimension(6,6) :: S
if (IO_lc(assumption) == 'isostrain') then
select case(misc_optional(lattice,''))
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
mu = ( C(1,1)+C(2,2)+C(3,3) &
- C(1,2)-C(2,3)-C(1,3) &
+(C(4,4)+C(5,5)+C(6,6)) * 3.0_pReal &
) / 15.0_pReal
+(C(4,4)+C(5,5)+C(6,6)) * 3.0_pREAL &
) / 15.0_pREAL
end select
elseif (IO_lc(assumption) == 'isostress') then
select case(misc_optional(lattice,''))
case('cF','cI')
mu = 5.0_pReal &
/ (4.0_pReal/(C(1,1)-C(1,2)) + 3.0_pReal/C(4,4))
mu = 5.0_pREAL &
/ (4.0_pREAL/(C(1,1)-C(1,2)) + 3.0_pREAL/C(4,4))
case default
call math_invert(S,error,C)
if (error) error stop 'matrix inversion failed'
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)))
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)))
end select
else
error stop 'invalid assumption'
@ -2228,20 +2228,20 @@ end function lattice_isotropic_mu
!--------------------------------------------------------------------------------------------------
subroutine selfTest
real(pReal), dimension(:,:,:), allocatable :: CoSy
real(pReal), dimension(:,:), allocatable :: system
real(pREAL), dimension(:,:,:), allocatable :: CoSy
real(pREAL), dimension(:,:), allocatable :: system
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(2) :: r
real(pReal) :: lambda
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(2) :: r
real(pREAL) :: lambda
integer :: i
call random_number(r)
system = reshape([1.0_pReal+r(1),0.0_pReal,0.0_pReal, 0.0_pReal,1.0_pReal+r(2),0.0_pReal],[6,1])
CoSy = buildCoordinateSystem([1],[1],system,'cF',0.0_pReal)
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)
if (any(dNeq(CoSy(1:3,1:3,1),math_I3))) error stop 'buildCoordinateSystem'
do i = 1, 10
@ -2274,9 +2274,9 @@ subroutine selfTest
T_hP = lattice_symmetrize_33(T,'hP')
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_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_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_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_hP(1,1),T_hP(2,2)]))) error stop 'Symmetry33_11-22/hP'
@ -2285,52 +2285,52 @@ subroutine selfTest
end do
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(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_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,'isostress','cI'),1.0e-12_pReal)) error stop 'isotropic_mu/isostress/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'
lambda = C_cI(1,2)
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'
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'
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'
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'
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,'isostress','hP'),1.0e-12_pReal)) error stop 'isotropic_mu/isostress/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'
lambda = C_hP(1,2)
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'
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'
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'
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'
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,'isostress','tI'),1.0e-12_pReal)) error stop 'isotropic_mu/isostress/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'
lambda = C_tI(1,2)
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'
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'
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'
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'
call random_number(C)
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'
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'
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'
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'
end subroutine selfTest

26
src/material.f90
View File

@ -22,7 +22,7 @@ module material
end type tRotationContainer
type, public :: tTensorContainer
real(pReal), dimension(:,:,:), allocatable :: data
real(pREAL), dimension(:,:,:), allocatable :: data
end type tTensorContainer
@ -45,7 +45,7 @@ module material
material_ID_phase, & !< Number of the 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
public :: &
@ -97,9 +97,9 @@ subroutine parse()
counterHomogenization, &
ho_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 :: &
el, ip, &
ho, ph, &
@ -125,20 +125,20 @@ subroutine parse()
end do
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_V_e_0(materials%length))
allocate(ho_of(materials%length))
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
item => materials%first
do ma = 1, materials%length
material => item%node%asDict()
ho_of(ma) = homogenizations%index(material%get_asString('homogenization'))
ho_of(ma) = homogenizations%index(material%get_asStr('homogenization'))
constituents => material%get_list('constituents')
homogenization => homogenizations%get_dict(ho_of(ma))
@ -149,16 +149,16 @@ subroutine parse()
do co = 1, constituents%length
constituent => constituents%get_dict(co)
v_of(ma,co) = constituent%get_asFloat('v')
ph_of(ma,co) = phases%index(constituent%get_asString('phase'))
v_of(ma,co) = constituent%get_asReal('v')
ph_of(ma,co) = phases%index(constituent%get_asStr('phase'))
call material_O_0(ma)%data(co)%fromQuaternion(constituent%get_as1dFloat('O',requiredSize=4))
material_V_e_0(ma)%data(1:3,1:3,co) = constituent%get_as2dFloat('V_e',defaultVal=math_I3,requiredShape=[3,3])
call material_O_0(ma)%data(co)%fromQuaternion(constituent%get_as1dReal('O',requiredSize=4))
material_V_e_0(ma)%data(1:3,1:3,co) = constituent%get_as2dReal('V_e',defaultVal=math_I3,requiredShape=[3,3])
if (any(dNeq(material_V_e_0(ma)%data(1:3,1:3,co),transpose(material_V_e_0(ma)%data(1:3,1:3,co))))) &
call IO_error(147)
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
end do
@ -213,7 +213,7 @@ function getKeys(dict)
type(tDict), intent(in) :: dict
character(len=:), dimension(:), allocatable :: getKeys
character(len=pStringLen), dimension(:), allocatable :: temp
character(len=pSTRLEN), dimension(:), allocatable :: temp
integer :: i,l

2
src/materialpoint.f90
View File

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

448
src/math.f90
View File

@ -31,24 +31,24 @@ module math
config
#endif
real(pReal), parameter :: &
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
INDEG = 360.0_pReal/TAU, & !< conversion from radian to degree
INRAD = TAU/360.0_pReal !< conversion from degree to radian
real(pREAL), parameter :: &
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
INDEG = 360.0_pREAL/TAU, & !< conversion from radian to degree
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([&
1.0_pReal,0.0_pReal,0.0_pReal, &
0.0_pReal,1.0_pReal,0.0_pReal, &
0.0_pReal,0.0_pReal,1.0_pReal &
1.0_pREAL,0.0_pREAL,0.0_pREAL, &
0.0_pREAL,1.0_pREAL,0.0_pREAL, &
0.0_pREAL,0.0_pREAL,1.0_pREAL &
],shape(math_I3)) !< 3x3 Identity
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
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
real(pReal), dimension(*), parameter, private :: &
INVNRMMANDEL = 1.0_pReal/NRMMANDEL !< backward weighting for Mandel notation
real(pREAL), dimension(*), parameter, private :: &
INVNRMMANDEL = 1.0_pREAL/NRMMANDEL !< backward weighting for Mandel notation
integer, dimension (2,6), parameter, private :: &
MAPNYE = reshape([&
@ -94,7 +94,7 @@ contains
!--------------------------------------------------------------------------------------------------
subroutine math_init()
real(pReal), dimension(4) :: randTest
real(pREAL), dimension(4) :: randTest
integer :: randSize
integer, dimension(:), allocatable :: seed
type(tDict), pointer :: &
@ -201,9 +201,9 @@ end subroutine math_sort
!--------------------------------------------------------------------------------------------------
pure function math_expand(what,how)
real(pReal), dimension(:), intent(in) :: what
real(pREAL), dimension(:), intent(in) :: what
integer, dimension(:), intent(in) :: how
real(pReal), dimension(sum(how)) :: math_expand
real(pREAL), dimension(sum(how)) :: math_expand
integer :: i
@ -239,14 +239,14 @@ end function math_range
pure function math_eye(d)
integer, intent(in) :: d !< tensor dimension
real(pReal), dimension(d,d) :: math_eye
real(pREAL), dimension(d,d) :: math_eye
integer :: i
math_eye = 0.0_pReal
math_eye = 0.0_pREAL
do i=1,d
math_eye(i,i) = 1.0_pReal
math_eye(i,i) = 1.0_pREAL
end do
end function math_eye
@ -258,18 +258,18 @@ end function math_eye
!--------------------------------------------------------------------------------------------------
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
#ifndef __INTEL_COMPILER
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
#else
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
end function math_identity4th
@ -281,7 +281,7 @@ end function math_identity4th
! e_ijk = -1 if odd permutation of ijk
! 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
@ -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
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
math_LeviCivita = -1.0_pReal
math_LeviCivita = -1.0_pREAL
else
math_LeviCivita = 0.0_pReal
math_LeviCivita = 0.0_pREAL
end if
end function math_LeviCivita
@ -304,12 +304,12 @@ end function math_LeviCivita
! d_ij = 1 if i = j
! 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
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
@ -319,8 +319,8 @@ end function math_delta
!--------------------------------------------------------------------------------------------------
pure function math_cross(A,B)
real(pReal), dimension(3), intent(in) :: A,B
real(pReal), dimension(3) :: math_cross
real(pREAL), dimension(3), intent(in) :: A,B
real(pREAL), dimension(3) :: math_cross
math_cross = [ A(2)*B(3) -A(3)*B(2), &
@ -335,8 +335,8 @@ end function math_cross
!--------------------------------------------------------------------------------------------------
pure function math_outer(A,B)
real(pReal), dimension(:), intent(in) :: A,B
real(pReal), dimension(size(A,1),size(B,1)) :: math_outer
real(pREAL), dimension(:), intent(in) :: A,B
real(pREAL), dimension(size(A,1),size(B,1)) :: math_outer
integer :: i,j
@ -355,10 +355,10 @@ end function math_outer
!--------------------------------------------------------------------------------------------------
!> @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(size(A,1)), intent(in) :: B
real(pREAL), dimension(:), intent(in) :: A
real(pREAL), dimension(size(A,1)), intent(in) :: B
math_inner = sum(A*B)
@ -369,9 +369,9 @@ end function math_inner
!--------------------------------------------------------------------------------------------------
!> @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)
@ -384,9 +384,9 @@ end function math_tensordot
!--------------------------------------------------------------------------------------------------
pure function math_mul3333xx33(A,B)
real(pReal), dimension(3,3,3,3), intent(in) :: A
real(pReal), dimension(3,3), intent(in) :: B
real(pReal), dimension(3,3) :: math_mul3333xx33
real(pREAL), dimension(3,3,3,3), intent(in) :: A
real(pREAL), dimension(3,3), intent(in) :: B
real(pREAL), dimension(3,3) :: math_mul3333xx33
integer :: i,j
@ -407,9 +407,9 @@ end function math_mul3333xx33
!--------------------------------------------------------------------------------------------------
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) :: B
real(pReal), dimension(3,3,3,3) :: math_mul3333xx3333
real(pREAL), dimension(3,3,3,3), intent(in) :: A
real(pREAL), dimension(3,3,3,3), intent(in) :: B
real(pREAL), dimension(3,3,3,3) :: math_mul3333xx3333
integer :: i,j,k,l
@ -430,20 +430,20 @@ end function math_mul3333xx3333
!--------------------------------------------------------------------------------------------------
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
real(pReal), dimension(3,3) :: B, math_exp33
real(pREAL), dimension(3,3) :: B, math_exp33
real(pReal) :: invFac
real(pREAL) :: invFac
integer :: i
invFac = 1.0_pReal ! 0!
invFac = 1.0_pREAL ! 0!
B = math_I3
math_exp33 = math_I3 ! A^0 = I
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)
math_exp33 = math_exp33 + invFac*B ! exp = SUM (A^i)/(i!)
end do
@ -458,15 +458,15 @@ end function math_exp33
!--------------------------------------------------------------------------------------------------
pure function math_inv33(A)
real(pReal), dimension(3,3), intent(in) :: A
real(pReal), dimension(3,3) :: math_inv33
real(pREAL), dimension(3,3), intent(in) :: A
real(pREAL), dimension(3,3) :: math_inv33
real(pReal) :: DetA
real(pREAL) :: DetA
logical :: error
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
@ -478,12 +478,12 @@ end function math_inv33
!--------------------------------------------------------------------------------------------------
pure subroutine math_invert33(InvA,DetA,error, A)
real(pReal), dimension(3,3), intent(out) :: InvA
real(pReal), intent(out), optional :: DetA
real(pREAL), dimension(3,3), intent(out) :: InvA
real(pREAL), intent(out), optional :: DetA
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)
@ -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)
if (dEq0(Det)) then
InvA = 0.0_pReal
if (present(DetA)) DetA = 0.0_pReal
InvA = 0.0_pREAL
if (present(DetA)) DetA = 0.0_pREAL
error = .true.
else
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)
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
real(pReal), dimension(6,6) :: temp66
real(pReal), dimension(6*6) :: work
real(pREAL), dimension(6,6) :: temp66
real(pREAL), dimension(6*6) :: work
integer :: ierr_i, ierr_f
@ -545,12 +545,12 @@ end function math_invSym3333
!--------------------------------------------------------------------------------------------------
pure subroutine math_invert(InvA, error, A)
real(pReal), dimension(:,:), intent(in) :: A
real(pReal), dimension(size(A,1),size(A,1)), intent(out) :: invA
real(pREAL), dimension(:,:), intent(in) :: A
real(pREAL), dimension(size(A,1),size(A,1)), intent(out) :: invA
logical, intent(out) :: error
integer, dimension(size(A,1)) :: ipiv
real(pReal), dimension(size(A,1)**2) :: work
real(pREAL), dimension(size(A,1)**2) :: work
integer :: ierr
@ -568,11 +568,11 @@ end subroutine math_invert
!--------------------------------------------------------------------------------------------------
pure function math_symmetric33(m)
real(pReal), dimension(3,3) :: math_symmetric33
real(pReal), dimension(3,3), intent(in) :: m
real(pREAL), dimension(3,3) :: math_symmetric33
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
@ -582,8 +582,8 @@ end function math_symmetric33
!--------------------------------------------------------------------------------------------------
pure function math_skew33(m)
real(pReal), dimension(3,3) :: math_skew33
real(pReal), dimension(3,3), intent(in) :: m
real(pREAL), dimension(3,3) :: math_skew33
real(pREAL), dimension(3,3), intent(in) :: m
math_skew33 = m - math_symmetric33(m)
@ -596,11 +596,11 @@ end function math_skew33
!--------------------------------------------------------------------------------------------------
pure function math_spherical33(m)
real(pReal), dimension(3,3) :: math_spherical33
real(pReal), dimension(3,3), intent(in) :: m
real(pREAL), dimension(3,3) :: math_spherical33
real(pREAL), dimension(3,3), intent(in) :: m
math_spherical33 = math_I3 * math_trace33(m)/3.0_pReal
math_spherical33 = math_I3 * math_trace33(m)/3.0_pREAL
end function math_spherical33
@ -610,8 +610,8 @@ end function math_spherical33
!--------------------------------------------------------------------------------------------------
pure function math_deviatoric33(m)
real(pReal), dimension(3,3) :: math_deviatoric33
real(pReal), dimension(3,3), intent(in) :: m
real(pREAL), dimension(3,3) :: math_deviatoric33
real(pREAL), dimension(3,3), intent(in) :: m
math_deviatoric33 = m - math_spherical33(m)
@ -622,9 +622,9 @@ end function math_deviatoric33
!--------------------------------------------------------------------------------------------------
!> @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)
@ -635,9 +635,9 @@ end function math_trace33
!--------------------------------------------------------------------------------------------------
!> @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)) &
@ -650,13 +650,13 @@ end function math_det33
!--------------------------------------------------------------------------------------------------
!> @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) &
+ 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
@ -666,8 +666,8 @@ end function math_detSym33
!--------------------------------------------------------------------------------------------------
pure function math_33to9(m33)
real(pReal), dimension(9) :: math_33to9
real(pReal), dimension(3,3), intent(in) :: m33
real(pREAL), dimension(9) :: math_33to9
real(pREAL), dimension(3,3), intent(in) :: m33
integer :: i
@ -682,8 +682,8 @@ end function math_33to9
!--------------------------------------------------------------------------------------------------
pure function math_9to33(v9)
real(pReal), dimension(3,3) :: math_9to33
real(pReal), dimension(9), intent(in) :: v9
real(pREAL), dimension(3,3) :: math_9to33
real(pREAL), dimension(9), intent(in) :: v9
integer :: i
@ -703,14 +703,14 @@ end function math_9to33
!--------------------------------------------------------------------------------------------------
pure function math_sym33to6(m33,weighted)
real(pReal), dimension(6) :: math_sym33to6
real(pReal), dimension(3,3), intent(in) :: m33 !< symmetric 3x3 matrix (no internal check)
real(pREAL), dimension(6) :: math_sym33to6
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)
real(pReal), dimension(6) :: w
real(pREAL), dimension(6) :: w
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)]
@ -725,15 +725,15 @@ end function math_sym33to6
!--------------------------------------------------------------------------------------------------
pure function math_6toSym33(v6,weighted)
real(pReal), dimension(3,3) :: math_6toSym33
real(pReal), dimension(6), intent(in) :: v6 !< 6 vector
real(pREAL), dimension(3,3) :: math_6toSym33
real(pREAL), dimension(6), intent(in) :: v6 !< 6 vector
logical, optional, intent(in) :: weighted !< weight according to Mandel (.true. by default)
real(pReal), dimension(6) :: w
real(pREAL), dimension(6) :: w
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
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)
real(pReal), dimension(9,9) :: math_3333to99
real(pReal), dimension(3,3,3,3), intent(in) :: m3333
real(pREAL), dimension(9,9) :: math_3333to99
real(pREAL), dimension(3,3,3,3), intent(in) :: m3333
integer :: i,j
@ -770,8 +770,8 @@ end function math_3333to99
!--------------------------------------------------------------------------------------------------
pure function math_99to3333(m99)
real(pReal), dimension(3,3,3,3) :: math_99to3333
real(pReal), dimension(9,9), intent(in) :: m99
real(pREAL), dimension(3,3,3,3) :: math_99to3333
real(pREAL), dimension(9,9), intent(in) :: m99
integer :: i,j
@ -795,15 +795,15 @@ end function math_99to3333
!--------------------------------------------------------------------------------------------------
pure function math_sym3333to66(m3333,weighted)
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(6,6) :: math_sym3333to66
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)
real(pReal), dimension(6) :: w
real(pREAL), dimension(6) :: w
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
do concurrent(i=1:6, j=1:6)
@ -824,15 +824,15 @@ end function math_sym3333to66
!--------------------------------------------------------------------------------------------------
pure function math_66toSym3333(m66,weighted)
real(pReal), dimension(3,3,3,3) :: math_66toSym3333
real(pReal), dimension(6,6), intent(in) :: m66 !< 6x6 matrix
real(pREAL), dimension(3,3,3,3) :: math_66toSym3333
real(pREAL), dimension(6,6), intent(in) :: m66 !< 6x6 matrix
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
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
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)
real(pReal), dimension(3,3) :: sigma
real(pReal), dimension(6), intent(in) :: sigma_tilde
real(pREAL), dimension(3,3) :: sigma
real(pREAL), dimension(6), intent(in) :: sigma_tilde
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)
real(pReal), dimension(3,3) :: epsilon
real(pReal), dimension(6), intent(in) :: epsilon_tilde
real(pREAL), dimension(3,3) :: epsilon
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), &
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])
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(5), 0.5_pREAL*epsilon_tilde(4), epsilon_tilde(3)],[3,3])
end function math_Voigt6to33_strain
@ -881,8 +881,8 @@ end function math_Voigt6to33_strain
!--------------------------------------------------------------------------------------------------
pure function math_33toVoigt6_stress(sigma) result(sigma_tilde)
real(pReal), dimension(6) :: sigma_tilde
real(pReal), dimension(3,3), intent(in) :: sigma
real(pREAL), dimension(6) :: sigma_tilde
real(pREAL), dimension(3,3), intent(in) :: sigma
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)
real(pReal), dimension(6) :: epsilon_tilde
real(pReal), dimension(3,3), intent(in) :: epsilon
real(pREAL), dimension(6) :: epsilon_tilde
real(pREAL), dimension(3,3), intent(in) :: epsilon
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
@ -912,8 +912,8 @@ end function math_33toVoigt6_strain
!--------------------------------------------------------------------------------------------------
pure function math_Voigt66to3333_stiffness(C_tilde) result(C)
real(pReal), dimension(3,3,3,3) :: C
real(pReal), dimension(6,6), intent(in) :: C_tilde
real(pREAL), dimension(3,3,3,3) :: C
real(pREAL), dimension(6,6), intent(in) :: C_tilde
integer :: i,j
@ -933,8 +933,8 @@ end function math_Voigt66to3333_stiffness
!--------------------------------------------------------------------------------------------------
pure function math_3333toVoigt66_stiffness(C) result(C_tilde)
real(pReal), dimension(6,6) :: C_tilde
real(pReal), dimension(3,3,3,3), intent(in) :: C
real(pREAL), dimension(6,6) :: C_tilde
real(pREAL), dimension(3,3,3,3), intent(in) :: C
integer :: i,j
@ -957,15 +957,15 @@ end function math_3333toVoigt66_stiffness
!--------------------------------------------------------------------------------------------------
impure elemental subroutine math_normal(x,mu,sigma)
real(pReal), intent(out) :: x
real(pReal), intent(in), optional :: mu, sigma
real(pREAL), intent(out) :: x
real(pREAL), intent(in), optional :: mu, sigma
real(pReal), dimension(2) :: rnd
real(pREAL), dimension(2) :: rnd
call random_number(rnd)
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)))
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)))
end subroutine math_normal
@ -975,13 +975,13 @@ end subroutine math_normal
!--------------------------------------------------------------------------------------------------
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(size(m,1)), intent(out) :: w !< eigenvalues
real(pReal), dimension(size(m,1),size(m,1)), intent(out) :: v !< eigenvectors
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),size(m,1)), intent(out) :: v !< eigenvectors
logical, intent(out) :: error
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
@ -1000,11 +1000,11 @@ end subroutine math_eigh
!--------------------------------------------------------------------------------------------------
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), intent(out) :: w !< eigenvalues
real(pReal), dimension(3,3),intent(out) :: v !< eigenvectors
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,3),intent(out) :: v !< eigenvectors
real(pReal) :: T, U, norm, threshold
real(pREAL) :: T, U, norm, threshold
logical :: error
@ -1016,7 +1016,7 @@ pure subroutine math_eigh33(w,v,m)
T = maxval(abs(w))
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
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)
real(pReal), dimension(3,3), intent(in) :: &
real(pREAL), dimension(3,3), intent(in) :: &
F ! deformation gradient
real(pReal), dimension(3,3) :: &
real(pREAL), dimension(3,3) :: &
C, & ! right Cauchy-Green tensor
R ! rotational part
real(pReal), dimension(3) :: &
real(pREAL), dimension(3) :: &
lambda, & ! principal stretches
I_C, & ! invariants of C
I_U ! invariants of U
real(pReal), dimension(2) :: &
real(pREAL), dimension(2) :: &
I_F ! first two invariants of F
real(pReal) :: x,Phi
real(pREAL) :: x,Phi
C = matmul(transpose(F),F)
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
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))) &
*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)
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))) &
*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)
else
lambda = sqrt(I_C(1)/3.0_pReal)
lambda = sqrt(I_C(1)/3.0_pREAL)
end if
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) * transpose(matmul(F,F)) &
- 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
@ -1105,17 +1105,17 @@ end function math_rotationalPart
!--------------------------------------------------------------------------------------------------
pure function math_eigvalsh(m)
real(pReal), dimension(:,:), intent(in) :: m !< symmetric matrix to compute eigenvalues of
real(pReal), dimension(size(m,1)) :: math_eigvalsh
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),size(m,1)) :: m_
real(pREAL), dimension(size(m,1),size(m,1)) :: m_
integer :: ierr
real(pReal), dimension(size(m,1)**2) :: work
real(pREAL), dimension(size(m,1)**2) :: work
m_ = m ! m_ will be destroyed
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
@ -1129,30 +1129,30 @@ end function math_eigvalsh
!--------------------------------------------------------------------------------------------------
pure function math_eigvalsh33(m)
real(pReal), intent(in), dimension(3,3) :: m !< 3x3 symmetric matrix to compute eigenvalues of
real(pReal), dimension(3) :: math_eigvalsh33,I
real(pReal) :: P, Q, rho, phi
real(pReal), parameter :: TOL=1.e-14_pReal
real(pREAL), intent(in), dimension(3,3) :: m !< 3x3 symmetric matrix to compute eigenvalues of
real(pREAL), dimension(3) :: math_eigvalsh33,I
real(pREAL) :: P, Q, rho, phi
real(pREAL), parameter :: TOL=1.e-14_pREAL
I = math_invariantsSym33(m) ! invariants are coefficients in characteristic polynomial apart for the sign of c0 and c2 in http://arxiv.org/abs/physics/0610206
P = I(2)-I(1)**2/3.0_pReal ! different from http://arxiv.org/abs/physics/0610206 (this formulation was in DAMASK)
Q = product(I(1:2))/3.0_pReal &
- 2.0_pReal/27.0_pReal*I(1)**3 &
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 &
- 2.0_pREAL/27.0_pREAL*I(1)**3 &
- I(3) ! different from http://arxiv.org/abs/physics/0610206 (this formulation was in DAMASK)
if (all(abs([P,Q]) < TOL)) then
math_eigvalsh33 = math_eigvalsh(m)
else
rho=sqrt(-3.0_pReal*P**3)/9.0_pReal
phi=acos(math_clip(-Q/rho*0.5_pReal,-1.0_pReal,1.0_pReal))
math_eigvalsh33 = 2.0_pReal*rho**(1.0_pReal/3.0_pReal)* &
[cos( phi /3.0_pReal), &
cos((phi+TAU)/3.0_pReal), &
cos((phi+2.0_pReal*TAU)/3.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))
math_eigvalsh33 = 2.0_pREAL*rho**(1.0_pREAL/3.0_pREAL)* &
[cos( phi /3.0_pREAL), &
cos((phi+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 function math_eigvalsh33
@ -1163,8 +1163,8 @@ end function math_eigvalsh33
!--------------------------------------------------------------------------------------------------
pure function math_invariantsSym33(m)
real(pReal), dimension(3,3), intent(in) :: m
real(pReal), dimension(3) :: math_invariantsSym33
real(pREAL), dimension(3,3), intent(in) :: m
real(pREAL), dimension(3) :: math_invariantsSym33
math_invariantsSym33(1) = math_trace33(m)
@ -1225,17 +1225,17 @@ end function math_multinomial
!--------------------------------------------------------------------------------------------------
!> @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,3) :: m
real(pREAL), dimension (3), intent(in) :: v1,v2,v3,v4
real(pREAL), dimension (3,3) :: m
m(1:3,1) = v1-v2
m(1:3,2) = v1-v3
m(1:3,3) = v1-v4
math_volTetrahedron = abs(math_det33(m))/6.0_pReal
math_volTetrahedron = abs(math_det33(m))/6.0_pREAL
end function math_volTetrahedron
@ -1243,12 +1243,12 @@ end function math_volTetrahedron
!--------------------------------------------------------------------------------------------------
!> @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
@ -1256,10 +1256,10 @@ end function math_areaTriangle
!--------------------------------------------------------------------------------------------------
!> @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), optional :: left, right
real(pREAL), intent(in) :: a
real(pREAL), intent(in), optional :: left, right
math_clip = a
@ -1285,30 +1285,30 @@ subroutine selfTest()
integer, dimension(5) :: range_out_ = [1,2,3,4,5]
integer, dimension(3) :: ijk
real(pReal) :: det
real(pReal), dimension(3) :: v3_1,v3_2,v3_3,v3_4
real(pReal), dimension(6) :: v6
real(pReal), dimension(9) :: v9
real(pReal), dimension(3,3) :: t33,t33_2
real(pReal), dimension(6,6) :: t66
real(pReal), dimension(9,9) :: t99,t99_2
real(pReal), dimension(:,:), &
real(pREAL) :: det
real(pREAL), dimension(3) :: v3_1,v3_2,v3_3,v3_4
real(pREAL), dimension(6) :: v6
real(pREAL), dimension(9) :: v9
real(pREAL), dimension(3,3) :: t33,t33_2
real(pREAL), dimension(6,6) :: t66
real(pREAL), dimension(9,9) :: t99,t99_2
real(pREAL), dimension(:,:), &
allocatable :: txx,txx_2
real(pReal) :: r
real(pREAL) :: r
integer :: d
logical :: e
if (any(abs([1.0_pReal,2.0_pReal,2.0_pReal,3.0_pReal,3.0_pReal,3.0_pReal] - &
math_expand([1.0_pReal,2.0_pReal,3.0_pReal],[1,2,3,0])) > tol_math_check)) &
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)) &
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] - &
math_expand([1.0_pReal,2.0_pReal,3.0_pReal],[1,2])) > tol_math_check)) &
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)) &
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] - &
math_expand([1.0_pReal,2.0_pReal],[1,2,3])) > tol_math_check)) &
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)) &
error stop 'math_expand [1,2] by [1,2,3] => [1,2,2,1,1,1]'
call math_sort(sort_in_,1,3,2)
@ -1320,7 +1320,7 @@ subroutine selfTest()
if (any(dNeq(math_exp33(math_I3,0),math_I3))) &
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)'
call random_number(v9)
@ -1336,10 +1336,10 @@ subroutine selfTest()
error stop 'math_sym33to6/math_6toSym33'
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'
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'
call random_number(v6)
@ -1351,12 +1351,12 @@ subroutine selfTest()
call random_number(v3_3)
call random_number(v3_4)
if (dNeq(abs(dot_product(math_cross(v3_1-v3_4,v3_2-v3_4),v3_3-v3_4))/6.0_pReal, &
math_volTetrahedron(v3_1,v3_2,v3_3,v3_4),tol=1.0e-12_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)) &
error stop 'math_volTetrahedron'
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'
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)))) &
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)
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'
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'
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)'
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'
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)
end do
t33_2 = math_rotationalPart(transpose(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)'
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)'
call random_number(r)
d = int(r*5.0_pReal) + 1
d = int(r*5.0_pREAL) + 1
txx = math_eye(d)
allocate(txx_2(d,d))
call math_invert(txx_2,e,txx)
@ -1400,10 +1400,10 @@ subroutine selfTest()
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
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)'
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'
if (math_factorial(10) /= 3628800) &
@ -1415,35 +1415,35 @@ subroutine selfTest()
if (math_multinomial([1,2,3,4]) /= 12600) &
error stop 'math_multinomial'
ijk = cshift([1,2,3],int(r*1.0e2_pReal))
if (dNeq(math_LeviCivita(ijk(1),ijk(2),ijk(3)),+1.0_pReal)) &
ijk = cshift([1,2,3],int(r*1.0e2_pREAL))
if (dNeq(math_LeviCivita(ijk(1),ijk(2),ijk(3)),+1.0_pREAL)) &
error stop 'math_LeviCivita(even)'
ijk = cshift([3,2,1],int(r*2.0e2_pReal))
if (dNeq(math_LeviCivita(ijk(1),ijk(2),ijk(3)),-1.0_pReal)) &
ijk = cshift([3,2,1],int(r*2.0e2_pREAL))
if (dNeq(math_LeviCivita(ijk(1),ijk(2),ijk(3)),-1.0_pREAL)) &
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)))) &
error stop 'math_LeviCivita'
normal_distribution: block
integer, parameter :: N = 1000000
real(pReal), dimension(:), allocatable :: r
real(pReal) :: mu, sigma
real(pREAL), dimension(:), allocatable :: r
real(pREAL) :: mu, sigma
allocate(r(N))
call random_number(mu)
call random_number(sigma)
sigma = 1.0_pReal + sigma*5.0_pReal
mu = (mu-0.5_pReal)*10_pReal
sigma = 1.0_pREAL + sigma*5.0_pREAL
mu = (mu-0.5_pREAL)*10_pREAL
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)'
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) &
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) &
error stop 'math_normal(sigma)'
end block normal_distribution

42
src/mesh/DAMASK_mesh.f90
View File

@ -23,7 +23,7 @@ program DAMASK_mesh
implicit none(type,external)
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
outputfrequency = 1 !< frequency of result writes
logical :: followFormerTrajectory = .true. !< follow trajectory of former loadcase
@ -43,12 +43,12 @@ program DAMASK_mesh
! loop variables, convergence etc.
integer, parameter :: &
subStepFactor = 2 !< for each substep, divide the last time increment by 2.0
real(pReal) :: &
time = 0.0_pReal, & !< elapsed time
time0 = 0.0_pReal, & !< begin of interval
timeinc = 0.0_pReal, & !< current time interval
timeIncOld = 0.0_pReal, & !< previous time interval
remainingLoadCaseTime = 0.0_pReal !< remaining time of current load case
real(pREAL) :: &
time = 0.0_pREAL, & !< elapsed time
time0 = 0.0_pREAL, & !< begin of interval
timeinc = 0.0_pREAL, & !< current time interval
timeIncOld = 0.0_pREAL, & !< previous time interval
remainingLoadCaseTime = 0.0_pREAL !< remaining time of current load case
logical :: &
guess, & !< guess along former trajectory
stagIterate
@ -67,8 +67,8 @@ program DAMASK_mesh
component
type(tDict), pointer :: &
num_mesh
character(len=pStringLen), dimension(:), allocatable :: fileContent
character(len=pStringLen) :: &
character(len=pSTRLEN), dimension(:), allocatable :: fileContent
character(len=pSTRLEN) :: &
incInfo, &
loadcase_string
integer :: &
@ -109,9 +109,9 @@ program DAMASK_mesh
line = fileContent(l)
if (IO_isBlank(line)) cycle ! skip empty lines
chunkPos = IO_stringPos(line)
chunkPos = IO_strPos(line)
do i = 1, chunkPos(1) ! reading compulsory parameters for loadcase
select case (IO_stringValue(line,chunkPos,i))
select case (IO_strValue(line,chunkPos,i))
case('$Loadcase')
N_def = N_def + 1
end select
@ -140,7 +140,7 @@ program DAMASK_mesh
end select
end do
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.)
end do
end do
@ -151,9 +151,9 @@ program DAMASK_mesh
line = fileContent(l)
if (IO_isBlank(line)) cycle ! skip empty lines
chunkPos = IO_stringPos(line)
chunkPos = IO_strPos(line)
do i = 1, chunkPos(1)
select case (IO_stringValue(line,chunkPos,i))
select case (IO_strValue(line,chunkPos,i))
!--------------------------------------------------------------------------------------------------
! loadcase information
case('$Loadcase')
@ -166,7 +166,7 @@ program DAMASK_mesh
end do
if (currentFaceSet < 0) call IO_error(error_ID = 837, ext_msg = 'invalid BC')
case('t')
loadCases(currentLoadCase)%time = IO_floatValue(line,chunkPos,i+1)
loadCases(currentLoadCase)%time = IO_realValue(line,chunkPos,i+1)
case('N')
loadCases(currentLoadCase)%incs = IO_intValue(line,chunkPos,i+1)
case('f_out')
@ -177,7 +177,7 @@ program DAMASK_mesh
!--------------------------------------------------------------------------------------------------
! boundary condition information
case('X','Y','Z')
select case(IO_stringValue(line,chunkPos,i))
select case(IO_strValue(line,chunkPos,i))
case('X')
ID = COMPONENT_MECH_X_ID
case('Y')
@ -191,7 +191,7 @@ program DAMASK_mesh
loadCases(currentLoadCase)%fieldBC(1)%componentBC(component)%Mask (currentFaceSet) = &
.true.
loadCases(currentLoadCase)%fieldBC(1)%componentBC(component)%Value(currentFaceSet) = &
IO_floatValue(line,chunkPos,i+1)
IO_realValue(line,chunkPos,i+1)
end if
end do
end select
@ -240,7 +240,7 @@ program DAMASK_mesh
print'(/,1x,a)', '... writing initial configuration to file .................................'
flush(IO_STDOUT)
call materialpoint_result(0,0.0_pReal)
call materialpoint_result(0,0.0_pREAL)
loadCaseLooping: do currentLoadCase = 1, size(loadCases)
time0 = time ! load case start time
@ -252,8 +252,8 @@ program DAMASK_mesh
!--------------------------------------------------------------------------------------------------
! forwarding time
timeIncOld = timeinc ! last timeinc that brought former inc to an end
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 = loadCases(currentLoadCase)%time/real(loadCases(currentLoadCase)%incs,pREAL)
timeinc = timeinc * real(subStepFactor,pREAL)**real(-cutBackLevel,pREAL) ! depending on cut back level, decrease time step
stepFraction = 0 ! fraction scaled by stepFactor**cutLevel
subStepLooping: do while (stepFraction < subStepFactor**cutBackLevel)
@ -298,7 +298,7 @@ program DAMASK_mesh
stepFraction = (stepFraction - 1) * subStepFactor ! adjust to new denominator
cutBackLevel = cutBackLevel + 1
time = time - timeinc ! rewind time
timeinc = timeinc/2.0_pReal
timeinc = timeinc/2.0_pREAL
print'(/,1x,a)', 'cutting back'
else ! default behavior, exit if spectral solver does not converge
if (worldrank == 0) close(statUnit)

286
src/mesh/FEM_quadrature.f90
View File

@ -10,23 +10,23 @@ module FEM_quadrature
integer, parameter :: &
maxOrder = 5 !< maximum integration order
real(pReal), dimension(2,3), parameter :: &
triangle = reshape([-1.0_pReal, -1.0_pReal, &
1.0_pReal, -1.0_pReal, &
-1.0_pReal, 1.0_pReal], shape=[2,3])
real(pReal), dimension(3,4), parameter :: &
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], shape=[3,4])
real(pREAL), dimension(2,3), parameter :: &
triangle = reshape([-1.0_pREAL, -1.0_pREAL, &
1.0_pREAL, -1.0_pREAL, &
-1.0_pREAL, 1.0_pREAL], shape=[2,3])
real(pREAL), dimension(3,4), parameter :: &
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], shape=[3,4])
type :: group_float !< variable length datatype
real(pReal), dimension(:), allocatable :: p
end type group_float
type :: group_real !< variable length datatype
real(pREAL), dimension(:), allocatable :: p
end type group_real
integer, dimension(2:3,maxOrder), public, protected :: &
FEM_nQuadrature !< number of quadrature points for spatial dimension(2-3) and interpolation order (1-maxOrder)
type(group_float), dimension(2:3,maxOrder), public, protected :: &
type(group_real), dimension(2:3,maxOrder), public, protected :: &
FEM_quadrature_weights, & !< quadrature weights for each quadrature rule
FEM_quadrature_points !< quadrature point coordinates (in simplical system) for each quadrature rule
@ -51,132 +51,132 @@ subroutine FEM_quadrature_init()
FEM_nQuadrature(2,1) = 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
FEM_nQuadrature(2,2) = 3
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
FEM_nQuadrature(2,3) = 6
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(4:6) = 1.0995174365532187e-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_points (2,3)%p = [ &
permutationStar21([4.4594849091596489e-1_pReal]), &
permutationStar21([9.157621350977074e-2_pReal]) ]
permutationStar21([4.4594849091596489e-1_pREAL]), &
permutationStar21([9.157621350977074e-2_pREAL]) ]
!--------------------------------------------------------------------------------------------------
! 2D quartic
FEM_nQuadrature(2,4) = 12
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(4:6) = 5.0844906370206817e-2_pReal
FEM_quadrature_weights(2,4)%p(7:12) = 8.285107561837358e-2_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(7:12) = 8.285107561837358e-2_pREAL
FEM_quadrature_points (2,4)%p = [ &
permutationStar21([2.4928674517091042e-1_pReal]), &
permutationStar21([6.308901449150223e-2_pReal]), &
permutationStar111([3.1035245103378440e-1_pReal, 5.3145049844816947e-2_pReal]) ]
permutationStar21([2.4928674517091042e-1_pREAL]), &
permutationStar21([6.308901449150223e-2_pREAL]), &
permutationStar111([3.1035245103378440e-1_pREAL, 5.3145049844816947e-2_pREAL]) ]
!--------------------------------------------------------------------------------------------------
! 2D quintic
FEM_nQuadrature(2,5) = 16
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(2:4) = 9.509163426728463e-2_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(11:16) = 2.7230314174434994e-2_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(5:7) = 1.0321737053471825e-1_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_points (2,5)%p = [ &
permutationStar3([1._pReal/3._pReal]), &
permutationStar21([4.5929258829272316e-1_pReal]), &
permutationStar21([1.705693077517602e-1_pReal]), &
permutationStar21([5.0547228317030975e-2_pReal]), &
permutationStar111([2.631128296346381e-1_pReal, 8.3947774099576053e-2_pReal]) ]
permutationStar3([1._pREAL/3._pREAL]), &
permutationStar21([4.5929258829272316e-1_pREAL]), &
permutationStar21([1.705693077517602e-1_pREAL]), &
permutationStar21([5.0547228317030975e-2_pREAL]), &
permutationStar111([2.631128296346381e-1_pREAL, 8.3947774099576053e-2_pREAL]) ]
!--------------------------------------------------------------------------------------------------
! 3D linear
FEM_nQuadrature(3,1) = 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
FEM_nQuadrature(3,2) = 4
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
FEM_nQuadrature(3,3) = 14
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(5:8) = 1.1268792571801585e-1_pReal
FEM_quadrature_weights(3,3)%p(9:14) = 4.2546020777081467e-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(9:14) = 4.2546020777081467e-2_pREAL
FEM_quadrature_points (3,3)%p = [ &
permutationStar31([9.273525031089123e-2_pReal]), &
permutationStar31([3.108859192633006e-1_pReal]), &
permutationStar22([4.5503704125649649e-2_pReal]) ]
permutationStar31([9.273525031089123e-2_pREAL]), &
permutationStar31([3.108859192633006e-1_pREAL]), &
permutationStar22([4.5503704125649649e-2_pREAL]) ]
!--------------------------------------------------------------------------------------------------
! 3D quartic (lower precision/unknown source)
FEM_nQuadrature(3,4) = 35
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(5:16) = 0.0143395670177665_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(35) = 0.0931745731195340_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(17:22) = 0.0250305395686746_pREAL
FEM_quadrature_weights(3,4)%p(23:34) = 0.0479839333057554_pREAL
FEM_quadrature_weights(3,4)%p(35) = 0.0931745731195340_pREAL
FEM_quadrature_points (3,4)%p = [ &
permutationStar31([0.0267367755543735_pReal]), &
permutationStar211([0.0391022406356488_pReal, 0.7477598884818090_pReal]), &
permutationStar22([0.4547545999844830_pReal]), &
permutationStar211([0.2232010379623150_pReal, 0.0504792790607720_pReal]), &
permutationStar4([0.25_pReal]) ]
permutationStar31([0.0267367755543735_pREAL]), &
permutationStar211([0.0391022406356488_pREAL, 0.7477598884818090_pREAL]), &
permutationStar22([0.4547545999844830_pREAL]), &
permutationStar211([0.2232010379623150_pREAL, 0.0504792790607720_pREAL]), &
permutationStar4([0.25_pREAL]) ]
!--------------------------------------------------------------------------------------------------
! 3D quintic (lower precision/unknown source)
FEM_nQuadrature(3,5) = 56
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(5:16) = 0.0096016645399480_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(41:52) = 0.0293520118375230_pReal
FEM_quadrature_weights(3,5)%p(53:56) = 0.0366291366405108_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(17:28) = 0.0164493976798232_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(53:56) = 0.0366291366405108_pREAL
FEM_quadrature_points (3,5)%p = [ &
permutationStar31([0.0149520651530592_pReal]), &
permutationStar211([0.0340960211962615_pReal, 0.1518319491659370_pReal]), &
permutationStar211([0.0462051504150017_pReal, 0.3549340560639790_pReal]), &
permutationStar211([0.2281904610687610_pReal, 0.0055147549744775_pReal]), &
permutationStar211([0.3523052600879940_pReal, 0.0992057202494530_pReal]), &
permutationStar31([0.1344783347929940_pReal]) ]
permutationStar31([0.0149520651530592_pREAL]), &
permutationStar211([0.0340960211962615_pREAL, 0.1518319491659370_pREAL]), &
permutationStar211([0.0462051504150017_pREAL, 0.3549340560639790_pREAL]), &
permutationStar211([0.2281904610687610_pREAL, 0.0055147549744775_pREAL]), &
permutationStar211([0.3523052600879940_pREAL, 0.0992057202494530_pREAL]), &
permutationStar31([0.1344783347929940_pREAL]) ]
call selfTest()
@ -188,8 +188,8 @@ end subroutine FEM_quadrature_init
!--------------------------------------------------------------------------------------------------
pure function permutationStar3(point) result(qPt)
real(pReal), dimension(2) :: qPt
real(pReal), dimension(1), intent(in) :: point
real(pREAL), dimension(2) :: qPt
real(pREAL), dimension(1), intent(in) :: point
qPt = pack(matmul(triangle,reshape([ &
@ -203,14 +203,14 @@ end function permutationStar3
!--------------------------------------------------------------------------------------------------
pure function permutationStar21(point) result(qPt)
real(pReal), dimension(6) :: qPt
real(pReal), dimension(1), intent(in) :: point
real(pREAL), dimension(6) :: qPt
real(pREAL), dimension(1), intent(in) :: point
qPt = pack(matmul(triangle,reshape([ &
point(1), point(1), 1.0_pReal - 2.0_pReal*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.)
point(1), point(1), 1.0_pREAL - 2.0_pREAL*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.)
end function permutationStar21
@ -220,17 +220,17 @@ end function permutationStar21
!--------------------------------------------------------------------------------------------------
pure function permutationStar111(point) result(qPt)
real(pReal), dimension(12) :: qPt
real(pReal), dimension(2), intent(in) :: point
real(pREAL), dimension(12) :: qPt
real(pREAL), dimension(2), intent(in) :: point
qPt = pack(matmul(triangle,reshape([ &
point(1), point(2), 1.0_pReal - point(1) - 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), 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(1), point(2)],[3,6])),.true.)
point(1), point(2), 1.0_pREAL - point(1) - 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), 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(1), point(2)],[3,6])),.true.)
end function permutationStar111
@ -240,8 +240,8 @@ end function permutationStar111
!--------------------------------------------------------------------------------------------------
pure function permutationStar4(point) result(qPt)
real(pReal), dimension(3) :: qPt
real(pReal), dimension(1), intent(in) :: point
real(pREAL), dimension(3) :: qPt
real(pREAL), dimension(1), intent(in) :: point
qPt = pack(matmul(tetrahedron,reshape([ &
@ -255,15 +255,15 @@ end function permutationStar4
!--------------------------------------------------------------------------------------------------
pure function permutationStar31(point) result(qPt)
real(pReal), dimension(12) :: qPt
real(pReal), dimension(1), intent(in) :: point
real(pREAL), dimension(12) :: qPt
real(pREAL), dimension(1), intent(in) :: point
qPt = pack(matmul(tetrahedron,reshape([ &
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), 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.)
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), 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.)
end function permutationStar31
@ -273,17 +273,17 @@ end function permutationStar31
!--------------------------------------------------------------------------------------------------
function permutationStar22(point) result(qPt)
real(pReal), dimension(18) :: qPt
real(pReal), dimension(1), intent(in) :: point
real(pREAL), dimension(18) :: qPt
real(pREAL), dimension(1), intent(in) :: point
qPt = pack(matmul(tetrahedron,reshape([ &
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), &
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), 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), 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), &
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), 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.)
end function permutationStar22
@ -293,23 +293,23 @@ end function permutationStar22
!--------------------------------------------------------------------------------------------------
pure function permutationStar211(point) result(qPt)
real(pReal), dimension(36) :: qPt
real(pReal), dimension(2), intent(in) :: point
real(pREAL), dimension(36) :: qPt
real(pREAL), dimension(2), intent(in) :: point
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), 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), 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(2), point(1), &
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), 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(2), point(1), &
1.0_pReal - 2.0_pReal*point(1) - point(2), point(2), point(1), point(1)],[4,12])),.true.)
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(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), 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(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), 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(2), point(1), &
1.0_pREAL - 2.0_pREAL*point(1) - point(2), point(2), point(1), point(1)],[4,12])),.true.)
end function permutationStar211
@ -319,35 +319,35 @@ end function permutationStar211
!--------------------------------------------------------------------------------------------------
pure function permutationStar1111(point) result(qPt)
real(pReal), dimension(72) :: qPt
real(pReal), dimension(3), intent(in) :: point
real(pREAL), dimension(72) :: qPt
real(pREAL), dimension(3), intent(in) :: point
qPt = pack(matmul(tetrahedron,reshape([ &
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(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), 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(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(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), 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(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(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), 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), &
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(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(3), point(1), point(2), &
1.0_pReal - point(1) - point(2)- point(3), point(3), point(2), point(1)],[4,24])),.true.)
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(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), 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(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(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), 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(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(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), 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), &
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(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(3), point(1), point(2), &
1.0_pREAL - point(1) - point(2)- point(3), point(3), point(2), point(1)],[4,24])),.true.)
end function permutationStar1111
@ -358,12 +358,12 @@ end function permutationStar1111
subroutine selfTest
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 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'
end do
end do
@ -371,7 +371,7 @@ subroutine selfTest
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)
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'
end do
end do

18
src/mesh/FEM_utilities.f90
View File

@ -29,7 +29,7 @@ module FEM_utilities
private
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
integer(kind(COMPONENT_UNDEFINED_ID)) :: ID
real(pReal), allocatable, dimension(:) :: Value
real(pREAL), allocatable, dimension(:) :: Value
logical, allocatable, dimension(:) :: Mask
end type tComponentBC
@ -92,7 +92,7 @@ contains
!--------------------------------------------------------------------------------------------------
subroutine FEM_utilities_init
character(len=pStringLen) :: petsc_optionsOrder
character(len=pSTRLEN) :: petsc_optionsOrder
type(tDict), pointer :: &
num_mesh
integer :: &
@ -122,13 +122,13 @@ subroutine FEM_utilities_init
&-mechanical_snes_ksp_ew_rtol0 0.01 -mechanical_snes_ksp_ew_rtolmax 0.01 &
&-mechanical_ksp_type fgmres -mechanical_ksp_max_it 25', err_PETSc)
CHKERRQ(err_PETSc)
call PetscOptionsInsertString(PETSC_NULL_OPTIONS,num_mesh%get_asString('PETSc_options',defaultVal=''),err_PETSc)
call PetscOptionsInsertString(PETSC_NULL_OPTIONS,num_mesh%get_asStr('PETSc_options',defaultVal=''),err_PETSc)
CHKERRQ(err_PETSc)
write(petsc_optionsOrder,'(a,i0)') '-mechFE_petscspace_degree ', p_s
call PetscOptionsInsertString(PETSC_NULL_OPTIONS,trim(petsc_optionsOrder),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
@ -139,9 +139,9 @@ end subroutine FEM_utilities_init
!--------------------------------------------------------------------------------------------------
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
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
@ -170,8 +170,8 @@ subroutine utilities_projectBCValues(localVec,section,field,comp,bcPointsIS,BCVa
PetscSection :: section
IS :: bcPointsIS
PetscInt, pointer :: bcPoints(:)
real(pReal), pointer :: localArray(:)
real(pReal) :: BCValue,BCDotValue,timeinc
real(pREAL), pointer :: localArray(:)
real(pREAL) :: BCValue,BCDotValue,timeinc
PetscErrorCode :: err_PETSc

18
src/mesh/discretization_mesh.f90
View File

@ -49,11 +49,11 @@ module discretization_mesh
PetscInt, dimension(:), allocatable, public, protected :: &
mesh_boundaries
real(pReal), dimension(:,:), allocatable :: &
real(pREAL), dimension(:,:), allocatable :: &
mesh_ipVolume, & !< volume associated with IP (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!)
#ifdef PETSC_USE_64BIT_INDICES
@ -92,7 +92,7 @@ subroutine discretization_mesh_init(restart)
num_mesh
integer :: p_i, dim !< integration order (quadrature rule)
type(tvec) :: coords_node0
real(pReal), pointer, dimension(:) :: &
real(pREAL), pointer, dimension(:) :: &
mesh_node0_temp
print'(/,1x,a)', '<<<+- discretization_mesh init -+>>>'
@ -176,7 +176,7 @@ subroutine discretization_mesh_init(restart)
end do
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])
@ -200,7 +200,7 @@ subroutine mesh_FEM_build_ipVolumes(dimPlex)
PetscInt :: cellStart, cellEnd, cell
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)
CHKERRQ(err_PETSc)
@ -209,7 +209,7 @@ subroutine mesh_FEM_build_ipVolumes(dimPlex)
do cell = cellStart, cellEnd-1
call DMPlexComputeCellGeometryFVM(geomMesh,cell,vol,pCent,pNorm,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 subroutine mesh_FEM_build_ipVolumes
@ -229,7 +229,7 @@ subroutine mesh_FEM_build_ipCoordinates(dimPlex,qPoints)
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(pCellJ(dimPlex**2))
@ -245,7 +245,7 @@ subroutine mesh_FEM_build_ipCoordinates(dimPlex,qPoints)
mesh_ipCoordinates(dirI,qPt,cell+1) = pV0(dirI)
do dirJ = 1_pPETSCINT, dimPlex
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
qOffset = qOffset + dimPlex
@ -259,7 +259,7 @@ end subroutine mesh_FEM_build_ipCoordinates
!--------------------------------------------------------------------------------------------------
subroutine writeGeometry(coordinates_points,coordinates_nodes)
real(pReal), dimension(:,:), intent(in) :: &
real(pREAL), dimension(:,:), intent(in) :: &
coordinates_nodes, &
coordinates_points

104
src/mesh/mesh_mech_FEM.f90
View File

@ -37,7 +37,7 @@ module mesh_mechanical_FEM
! derived types
type tSolutionParams
type(tFieldBC) :: fieldBC
real(pReal) :: timeinc
real(pREAL) :: timeinc
end type tSolutionParams
type(tSolutionParams) :: params
@ -48,7 +48,7 @@ module mesh_mechanical_FEM
itmax
logical :: &
BBarStabilisation
real(pReal) :: &
real(pREAL) :: &
eps_struct_atol, & !< absolute tolerance for mechanical equilibrium
eps_struct_rtol !< relative tolerance for mechanical equilibrium
end type tNumerics
@ -65,11 +65,11 @@ module mesh_mechanical_FEM
!--------------------------------------------------------------------------------------------------
! stress, stiffness and compliance average etc.
character(len=pStringLen) :: incInfo
real(pReal), dimension(3,3) :: &
P_av = 0.0_pReal
character(len=pSTRLEN) :: incInfo
real(pREAL), dimension(3,3) :: &
P_av = 0.0_pREAL
logical :: ForwardData
real(pReal), parameter :: eps = 1.0e-18_pReal
real(pREAL), parameter :: eps = 1.0e-18_pREAL
external :: & ! ToDo: write interfaces
#ifdef PETSC_USE_64BIT_INDICES
@ -120,12 +120,12 @@ subroutine FEM_mechanical_init(fieldBC)
PetscReal :: detJ
PetscReal, allocatable, target :: cellJMat(:,:)
real(pReal), pointer, dimension(:) :: px_scal
real(pReal), allocatable, target, dimension(:) :: x_scal
real(pREAL), pointer, dimension(:) :: px_scal
real(pREAL), allocatable, target, dimension(:) :: x_scal
character(len=*), parameter :: prefix = 'mechFE_'
PetscErrorCode :: err_PETSc
real(pReal), dimension(3,3) :: devNull
real(pREAL), dimension(3,3) :: devNull
type(tDict), pointer :: &
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%itmax = int(num_mesh%get_asInt('itmax',defaultVal=250),pPETSCINT)
num%BBarStabilisation = num_mesh%get_asBool('bbarstabilisation',defaultVal = .false.)
num%eps_struct_atol = num_mesh%get_asFloat('eps_struct_atol', defaultVal = 1.0e-10_pReal)
num%eps_struct_rtol = num_mesh%get_asFloat('eps_struct_rtol', defaultVal = 1.0e-4_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)
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_atol <= 0.0_pReal) call IO_error(301,ext_msg='eps_struct_atol')
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')
!--------------------------------------------------------------------------------------------------
! Setup FEM mech mesh
@ -264,16 +264,16 @@ subroutine FEM_mechanical_init(fieldBC)
CHKERRQ(err_PETSc)
call SNESSetConvergenceTest(mechanical_snes,FEM_mechanical_converged,PETSC_NULL_VEC,PETSC_NULL_FUNCTION,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)
call SNESSetFromOptions(mechanical_snes,err_PETSc)
CHKERRQ(err_PETSc)
!--------------------------------------------------------------------------------------------------
! init fields
call VecSet(solution ,0.0_pReal,err_PETSc)
call VecSet(solution ,0.0_pREAL,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)
allocate(x_scal(cellDof))
allocate(nodalWeightsP(1))
@ -289,7 +289,7 @@ subroutine FEM_mechanical_init(fieldBC)
call DMPlexGetHeightStratum(mechanical_mesh,0_pPETSCINT,cellStart,cellEnd,err_PETSc)
CHKERRQ(err_PETSc)
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)
CHKERRQ(err_PETSc)
cellJMat = reshape(pCellJ,shape=[dimPlex,dimPlex])
@ -298,13 +298,13 @@ subroutine FEM_mechanical_init(fieldBC)
CHKERRQ(err_PETSc)
call PetscQuadratureGetData(functional,dimPlex,nc,nNodalPoints,nodalPointsP,nodalWeightsP,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
px_scal => x_scal
call DMPlexVecSetClosure(mechanical_mesh,section,solution_local,cell,px_scal,5,err_PETSc)
CHKERRQ(err_PETSc)
end do
call utilities_constitutiveResponse(0.0_pReal,devNull,.true.)
call utilities_constitutiveResponse(0.0_pREAL,devNull,.true.)
end subroutine FEM_mechanical_init
@ -317,7 +317,7 @@ type(tSolutionState) function FEM_mechanical_solution( &
!--------------------------------------------------------------------------------------------------
! input data for solution
real(pReal), intent(in) :: &
real(pREAL), intent(in) :: &
timeinc, & !< increment in time for current solution
timeinc_old !< increment in time of last increment
type(tFieldBC), intent(in) :: &
@ -369,8 +369,8 @@ subroutine FEM_mechanical_formResidual(dm_local,xx_local,f_local,dummy,err_PETSc
PetscDS :: prob
Vec :: x_local, f_local, xx_local
PetscSection :: section
real(pReal), dimension(:), pointer :: x_scal, pf_scal
real(pReal), dimension(cellDof), target :: f_scal
real(pREAL), dimension(:), pointer :: x_scal, pf_scal
real(pREAL), dimension(cellDof), target :: f_scal
PetscReal :: IcellJMat(dimPlex,dimPlex)
PetscReal, dimension(:),pointer :: pV0, pCellJ, pInvcellJ, basisField, basisFieldDer
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)
call DMGetLocalVector(dm_local,x_local,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)
do field = 1_pPETSCINT, dimPlex; do face = 1_pPETSCINT, mesh_Nboundaries
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)
CHKERRQ(err_PETSc)
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)
CHKERRQ(err_PETSc)
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])
do qPt = 0_pPETSCINT, nQuadrature-1_pPETSCINT
m = cell*nQuadrature + qPt+1_pPETSCINT
BMat = 0.0_pReal
BMat = 0.0_pREAL
do basis = 0_pPETSCINT, nBasis-1_pPETSCINT
do comp = 0_pPETSCINT, dimPlex-1_pPETSCINT
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])
end do
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
m = cell*nQuadrature + qPt+1
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 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)
CHKERRQ(err_PETSc)
IcellJMat = reshape(pInvcellJ,shape=[dimPlex,dimPlex])
f_scal = 0.0_pReal
f_scal = 0.0_pREAL
do qPt = 0_pPETSCINT, nQuadrature-1_pPETSCINT
m = cell*nQuadrature + qPt+1_pPETSCINT
BMat = 0.0_pReal
BMat = 0.0_pREAL
do basis = 0_pPETSCINT, nBasis-1_pPETSCINT
do comp = 0_pPETSCINT, dimPlex-1_pPETSCINT
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, &
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) :: K_eA, K_eB
real(pREAL),dimension(cellDOF,cellDOF), target :: K_e
real(pREAL),dimension(cellDOF,cellDOF) :: K_eA, K_eB
PetscInt :: cellStart, cellEnd, cell, field, face, &
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)
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)
do field = 1, dimPlex; do face = 1, mesh_Nboundaries
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)
CHKERRQ(err_PETSc)
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)
CHKERRQ(err_PETSc)
end if
@ -569,14 +569,14 @@ subroutine FEM_mechanical_formJacobian(dm_local,xx_local,Jac_pre,Jac,dummy,err_P
CHKERRQ(err_PETSc)
call DMPlexComputeCellGeometryAffineFEM(dm_local,cell,pV0,pCellJ,pInvcellJ,detJ,err_PETSc)
CHKERRQ(err_PETSc)
K_eA = 0.0_pReal
K_eB = 0.0_pReal
MatB = 0.0_pReal
FAvg = 0.0_pReal
BMatAvg = 0.0_pReal
K_eA = 0.0_pREAL
K_eB = 0.0_pREAL
MatB = 0.0_pREAL
FAvg = 0.0_pREAL
BMatAvg = 0.0_pREAL
do qPt = 0_pPETSCINT, nQuadrature-1_pPETSCINT
m = cell*nQuadrature + qPt + 1_pPETSCINT
BMat = 0.0_pReal
BMat = 0.0_pREAL
do basis = 0_pPETSCINT, nBasis-1_pPETSCINT
do comp = 0_pPETSCINT, dimPlex-1_pPETSCINT
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
F(1:dimPlex,1:dimPlex) = reshape(matmul(BMat,x_scal),shape=[dimPlex,dimPlex])
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 - &
matmul(transpose(matmul(reshape(homogenization_F(1:dimPlex,1:dimPlex,m),shape=[dimPlex**2,1_pPETSCINT]), &
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
if (num%BBarStabilisation) then
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), &
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
K_e = K_eA
end if
@ -662,7 +662,7 @@ subroutine FEM_mechanical_forward(guess,timeinc,timeinc_old,fieldBC)
type(tFieldBC), intent(in) :: &
fieldBC
real(pReal), intent(in) :: &
real(pREAL), intent(in) :: &
timeinc_old, &
timeinc
logical, intent(in) :: &
@ -686,13 +686,13 @@ subroutine FEM_mechanical_forward(guess,timeinc,timeinc_old,fieldBC)
CHKERRQ(err_PETSc)
call DMGetLocalVector(dm_local,x_local,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)
call DMGlobalToLocalBegin(dm_local,solution,INSERT_VALUES,x_local,err_PETSc) !< retrieve my partition of global solution vector
CHKERRQ(err_PETSc)
call DMGlobalToLocalEnd(dm_local,solution,INSERT_VALUES,x_local,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)
do field = 1, dimPlex; do face = 1, mesh_Nboundaries
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)
CHKERRQ(err_PETSc)
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)
CHKERRQ(err_PETSc)
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), &
' @ Iteration ',PETScIter,' mechanical residual norm = ',fnorm/divTol
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)
end subroutine FEM_mechanical_converged
@ -759,7 +759,7 @@ subroutine FEM_mechanical_updateCoords()
PetscReal, pointer, dimension(:,:) :: &
nodeCoords !< nodal coordinates (3,Nnodes)
real(pReal), pointer, dimension(:,:,:) :: &
real(pREAL), pointer, dimension(:,:,:) :: &
ipCoords !< ip coordinates (3,nQuadrature,mesh_NcpElems)
integer :: &
@ -777,7 +777,7 @@ subroutine FEM_mechanical_updateCoords()
PetscQuadrature :: mechQuad
PetscReal, dimension(:), pointer :: basisField, basisFieldDer, &
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)
CHKERRQ(err_PETSc)
@ -793,7 +793,7 @@ subroutine FEM_mechanical_updateCoords()
! write cell vertex displacements
call DMPlexGetDepthStratum(dm_local,0_pPETSCINT,pStart,pEnd,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)
CHKERRQ(err_PETSc)
do p=pStart, pEnd-1
@ -811,7 +811,7 @@ subroutine FEM_mechanical_updateCoords()
CHKERRQ(err_PETSc)
call PetscDSGetTabulation(mechQuad,0_pPETSCINT,basisField,basisFieldDer,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
qOffset=0
call DMPlexVecGetClosure(dm_local,section,x_local,c,x_scal,err_PETSc) !< get nodal coordinates of each element

46
src/misc.f90
View File

@ -11,9 +11,9 @@ module misc
interface misc_optional
module procedure misc_optional_bool
module procedure misc_optional_integer
module procedure misc_optional_int
module procedure misc_optional_real
module procedure misc_optional_string
module procedure misc_optional_str
end interface misc_optional
public :: &
@ -57,7 +57,7 @@ end function misc_optional_bool
!--------------------------------------------------------------------------------------------------
!> @brief Return integer value if given, otherwise default.
!--------------------------------------------------------------------------------------------------
pure function misc_optional_integer(given,default) result(var)
pure function misc_optional_int(given,default) result(var)
integer, intent(in), optional :: given
integer, intent(in) :: default
@ -70,7 +70,7 @@ pure function misc_optional_integer(given,default) result(var)
var = default
end if
end function misc_optional_integer
end function misc_optional_int
!--------------------------------------------------------------------------------------------------
@ -78,9 +78,9 @@ end function misc_optional_integer
!--------------------------------------------------------------------------------------------------
pure function misc_optional_real(given,default) result(var)
real(pReal), intent(in), optional :: given
real(pReal), intent(in) :: default
real(pReal) :: var
real(pREAL), intent(in), optional :: given
real(pREAL), intent(in) :: default
real(pREAL) :: var
if (present(given)) then
@ -95,7 +95,7 @@ end function misc_optional_real
!--------------------------------------------------------------------------------------------------
!> @brief Return string value if given, otherwise default.
!--------------------------------------------------------------------------------------------------
pure function misc_optional_string(given,default) result(var)
pure function misc_optional_str(given,default) result(var)
character(len=*), intent(in), optional :: given
character(len=*), intent(in) :: default
@ -108,7 +108,7 @@ pure function misc_optional_string(given,default) result(var)
var = default
end if
end function misc_optional_string
end function misc_optional_str
!--------------------------------------------------------------------------------------------------
@ -116,21 +116,21 @@ end function misc_optional_string
!--------------------------------------------------------------------------------------------------
subroutine misc_selfTest()
real(pReal) :: r
real(pREAL) :: r
call random_number(r)
if (test_str('DAMASK') /= 'DAMASK') error stop 'optional_string, present'
if (test_str() /= 'default') error stop 'optional_string, not present'
if (misc_optional(default='default') /= 'default') error stop 'optional_string, default only'
if (test_str('DAMASK') /= 'DAMASK') error stop 'optional_str, present'
if (test_str() /= 'default') error stop 'optional_str, not present'
if (misc_optional(default='default') /= 'default') error stop 'optional_str, default only'
if (test_int(20191102) /= 20191102) error stop 'optional_int, present'
if (test_int() /= 42) error stop 'optional_int, not present'
if (misc_optional(default=20191102) /= 20191102) error stop 'optional_int, default only'
if (dNeq(test_real(r),r)) error stop 'optional_float, present'
if (dNeq(test_real(),0.0_pReal)) error stop 'optional_float, not present'
if (dNeq(misc_optional(default=r),r)) error stop 'optional_float, default only'
if (test_bool(r<0.5_pReal) .neqv. r<0.5_pReal) error stop 'optional_bool, 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(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 (.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
@ -140,7 +140,7 @@ contains
character(len=*), intent(in), optional :: str_in
str_out = misc_optional_string(str_in,'default')
str_out = misc_optional_str(str_in,'default')
end function test_str
@ -151,18 +151,18 @@ contains
integer, intent(in), optional :: int_in
int_out = misc_optional_integer(int_in,42)
int_out = misc_optional_int(int_in,42)
end function test_int
function test_real(real_in) result(real_out)
real(pReal) :: real_out
real(pReal), intent(in), optional :: real_in
real(pREAL) :: real_out
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

18
src/parallelization.f90
View File

@ -39,8 +39,8 @@ module parallelization
public :: parallelization_bcast_str
contains
subroutine parallelization_bcast_str(string)
character(len=:), allocatable, intent(inout) :: string
subroutine parallelization_bcast_str(str)
character(len=:), allocatable, intent(inout) :: str
end subroutine parallelization_bcast_str
#else
@ -135,8 +135,8 @@ subroutine parallelization_init()
call MPI_Type_size(MPI_DOUBLE,typeSize,err_MPI)
if (err_MPI /= 0_MPI_INTEGER_KIND) &
error stop 'Could not determine size of MPI_DOUBLE'
if (typeSize*8_MPI_INTEGER_KIND /= int(storage_size(0.0_pReal),MPI_INTEGER_KIND)) &
error stop 'Mismatch between MPI_DOUBLE and DAMASK pReal'
if (typeSize*8_MPI_INTEGER_KIND /= int(storage_size(0.0_pREAL),MPI_INTEGER_KIND)) &
error stop 'Mismatch between MPI_DOUBLE and DAMASK pREAL'
!$ call get_environment_variable(name='OMP_NUM_THREADS',value=NumThreadsString,STATUS=got_env)
!$ if (got_env /= 0) then
@ -171,18 +171,18 @@ end subroutine parallelization_chkerr
!--------------------------------------------------------------------------------------------------
!> @brief Broadcast a string from process 0.
!--------------------------------------------------------------------------------------------------
subroutine parallelization_bcast_str(string)
subroutine parallelization_bcast_str(str)
character(len=:), allocatable, intent(inout) :: string
character(len=:), allocatable, intent(inout) :: str
integer(MPI_INTEGER_KIND) :: strlen, err_MPI
if (worldrank == 0) strlen = len(string,MPI_INTEGER_KIND)
if (worldrank == 0) strlen = len(str,MPI_INTEGER_KIND)
call MPI_Bcast(strlen,1_MPI_INTEGER_KIND,MPI_INTEGER,0_MPI_INTEGER_KIND,MPI_COMM_WORLD, err_MPI)
if (worldrank /= 0) allocate(character(len=strlen)::string)
if (worldrank /= 0) allocate(character(len=strlen)::str)
call MPI_Bcast(string,strlen,MPI_CHARACTER,0_MPI_INTEGER_KIND,MPI_COMM_WORLD, err_MPI)
call MPI_Bcast(str,strlen,MPI_CHARACTER,0_MPI_INTEGER_KIND,MPI_COMM_WORLD, err_MPI)
end subroutine parallelization_bcast_str

134
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
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
real(pReal), allocatable, dimension(:) :: &
real(pREAL), allocatable, dimension(:) :: &
atol
! 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, &
state, & !< state
dotState, & !< rate of state change
deltaState !< increment of state change
real(pReal), pointer, dimension(:,:) :: &
real(pREAL), pointer, dimension(:,:) :: &
deltaState2
end type
@ -51,8 +51,8 @@ module phase
character(len=2), allocatable, dimension(:) :: phase_lattice
real(pReal), allocatable, dimension(:) :: phase_cOverA
real(pReal), allocatable, dimension(:) :: phase_rho
real(pREAL), allocatable, dimension(:) :: phase_cOverA
real(pREAL), allocatable, dimension(:) :: phase_rho
type(tRotationContainer), dimension(:), allocatable :: &
phase_O_0, &
@ -63,7 +63,7 @@ module phase
iJacoLpresiduum, & !< frequency of Jacobian update of residuum in Lp
nState, & !< state loop limit
nStress !< stress loop limit
real(pReal) :: &
real(pREAL) :: &
subStepMinCryst, & !< minimum (relative) size of sub-step allowed during cutback
subStepSizeCryst, & !< size of first substep when cutback
subStepSizeLp, & !< size of first substep when cutback in Lp calculation
@ -133,11 +133,11 @@ module phase
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) :: &
co, & !< counter in constituent loop
ce
real(pReal), dimension(3,3,3,3) :: dPdF
real(pREAL), dimension(3,3,3,3) :: dPdF
end function phase_mechanical_dPdF
module subroutine mechanical_restartWrite(groupHandle,ph)
@ -172,105 +172,105 @@ module phase
module function mechanical_S(ph,en) result(S)
integer, intent(in) :: ph,en
real(pReal), dimension(3,3) :: S
real(pREAL), dimension(3,3) :: S
end function mechanical_S
module function mechanical_L_p(ph,en) result(L_p)
integer, intent(in) :: ph,en
real(pReal), dimension(3,3) :: L_p
real(pREAL), dimension(3,3) :: L_p
end function mechanical_L_p
module function mechanical_F_e(ph,en) result(F_e)
integer, intent(in) :: ph,en
real(pReal), dimension(3,3) :: F_e
real(pREAL), dimension(3,3) :: F_e
end function mechanical_F_e
module function mechanical_F_i(ph,en) result(F_i)
integer, intent(in) :: ph,en
real(pReal), dimension(3,3) :: F_i
real(pREAL), dimension(3,3) :: F_i
end function mechanical_F_i
module function phase_F(co,ce) result(F)
integer, intent(in) :: co, ce
real(pReal), dimension(3,3) :: F
real(pREAL), dimension(3,3) :: F
end function phase_F
module function phase_P(co,ce) result(P)
integer, intent(in) :: co, ce
real(pReal), dimension(3,3) :: P
real(pREAL), dimension(3,3) :: P
end function phase_P
pure module function thermal_T(ph,en) result(T)
integer, intent(in) :: ph,en
real(pReal) :: T
real(pREAL) :: T
end function thermal_T
module function thermal_dot_T(ph,en) result(dot_T)
integer, intent(in) :: ph,en
real(pReal) :: dot_T
real(pREAL) :: dot_T
end function thermal_dot_T
module function damage_phi(ph,en) result(phi)
integer, intent(in) :: ph,en
real(pReal) :: phi
real(pREAL) :: phi
end function damage_phi
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
end subroutine phase_set_F
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
end subroutine phase_thermal_setField
module subroutine phase_set_phi(phi,co,ce)
real(pReal), intent(in) :: phi
real(pREAL), intent(in) :: phi
integer, intent(in) :: co, ce
end subroutine phase_set_phi
module function phase_mu_phi(co,ce) result(mu)
integer, intent(in) :: co, ce
real(pReal) :: mu
real(pREAL) :: mu
end function phase_mu_phi
module function phase_K_phi(co,ce) result(K)
integer, intent(in) :: co, ce
real(pReal), dimension(3,3) :: K
real(pREAL), dimension(3,3) :: K
end function phase_K_phi
module function phase_mu_T(co,ce) result(mu)
integer, intent(in) :: co, ce
real(pReal) :: mu
real(pREAL) :: mu
end function phase_mu_T
module function phase_K_T(co,ce) result(K)
integer, intent(in) :: co, ce
real(pReal), dimension(3,3) :: K
real(pREAL), dimension(3,3) :: K
end function phase_K_T
! == cleaned:end ===================================================================================
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
logical :: converged_
end function phase_thermal_constitutive
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
logical :: converged_
end function phase_damage_constitutive
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
logical :: converged_
end function phase_mechanical_constitutive
@ -278,25 +278,25 @@ module phase
!ToDo: Merge all the stiffness functions
module function phase_homogenizedC66(ph,en) result(C)
integer, intent(in) :: ph, en
real(pReal), dimension(6,6) :: C
real(pREAL), dimension(6,6) :: C
end function phase_homogenizedC66
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
real(pReal), dimension(6,6) :: C66_degraded
real(pREAL), dimension(6,6) :: C66_degraded
end function phase_damage_C66
module function phase_f_phi(phi,co,ce) result(f)
integer, intent(in) :: ce,co
real(pReal), intent(in) :: &
real(pREAL), intent(in) :: &
phi !< damage parameter
real(pReal) :: &
real(pREAL) :: &
f
end function phase_f_phi
module function phase_f_T(ph,en) result(f)
integer, intent(in) :: ph, en
real(pReal) :: f
real(pREAL) :: f
end function phase_f_T
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)
integer, intent(in) :: ph, en
real(pReal), intent(in), dimension(3,3) :: &
real(pREAL), intent(in), dimension(3,3) :: &
M_i
real(pReal), intent(out), dimension(3,3) :: &
real(pREAL), intent(out), dimension(3,3) :: &
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
end subroutine damage_anisobrittle_LiAndItsTangent
@ -389,7 +389,7 @@ subroutine phase_init
phases => config_material%get_dict('phase')
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_O_0(phases%length))
@ -398,12 +398,12 @@ subroutine phase_init
phase => phases%get_dict(ph)
refs = config_listReferences(phase,indent=3)
if (len(refs) > 0) print'(/,1x,a)', refs
phase_lattice(ph) = phase%get_asString('lattice')
phase_lattice(ph) = phase%get_asStr('lattice')
if (all(phase_lattice(ph) /= ['cF','cI','hP','tI'])) &
call IO_error(130,ext_msg='phase_init: '//phase%get_asString('lattice'))
call IO_error(130,ext_msg='phase_init: '//phase%get_asStr('lattice'))
if (any(phase_lattice(ph) == ['hP','tI'])) &
phase_cOverA(ph) = phase%get_asFloat('c/a')
phase_rho(ph) = phase%get_asFloat('rho',defaultVal=0.0_pReal)
phase_cOverA(ph) = phase%get_asReal('c/a')
phase_rho(ph) = phase%get_asReal('rho',defaultVal=0.0_pREAL)
allocate(phase_O_0(ph)%data(count(material_ID_phase==ph)))
end do
@ -454,13 +454,13 @@ subroutine phase_allocateState(state, &
state%offsetDeltaState = sizeState-sizeDeltaState ! deltaState occupies latter part of state by definition
end if
allocate(state%atol (sizeState), source=0.0_pReal)
allocate(state%state0 (sizeState,NEntries), source=0.0_pReal)
allocate(state%state (sizeState,NEntries), source=0.0_pReal)
allocate(state%atol (sizeState), source=0.0_pREAL)
allocate(state%state0 (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%offsetDeltaState+state%sizeDeltaState,:)
@ -538,27 +538,27 @@ subroutine crystallite_init()
num_crystallite => config_numerics%get_dict('crystallite',defaultVal=emptyDict)
num%subStepMinCryst = num_crystallite%get_asFloat ('subStepMin', defaultVal=1.0e-3_pReal)
num%subStepSizeCryst = num_crystallite%get_asFloat ('subStepSize', defaultVal=0.25_pReal)
num%stepIncreaseCryst = num_crystallite%get_asFloat ('stepIncrease', defaultVal=1.5_pReal)
num%subStepSizeLp = num_crystallite%get_asFloat ('subStepSizeLp', defaultVal=0.5_pReal)
num%subStepSizeLi = num_crystallite%get_asFloat ('subStepSizeLi', defaultVal=0.5_pReal)
num%rtol_crystalliteState = num_crystallite%get_asFloat ('rtol_State', defaultVal=1.0e-6_pReal)
num%rtol_crystalliteStress = num_crystallite%get_asFloat ('rtol_Stress', defaultVal=1.0e-6_pReal)
num%atol_crystalliteStress = num_crystallite%get_asFloat ('atol_Stress', defaultVal=1.0e-8_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%stepIncreaseCryst = num_crystallite%get_asReal ('stepIncrease', defaultVal=1.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%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%atol_crystalliteStress = num_crystallite%get_asReal ('atol_Stress', defaultVal=1.0e-8_pREAL)
num%iJacoLpresiduum = num_crystallite%get_asInt ('iJacoLpresiduum', defaultVal=1)
num%nState = num_crystallite%get_asInt ('nState', defaultVal=20)
num%nStress = num_crystallite%get_asInt ('nStress', defaultVal=40)
extmsg = ''
if (num%subStepMinCryst <= 0.0_pReal) extmsg = trim(extmsg)//' subStepMinCryst'
if (num%subStepSizeCryst <= 0.0_pReal) extmsg = trim(extmsg)//' subStepSizeCryst'
if (num%stepIncreaseCryst <= 0.0_pReal) extmsg = trim(extmsg)//' stepIncreaseCryst'
if (num%subStepSizeLp <= 0.0_pReal) extmsg = trim(extmsg)//' subStepSizeLp'
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_crystalliteStress <= 0.0_pReal) extmsg = trim(extmsg)//' rtol_crystalliteStress'
if (num%atol_crystalliteStress <= 0.0_pReal) extmsg = trim(extmsg)//' atol_crystalliteStress'
if (num%subStepMinCryst <= 0.0_pREAL) extmsg = trim(extmsg)//' subStepMinCryst'
if (num%subStepSizeCryst <= 0.0_pREAL) extmsg = trim(extmsg)//' subStepSizeCryst'
if (num%stepIncreaseCryst <= 0.0_pREAL) extmsg = trim(extmsg)//' stepIncreaseCryst'
if (num%subStepSizeLp <= 0.0_pREAL) extmsg = trim(extmsg)//' subStepSizeLp'
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_crystalliteStress <= 0.0_pREAL) extmsg = trim(extmsg)//' rtol_crystalliteStress'
if (num%atol_crystalliteStress <= 0.0_pREAL) extmsg = trim(extmsg)//' atol_crystalliteStress'
if (num%iJacoLpresiduum < 1) extmsg = trim(extmsg)//' iJacoLpresiduum'
if (num%nState < 1) extmsg = trim(extmsg)//' nState'
if (num%nStress < 1) extmsg = trim(extmsg)//' nStress'
@ -615,13 +615,13 @@ end subroutine crystallite_orientations
!--------------------------------------------------------------------------------------------------
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):: &
co, &
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
@ -639,9 +639,9 @@ end function crystallite_push33ToRef
!--------------------------------------------------------------------------------------------------
logical pure function converged(residuum,state,atol)
real(pReal), intent(in), dimension(:) ::&
real(pREAL), intent(in), dimension(:) ::&
residuum, state, atol
real(pReal) :: &
real(pREAL) :: &
rTol
rTol = num%rTol_crystalliteState

70
src/phase_damage.f90
View File

@ -4,9 +4,9 @@
submodule(phase) damage
type :: tDamageParameters
real(pReal) :: &
mu = 0.0_pReal, & !< viscosity
l_c = 0.0_pReal !< characteristic length
real(pREAL) :: &
mu = 0.0_pREAL, & !< viscosity
l_c = 0.0_pREAL !< characteristic length
end type tDamageParameters
enum, bind(c); enumerator :: &
@ -19,7 +19,7 @@ submodule(phase) damage
type :: tDataContainer
real(pReal), dimension(:), allocatable :: phi
real(pREAL), dimension(:), allocatable :: phi
end type tDataContainer
integer(kind(DAMAGE_UNDEFINED_ID)), dimension(:), allocatable :: &
@ -42,16 +42,16 @@ submodule(phase) damage
module subroutine isobrittle_deltaState(C, Fe, ph, en)
integer, intent(in) :: ph,en
real(pReal), intent(in), dimension(3,3) :: &
real(pREAL), intent(in), dimension(3,3) :: &
Fe
real(pReal), intent(in), dimension(6,6) :: &
real(pREAL), intent(in), dimension(6,6) :: &
C
end subroutine isobrittle_deltaState
module subroutine anisobrittle_dotState(M_i, ph, en)
integer, intent(in) :: ph,en
real(pReal), intent(in), dimension(3,3) :: &
real(pREAL), intent(in), dimension(3,3) :: &
M_i
end subroutine anisobrittle_dotState
@ -99,7 +99,7 @@ module subroutine damage_init()
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)
source => phase%get_dict('damage',defaultVal=emptyDict)
@ -108,8 +108,8 @@ module subroutine damage_init()
refs = config_listReferences(source,indent=3)
if (len(refs) > 0) print'(/,1x,a)', refs
damage_active = .true.
param(ph)%mu = source%get_asFloat('mu')
param(ph)%l_c = source%get_asFloat('l_c')
param(ph)%mu = source%get_asReal('mu')
param(ph)%l_c = source%get_asReal('l_c')
end if
end do
@ -131,7 +131,7 @@ end subroutine damage_init
!--------------------------------------------------------------------------------------------------
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
@ -154,9 +154,9 @@ end function phase_damage_constitutive
!--------------------------------------------------------------------------------------------------
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
real(pReal), dimension(6,6) :: C66_degraded
real(pREAL), dimension(6,6) :: C66_degraded
damageType: select case (phase_damage(ph))
@ -195,9 +195,9 @@ end subroutine damage_restore
module function phase_f_phi(phi,co,ce) result(f)
integer, intent(in) :: ce,co
real(pReal), intent(in) :: &
real(pREAL), intent(in) :: &
phi !< damage parameter
real(pReal) :: &
real(pREAL) :: &
f
integer :: &
@ -209,10 +209,10 @@ module function phase_f_phi(phi,co,ce) result(f)
select case(phase_damage(ph))
case(DAMAGE_ISOBRITTLE_ID,DAMAGE_ANISOBRITTLE_ID)
f = 1.0_pReal &
f = 1.0_pREAL &
- 2.0_pREAL * phi*damageState(ph)%state(1,en)
case default
f = 0.0_pReal
f = 0.0_pREAL
end select
end function phase_f_phi
@ -224,7 +224,7 @@ end function phase_f_phi
!--------------------------------------------------------------------------------------------------
function integrateDamageState(Delta_t,ph,en) result(broken)
real(pReal), intent(in) :: Delta_t
real(pREAL), intent(in) :: Delta_t
integer, intent(in) :: &
ph, &
en
@ -233,11 +233,11 @@ function integrateDamageState(Delta_t,ph,en) result(broken)
integer :: &
NiterationState, & !< number of iterations in state loop
size_so
real(pReal) :: &
real(pREAL) :: &
zeta
real(pReal), dimension(phase_damage_maxSizeDotState) :: &
real(pREAL), dimension(phase_damage_maxSizeDotState) :: &
r ! state residuum
real(pReal), dimension(phase_damage_maxSizeDotState,2) :: source_dotState
real(pREAL), dimension(phase_damage_maxSizeDotState,2) :: source_dotState
logical :: &
converged_
@ -254,7 +254,7 @@ function integrateDamageState(Delta_t,ph,en) result(broken)
size_so = damageState(ph)%sizeDotState
damageState(ph)%state(1:size_so,en) = damageState(ph)%state0 (1:size_so,en) &
+ 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
@ -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))
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) &
- damageState(ph)%State0 (1:size_so,en) &
- 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.
!--------------------------------------------------------------------------------------------------
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
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_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
damper = 0.75_pReal + 0.25_pReal * tanh(2.0_pReal + 4.0_pReal * dot_prod12 / dot_prod22)
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)
else
damper = 1.0_pReal
damper = 1.0_pREAL
end if
end function damper
@ -401,7 +401,7 @@ end function phase_damage_collectDotState
module function phase_mu_phi(co,ce) result(mu)
integer, intent(in) :: co, ce
real(pReal) :: mu
real(pREAL) :: 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)
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)
@ -432,7 +432,7 @@ function phase_damage_deltaState(Fe, ph, en) result(broken)
integer, intent(in) :: &
ph, &
en
real(pReal), intent(in), dimension(3,3) :: &
real(pREAL), intent(in), dimension(3,3) :: &
Fe !< elastic deformation gradient
integer :: &
@ -484,7 +484,7 @@ function source_active(source_label) result(active_source)
do ph = 1, phases%length
phase => phases%get_dict(ph)
src => phase%get_dict('damage',defaultVal=emptyDict)
active_source(ph) = src%get_asString('type',defaultVal = 'x') == source_label
active_source(ph) = src%get_asStr('type',defaultVal = 'x') == source_label
end do
@ -496,7 +496,7 @@ end function source_active
!----------------------------------------------------------------------------------------------
module subroutine phase_set_phi(phi,co,ce)
real(pReal), intent(in) :: phi
real(pREAL), intent(in) :: phi
integer, intent(in) :: ce, co
@ -508,7 +508,7 @@ end subroutine phase_set_phi
module function damage_phi(ph,en) result(phi)
integer, intent(in) :: ph, en
real(pReal) :: phi
real(pREAL) :: phi
phi = current(ph)%phi(en)

56
src/phase_damage_anisobrittle.f90
View File

@ -7,17 +7,17 @@
submodule (phase:damage) anisobrittle
type :: tParameters !< container type for internal constitutive parameters
real(pReal) :: &
real(pREAL) :: &
dot_o_0, & !< opening rate of cleavage planes
p !< damage rate sensitivity
real(pReal), dimension(:), allocatable :: &
real(pREAL), dimension(:), allocatable :: &
s_crit, & !< critical displacement
g_crit !< critical load
real(pReal), dimension(:,:,:,:), allocatable :: &
real(pREAL), dimension(:,:,:,:), allocatable :: &
cleavage_systems
integer :: &
sum_N_cl !< total number of cleavage planes
character(len=pStringLen), allocatable, dimension(:) :: &
character(len=pSTRLEN), allocatable, dimension(:) :: &
output
end type tParameters
@ -71,11 +71,11 @@ module function anisobrittle_init() result(mySources)
N_cl = src%get_as1dInt('N_cl',defaultVal=emptyIntArray)
prm%sum_N_cl = sum(abs(N_cl))
prm%p = src%get_asFloat('p')
prm%dot_o_0 = src%get_asFloat('dot_o_0')
prm%p = src%get_asReal('p')
prm%dot_o_0 = src%get_asReal('dot_o_0')
prm%s_crit = src%get_as1dFloat('s_crit', requiredSize=size(N_cl))
prm%g_crit = src%get_as1dFloat('g_crit', requiredSize=size(N_cl))
prm%s_crit = src%get_as1dReal('s_crit',requiredSize=size(N_cl))
prm%g_crit = src%get_as1dReal('g_crit',requiredSize=size(N_cl))
prm%cleavage_systems = lattice_SchmidMatrix_cleavage(N_cl,phase_lattice(ph),phase_cOverA(ph))
@ -84,21 +84,21 @@ module function anisobrittle_init() result(mySources)
prm%g_crit = math_expand(prm%g_crit,N_cl)
#if defined (__GFORTRAN__)
prm%output = output_as1dString(src)
prm%output = output_as1dStr(src)
#else
prm%output = src%get_as1dString('output',defaultVal=emptyStringArray)
prm%output = src%get_as1dStr('output',defaultVal=emptyStrArray)
#endif
! sanity checks
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 (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 (prm%p <= 0.0_pREAL) extmsg = trim(extmsg)//' p'
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%s_crit < 0.0_pREAL)) extmsg = trim(extmsg)//' s_crit'
Nmembers = count(material_ID_phase==ph)
call phase_allocateState(damageState(ph),Nmembers,1,1,0)
damageState(ph)%atol = src%get_asFloat('atol_phi',defaultVal=1.0e-9_pReal)
if (any(damageState(ph)%atol < 0.0_pReal)) extmsg = trim(extmsg)//' atol_phi'
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'
end associate
@ -117,17 +117,17 @@ module subroutine anisobrittle_dotState(M_i, ph,en)
integer, intent(in) :: &
ph,en
real(pReal), intent(in), dimension(3,3) :: &
real(pREAL), intent(in), dimension(3,3) :: &
M_i
integer :: &
a, i
real(pReal) :: &
real(pREAL) :: &
traction, traction_crit
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
traction_crit = damage_phi(ph,en)**2 * prm%g_crit(a)
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) &
+ 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 associate
@ -173,22 +173,22 @@ module subroutine damage_anisobrittle_LiAndItsTangent(L_i, dL_i_dM_i, M_i, ph,en
integer, intent(in) :: &
ph,en
real(pReal), intent(in), dimension(3,3) :: &
real(pREAL), intent(in), dimension(3,3) :: &
M_i
real(pReal), intent(out), dimension(3,3) :: &
real(pREAL), intent(out), dimension(3,3) :: &
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
integer :: &
a, k, l, m, n, i
real(pReal) :: &
real(pREAL) :: &
traction, traction_crit, &
udot, dudot_dt
L_i = 0.0_pReal
dL_i_dM_i = 0.0_pReal
L_i = 0.0_pREAL
dL_i_dM_i = 0.0_pREAL
associate(prm => param(ph))
do a = 1,prm%sum_N_cl
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
traction = math_tensordot(M_i,prm%cleavage_systems(1:3,1:3,i,a))
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)
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) &
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)

32
src/phase_damage_isobrittle.f90
View File

@ -7,14 +7,14 @@
submodule(phase:damage) isobrittle
type :: tParameters !< container type for internal constitutive parameters
real(pReal) :: &
real(pREAL) :: &
W_crit !< critical elastic strain energy
character(len=pStringLen), allocatable, dimension(:) :: &
character(len=pSTRLEN), allocatable, dimension(:) :: &
output
end type tParameters
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
end type tIsobrittleState
@ -64,25 +64,25 @@ module function isobrittle_init() result(mySources)
associate(prm => param(ph), dlt => deltaState(ph), stt => state(ph))
prm%W_crit = src%get_asFloat('G_crit')/src%get_asFloat('l_c')
prm%W_crit = src%get_asReal('G_crit')/src%get_asReal('l_c')
print'(/,1x,a,i0,a)', 'phase ',ph,': '//phases%key(ph)
refs = config_listReferences(src,indent=3)
if (len(refs) > 0) print'(/,1x,a)', refs
#if defined (__GFORTRAN__)
prm%output = output_as1dString(src)
prm%output = output_as1dStr(src)
#else
prm%output = src%get_as1dString('output',defaultVal=emptyStringArray)
prm%output = src%get_as1dStr('output',defaultVal=emptyStrArray)
#endif
! 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)
call phase_allocateState(damageState(ph),Nmembers,1,0,1)
damageState(ph)%atol = src%get_asFloat('atol_phi',defaultVal=1.0e-9_pReal)
if (any(damageState(ph)%atol < 0.0_pReal)) extmsg = trim(extmsg)//' atol_phi'
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'
stt%r_W => damageState(ph)%state(1,:)
dlt%r_W => damageState(ph)%deltaState(1,:)
@ -105,23 +105,23 @@ end function isobrittle_init
module subroutine isobrittle_deltaState(C, Fe, ph,en)
integer, intent(in) :: ph,en
real(pReal), intent(in), dimension(3,3) :: &
real(pREAL), intent(in), dimension(3,3) :: &
Fe
real(pReal), intent(in), dimension(6,6) :: &
real(pREAL), intent(in), dimension(6,6) :: &
C
real(pReal), dimension(6) :: &
real(pREAL), dimension(6) :: &
epsilon
real(pReal) :: &
real(pREAL) :: &
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))
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))
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))
end associate

260
src/phase_mechanical.f90
View File

@ -57,22 +57,22 @@ submodule(phase) mechanical
integer, intent(in) :: &
ph, &
en
real(pReal), intent(in), dimension(3,3) :: &
real(pREAL), intent(in), dimension(3,3) :: &
Fe, & !< elastic 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
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_dFi !< derivative of 2nd P-K stress with respect to intermediate deformation gradient
end subroutine phase_hooke_SandItsTangents
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
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
real(pReal), dimension(3,3), intent(in) :: &
real(pREAL), dimension(3,3), intent(in) :: &
Mi !< Mandel stress
integer, intent(in) :: &
ph, &
@ -83,9 +83,9 @@ submodule(phase) mechanical
integer, intent(in) :: &
ph, &
en
real(pReal), intent(in) :: &
real(pREAL), intent(in) :: &
subdt !< timestep
real(pReal), dimension(plasticState(ph)%sizeDotState) :: &
real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
dotState
end function plastic_dotState
@ -101,13 +101,13 @@ submodule(phase) mechanical
S, Fi, ph,en)
integer, intent(in) :: &
ph,en
real(pReal), intent(in), dimension(3,3) :: &
real(pREAL), intent(in), dimension(3,3) :: &
S !< 2nd Piola-Kirchhoff stress
real(pReal), intent(in), dimension(3,3) :: &
real(pREAL), intent(in), dimension(3,3) :: &
Fi !< intermediate deformation gradient
real(pReal), intent(out), dimension(3,3) :: &
real(pREAL), intent(out), dimension(3,3) :: &
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_dFi
@ -118,12 +118,12 @@ submodule(phase) mechanical
S, Fi, ph,en)
integer, intent(in) :: &
ph,en
real(pReal), intent(in), dimension(3,3) :: &
real(pREAL), intent(in), dimension(3,3) :: &
S, & !< 2nd Piola-Kirchhoff stress
Fi !< intermediate deformation gradient
real(pReal), intent(out), dimension(3,3) :: &
real(pREAL), intent(out), dimension(3,3) :: &
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_dFi !< derivative of Lp with respect to Fi
end subroutine plastic_LpAndItsTangents
@ -160,23 +160,23 @@ submodule(phase) mechanical
end subroutine plastic_nonlocal_result
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
end function plastic_dislotwin_homogenizedC
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
end function elastic_C66
pure module function elastic_mu(ph,en,isotropic_bound) result(mu)
real(pReal) :: mu
real(pREAL) :: mu
integer, intent(in) :: ph, en
character(len=*), intent(in) :: isotropic_bound
end function elastic_mu
pure module function elastic_nu(ph,en,isotropic_bound) result(nu)
real(pReal) :: nu
real(pREAL) :: nu
integer, intent(in) :: ph, en
character(len=*), intent(in) :: isotropic_bound
end function elastic_nu
@ -184,7 +184,7 @@ submodule(phase) mechanical
end interface
type :: tOutput !< requested output (per phase)
character(len=pStringLen), allocatable, dimension(:) :: &
character(len=pSTRLEN), allocatable, dimension(:) :: &
label
end type tOutput
type(tOutput), allocatable, dimension(:) :: output_mechanical
@ -243,20 +243,20 @@ module subroutine mechanical_init(phases)
allocate(phase_mechanical_Fi(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_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_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_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_S0(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_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_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_S0(ph)%data(3,3,Nmembers),source=0.0_pREAL)
phase => phases%get_dict(ph)
mech => phase%get_dict('mechanical')
#if defined(__GFORTRAN__)
output_mechanical(ph)%label = output_as1dString(mech)
output_mechanical(ph)%label = output_as1dStr(mech)
#else
output_mechanical(ph)%label = mech%get_as1dString('output',defaultVal=emptyStringArray)
output_mechanical(ph)%label = mech%get_as1dStr('output',defaultVal=emptyStrArray)
#endif
end do
@ -291,7 +291,7 @@ module subroutine mechanical_init(phases)
num_crystallite => config_numerics%get_dict('crystallite',defaultVal=emptyDict)
select case(num_crystallite%get_asString('integrator',defaultVal='FPI'))
select case(num_crystallite%get_asStr('integrator',defaultVal='FPI'))
case('FPI')
integrateState => integrateStateFPI
@ -359,11 +359,11 @@ end subroutine mechanical_result
!--------------------------------------------------------------------------------------------------
function integrateStress(F,subFp0,subFi0,Delta_t,ph,en) result(broken)
real(pReal), dimension(3,3), intent(in) :: F,subFp0,subFi0
real(pReal), intent(in) :: Delta_t
real(pREAL), dimension(3,3), intent(in) :: F,subFp0,subFi0
real(pREAL), intent(in) :: Delta_t
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_current, & ! inverse of Fp_current
Lpguess, & ! current guess for plastic velocity gradient
@ -386,11 +386,11 @@ function integrateStress(F,subFp0,subFi0,Delta_t,ph,en) result(broken)
A, &
B, &
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
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)
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, &
dFe_dLp, & ! partial derivative of elastic deformation gradient
dFe_dLi, &
@ -399,7 +399,7 @@ function integrateStress(F,subFp0,subFi0,Delta_t,ph,en) result(broken)
dLi_dFi, &
dLp_dS, &
dLi_dS
real(pReal) steplengthLp, &
real(pREAL) steplengthLp, &
steplengthLi, &
atol_Lp, &
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
jacoCounterLi = 0
steplengthLi = 1.0_pReal
residuumLi_old = 0.0_pReal
steplengthLi = 1.0_pREAL
residuumLi_old = 0.0_pREAL
Liguess_old = Liguess
NiterationStressLi = 0
@ -440,8 +440,8 @@ function integrateStress(F,subFp0,subFi0,Delta_t,ph,en) result(broken)
Fi_new = math_inv33(invFi_new)
jacoCounterLp = 0
steplengthLp = 1.0_pReal
residuumLp_old = 0.0_pReal
steplengthLp = 1.0_pREAL
residuumLp_old = 0.0_pREAL
Lpguess_old = Lpguess
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)...
residuumLp_old = residuumLp ! ...remember old values and...
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...
steplengthLp = num%subStepSizeLp * steplengthLp ! ...try with smaller step length in same direction
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)...
residuumLi_old = residuumLi ! ...remember old values and...
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...
steplengthLi = num%subStepSizeLi * steplengthLi ! ...try with smaller step length in same direction
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_Lp(ph)%data(1:3,1:3,en) = Lpguess
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_Fe(ph)%data(1:3,1:3,en) = matmul(matmul(F,invFp_new),invFi_new)
broken = .false.
@ -564,9 +564,9 @@ end function integrateStress
!--------------------------------------------------------------------------------------------------
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(:) :: subState0
real(pReal), intent(in) :: Delta_t
real(pREAL), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0
real(pREAL), intent(in),dimension(:) :: subState0
real(pREAL), intent(in) :: Delta_t
integer, intent(in) :: &
ph, &
en
@ -576,12 +576,12 @@ function integrateStateFPI(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(b
integer :: &
NiterationState, & !< number of iterations in state loop
sizeDotState
real(pReal) :: &
real(pREAL) :: &
zeta
real(pReal), dimension(plasticState(ph)%sizeDotState) :: &
real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
r, & ! state residuum
dotState
real(pReal), dimension(plasticState(ph)%sizeDotState,2) :: &
real(pREAL), dimension(plasticState(ph)%sizeDotState,2) :: &
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
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
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))
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) &
- subState0 &
- 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
!--------------------------------------------------------------------------------------------------
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
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_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
damper = 0.75_pReal + 0.25_pReal * tanh(2.0_pReal + 4.0_pReal * dot_prod12 / dot_prod22)
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)
else
damper = 1.0_pReal
damper = 1.0_pREAL
end if
end function damper
@ -652,16 +652,16 @@ end function integrateStateFPI
!--------------------------------------------------------------------------------------------------
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(:) :: subState0
real(pReal), intent(in) :: Delta_t
real(pREAL), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0
real(pREAL), intent(in),dimension(:) :: subState0
real(pREAL), intent(in) :: Delta_t
integer, intent(in) :: &
ph, &
en !< grain index in grain loop
logical :: &
broken
real(pReal), dimension(plasticState(ph)%sizeDotState) :: &
real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
dotState
integer :: &
sizeDotState
@ -692,9 +692,9 @@ end function integrateStateEuler
!--------------------------------------------------------------------------------------------------
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(:) :: subState0
real(pReal), intent(in) :: Delta_t
real(pREAL), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0
real(pREAL), intent(in),dimension(:) :: subState0
real(pREAL), intent(in) :: Delta_t
integer, intent(in) :: &
ph, &
en
@ -703,7 +703,7 @@ function integrateStateAdaptiveEuler(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en
integer :: &
sizeDotState
real(pReal), dimension(plasticState(ph)%sizeDotState) :: &
real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
r, &
dotState
@ -715,7 +715,7 @@ function integrateStateAdaptiveEuler(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en
sizeDotState = plasticState(ph)%sizeDotState
r = - dotState * 0.5_pReal * Delta_t
r = - dotState * 0.5_pREAL * Delta_t
#ifndef __INTEL_LLVM_COMPILER
plasticState(ph)%state(1:sizeDotState,en) = subState0 + dotState*Delta_t
#else
@ -731,7 +731,7 @@ function integrateStateAdaptiveEuler(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en
dotState = plastic_dotState(Delta_t,ph,en)
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)%atol(1:sizeDotState))
@ -743,22 +743,22 @@ end function integrateStateAdaptiveEuler
!---------------------------------------------------------------------------------------------------
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(:) :: subState0
real(pReal), intent(in) :: Delta_t
real(pREAL), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0
real(pREAL), intent(in),dimension(:) :: subState0
real(pREAL), intent(in) :: Delta_t
integer, intent(in) :: ph, en
logical :: broken
real(pReal), dimension(3,3), parameter :: &
real(pREAL), dimension(3,3), parameter :: &
A = reshape([&
0.5_pReal, 0.0_pReal, 0.0_pReal, &
0.0_pReal, 0.5_pReal, 0.0_pReal, &
0.0_pReal, 0.0_pReal, 1.0_pReal],&
0.5_pREAL, 0.0_pREAL, 0.0_pREAL, &
0.0_pREAL, 0.5_pREAL, 0.0_pREAL, &
0.0_pREAL, 0.0_pREAL, 1.0_pREAL],&
shape(A))
real(pReal), dimension(3), parameter :: &
C = [0.5_pReal, 0.5_pReal, 1.0_pReal]
real(pReal), dimension(4), parameter :: &
B = [6.0_pReal, 3.0_pReal, 3.0_pReal, 6.0_pReal]**(-1)
real(pREAL), dimension(3), parameter :: &
C = [0.5_pREAL, 0.5_pREAL, 1.0_pREAL]
real(pREAL), dimension(4), parameter :: &
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)
@ -771,29 +771,29 @@ end function integrateStateRK4
!---------------------------------------------------------------------------------------------------
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(:) :: subState0
real(pReal), intent(in) :: Delta_t
real(pREAL), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0
real(pREAL), intent(in),dimension(:) :: subState0
real(pREAL), intent(in) :: Delta_t
integer, intent(in) :: ph, en
logical :: broken
real(pReal), dimension(5,5), parameter :: &
real(pREAL), dimension(5,5), parameter :: &
A = reshape([&
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/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, &
1631._pReal/55296._pReal,175._pReal/512._pReal,575._pReal/13824._pReal,44275._pReal/110592._pReal,253._pReal/4096._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/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, &
1631._pREAL/55296._pREAL,175._pREAL/512._pREAL,575._pREAL/13824._pREAL,44275._pREAL/110592._pREAL,253._pREAL/4096._pREAL],&
shape(A))
real(pReal), dimension(5), parameter :: &
C = [0.2_pReal, 0.3_pReal, 0.6_pReal, 1.0_pReal, 0.875_pReal]
real(pReal), dimension(6), parameter :: &
real(pREAL), dimension(5), parameter :: &
C = [0.2_pREAL, 0.3_pREAL, 0.6_pREAL, 1.0_pREAL, 0.875_pREAL]
real(pREAL), dimension(6), parameter :: &
B = &
[37.0_pReal/378.0_pReal, .0_pReal, 250.0_pReal/621.0_pReal, &
125.0_pReal/594.0_pReal, .0_pReal, 512.0_pReal/1771.0_pReal], &
[37.0_pREAL/378.0_pREAL, .0_pREAL, 250.0_pREAL/621.0_pREAL, &
125.0_pREAL/594.0_pREAL, .0_pREAL, 512.0_pREAL/1771.0_pREAL], &
DB = B - &
[2825.0_pReal/27648.0_pReal, .0_pReal, 18575.0_pReal/48384.0_pReal,&
13525.0_pReal/55296.0_pReal, 277.0_pReal/14336.0_pReal, 1._pReal/4._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]
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)
real(pReal), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0
real(pReal), intent(in),dimension(:) :: subState0
real(pReal), intent(in) :: Delta_t
real(pReal), dimension(:,:), intent(in) :: A
real(pReal), dimension(:), intent(in) :: B, C
real(pReal), dimension(:), intent(in), optional :: DB
real(pREAL), intent(in),dimension(3,3) :: F_0,F,subFp0,subFi0
real(pREAL), intent(in),dimension(:) :: subState0
real(pREAL), intent(in) :: Delta_t
real(pREAL), dimension(:,:), intent(in) :: A
real(pREAL), dimension(:), intent(in) :: B, C
real(pREAL), dimension(:), intent(in), optional :: DB
integer, intent(in) :: &
ph, &
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
n, &
sizeDotState
real(pReal), dimension(plasticState(ph)%sizeDotState) :: &
real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
dotState
real(pReal), dimension(plasticState(ph)%sizeDotState,size(B)) :: &
real(pREAL), dimension(plasticState(ph)%sizeDotState,size(B)) :: &
plastic_RKdotState
@ -945,7 +945,7 @@ subroutine results(group,ph)
function to_quaternion(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
@ -986,26 +986,26 @@ end subroutine mechanical_forward
!--------------------------------------------------------------------------------------------------
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
logical :: converged_
real(pReal) :: &
real(pREAL) :: &
formerSubStep
integer :: &
ph, en, sizeDotState
logical :: todo
real(pReal) :: subFrac,subStep
real(pReal), dimension(3,3) :: &
real(pREAL) :: subFrac,subStep
real(pREAL), dimension(3,3) :: &
subFp0, &
subFi0, &
subLp0, &
subLi0, &
subF0, &
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)
@ -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)
subFi0 = phase_mechanical_Fi0(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.
subStep = 1.0_pReal/num%subStepSizeCryst
subStep = 1.0_pREAL/num%subStepSizeCryst
converged_ = .false. ! pretend failed step of 1/subStepSizeCryst
todo = .true.
@ -1028,9 +1028,9 @@ module function phase_mechanical_constitutive(Delta_t,co,ce) result(converged_)
if (converged_) then
formerSubStep = 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
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_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)
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_Li(ph)%data(1:3,1:3,en) = subLi0
end if
@ -1105,19 +1105,19 @@ end subroutine mechanical_restore
!--------------------------------------------------------------------------------------------------
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) :: &
co, & !< counter in constituent loop
ce
real(pReal), dimension(3,3,3,3) :: dPdF
real(pREAL), dimension(3,3,3,3) :: dPdF
integer :: &
o, &
p, ph, en
real(pReal), dimension(3,3) :: devNull, &
real(pREAL), dimension(3,3) :: devNull, &
invSubFp0,invSubFi0,invFp,invFi, &
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, &
dSdFi, &
dLidS, & ! tangent in lattice configuration
@ -1129,7 +1129,7 @@ module function phase_mechanical_dPdF(Delta_t,co,ce) result(dPdF)
rhs_3333, &
lhs_3333, &
temp_3333
real(pReal), dimension(9,9):: temp_99
real(pREAL), dimension(9,9):: temp_99
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))
if (sum(abs(dLidS)) < tol_math_check) then
dFidS = 0.0_pReal
dFidS = 0.0_pREAL
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
#ifndef __INTEL_LLVM_COMPILER
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
call IO_warning(600,'inversion error in analytic tangent calculation', &
label1='phase',ID1=ph,label2='entry',ID2=en)
dFidS = 0.0_pReal
dFidS = 0.0_pREAL
else
dFidS = math_mul3333xx3333(math_99to3333(temp_99),rhs_3333)
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_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
dPdF(p,1:3,p,1:3) = transpose(matmul(invFp,temp_33_1))
end do
@ -1283,7 +1283,7 @@ end subroutine mechanical_restartRead
module function mechanical_S(ph,en) result(S)
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)
@ -1297,7 +1297,7 @@ end function mechanical_S
module function mechanical_L_p(ph,en) result(L_p)
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)
@ -1311,7 +1311,7 @@ end function mechanical_L_p
module function mechanical_F_e(ph,en) result(F_e)
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)
@ -1325,7 +1325,7 @@ end function mechanical_F_e
module function mechanical_F_i(ph,en) result(F_i)
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)
@ -1339,7 +1339,7 @@ end function mechanical_F_i
module function phase_P(co,ce) result(P)
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))
@ -1353,7 +1353,7 @@ end function phase_P
module function phase_F(co,ce) result(F)
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))
@ -1366,7 +1366,7 @@ end function phase_F
!--------------------------------------------------------------------------------------------------
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

28
src/phase_mechanical_eigen.f90
View File

@ -20,9 +20,9 @@ submodule(phase:mechanical) eigen
module subroutine thermalexpansion_LiAndItsTangent(Li, dLi_dTstar, 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
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)
end subroutine thermalexpansion_LiAndItsTangent
@ -101,7 +101,7 @@ function kinematics_active(kinematics_label,kinematics_length) result(active_ki
kinematics => mechanics%get_list('eigen',defaultVal=emptyList)
do k = 1, kinematics%length
kinematic => kinematics%get_dict(k)
active_kinematics(k,ph) = kinematic%get_asString('type') == kinematics_label
active_kinematics(k,ph) = kinematic%get_asStr('type') == kinematics_label
end do
end do
@ -129,7 +129,7 @@ function kinematics_active2(kinematics_label) result(active_kinematics)
do ph = 1, phases%length
phase => phases%get_dict(ph)
kinematics_type => phase%get_dict('damage',defaultVal=emptyDict)
active_kinematics(ph) = kinematics_type%get_asString('type',defaultVal='n/a') == kinematics_label
active_kinematics(ph) = kinematics_type%get_asStr('type',defaultVal='n/a') == kinematics_label
end do
@ -145,32 +145,32 @@ module subroutine phase_LiAndItsTangents(Li, dLi_dS, dLi_dFi, &
integer, intent(in) :: &
ph,en
real(pReal), intent(in), dimension(3,3) :: &
real(pREAL), intent(in), dimension(3,3) :: &
S !< 2nd Piola-Kirchhoff stress
real(pReal), intent(in), dimension(3,3) :: &
real(pREAL), intent(in), dimension(3,3) :: &
Fi !< intermediate deformation gradient
real(pReal), intent(out), dimension(3,3) :: &
real(pREAL), intent(out), dimension(3,3) :: &
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_dFi
real(pReal), dimension(3,3) :: &
real(pREAL), dimension(3,3) :: &
my_Li, & !< intermediate velocity gradient
FiInv, &
temp_33
real(pReal), dimension(3,3,3,3) :: &
real(pREAL), dimension(3,3,3,3) :: &
my_dLi_dS
real(pReal) :: &
real(pREAL) :: &
detFi
integer :: &
k, i, j
logical :: active
active = .false.
Li = 0.0_pReal
dLi_dS = 0.0_pReal
dLi_dFi = 0.0_pReal
Li = 0.0_pREAL
dLi_dS = 0.0_pREAL
dLi_dFi = 0.0_pREAL
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)
integer, intent(in) :: ph, me
real(pReal), intent(out), dimension(3,3) :: &
real(pREAL), intent(out), dimension(3,3) :: &
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)
real(pReal) :: T, dot_T
real(pReal), dimension(3,3) :: Alpha
real(pREAL) :: T, dot_T
real(pREAL), dimension(3,3) :: Alpha
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)))
Alpha = 0.0_pReal
Alpha = 0.0_pREAL
Alpha(1,1) = prm%Alpha_11%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))
Li = dot_T * Alpha
end associate
dLi_dTstar = 0.0_pReal
dLi_dTstar = 0.0_pREAL
end subroutine thermalexpansion_LiAndItsTangent

30
src/phase_mechanical_elastic.f90
View File

@ -46,7 +46,7 @@ module subroutine elastic_init(phases)
print'(/,1x,a,i0,a)', 'phase ',ph,': '//phases%key(ph)
refs = config_listReferences(elastic,indent=3)
if (len(refs) > 0) print'(/,1x,a)', refs
if (elastic%get_asString('type') /= 'Hooke') call IO_error(200,ext_msg=elastic%get_asString('type'))
if (elastic%get_asStr('type') /= 'Hooke') call IO_error(200,ext_msg=elastic%get_asStr('type'))
associate(prm => param(ph))
@ -77,13 +77,13 @@ pure module function elastic_C66(ph,en) result(C66)
ph, &
en
real(pReal), dimension(6,6) :: C66
real(pReal) :: T
real(pREAL), dimension(6,6) :: C66
real(pREAL) :: T
associate(prm => param(ph))
C66 = 0.0_pReal
C66 = 0.0_pREAL
T = thermal_T(ph,en)
C66(1,1) = prm%C_11%at(T)
@ -113,7 +113,7 @@ pure module function elastic_mu(ph,en,isotropic_bound) result(mu)
ph, &
en
character(len=*), intent(in) :: isotropic_bound
real(pReal) :: &
real(pREAL) :: &
mu
@ -135,7 +135,7 @@ pure module function elastic_nu(ph,en,isotropic_bound) result(nu)
ph, &
en
character(len=*), intent(in) :: isotropic_bound
real(pReal) :: &
real(pREAL) :: &
nu
@ -160,18 +160,18 @@ module subroutine phase_hooke_SandItsTangents(S, dS_dFe, dS_dFi, &
integer, intent(in) :: &
ph, &
en
real(pReal), intent(in), dimension(3,3) :: &
real(pREAL), intent(in), dimension(3,3) :: &
Fe, & !< elastic 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
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_dFi !< derivative of 2nd P-K stress with respect to intermediate deformation gradient
real(pReal), dimension(3,3) :: E
real(pReal), dimension(6,6) :: C66
real(pReal), dimension(3,3,3,3) :: C
real(pREAL), dimension(3,3) :: E
real(pREAL), dimension(6,6) :: C66
real(pREAL), dimension(3,3,3,3) :: C
integer :: &
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)
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
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_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 subroutine phase_hooke_SandItsTangents
@ -195,7 +195,7 @@ end subroutine phase_hooke_SandItsTangents
!--------------------------------------------------------------------------------------------------
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

90
src/phase_mechanical_plastic.f90
View File

@ -38,11 +38,11 @@ submodule(phase:mechanical) plastic
end function plastic_nonlocal_init
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
real(pReal), dimension(3,3,3,3), intent(out) :: &
real(pREAL), dimension(3,3,3,3), intent(out) :: &
dLp_dMp
real(pReal), dimension(3,3), intent(in) :: &
real(pREAL), dimension(3,3), intent(in) :: &
Mp
integer, intent(in) :: &
ph, &
@ -50,11 +50,11 @@ submodule(phase:mechanical) plastic
end subroutine isotropic_LpAndItsTangent
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
real(pReal), dimension(3,3,3,3), intent(out) :: &
real(pREAL), dimension(3,3,3,3), intent(out) :: &
dLp_dMp
real(pReal), dimension(3,3), intent(in) :: &
real(pREAL), dimension(3,3), intent(in) :: &
Mp
integer, intent(in) :: &
ph, &
@ -62,11 +62,11 @@ submodule(phase:mechanical) plastic
end subroutine phenopowerlaw_LpAndItsTangent
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
real(pReal), dimension(3,3,3,3), intent(out) :: &
real(pREAL), dimension(3,3,3,3), intent(out) :: &
dLp_dMp
real(pReal), dimension(3,3), intent(in) :: &
real(pREAL), dimension(3,3), intent(in) :: &
Mp
integer, intent(in) :: &
ph, &
@ -74,11 +74,11 @@ submodule(phase:mechanical) plastic
end subroutine kinehardening_LpAndItsTangent
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
real(pReal), dimension(3,3,3,3), intent(out) :: &
real(pREAL), dimension(3,3,3,3), intent(out) :: &
dLp_dMp
real(pReal), dimension(3,3), intent(in) :: &
real(pREAL), dimension(3,3), intent(in) :: &
Mp
integer, intent(in) :: &
ph, &
@ -86,11 +86,11 @@ submodule(phase:mechanical) plastic
end subroutine dislotwin_LpAndItsTangent
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
real(pReal), dimension(3,3,3,3), intent(out) :: &
real(pREAL), dimension(3,3,3,3), intent(out) :: &
dLp_dMp
real(pReal), dimension(3,3), intent(in) :: &
real(pREAL), dimension(3,3), intent(in) :: &
Mp
integer, intent(in) :: &
ph, &
@ -98,11 +98,11 @@ submodule(phase:mechanical) plastic
end subroutine dislotungsten_LpAndItsTangent
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
real(pReal), dimension(3,3,3,3), intent(out) :: &
real(pREAL), dimension(3,3,3,3), intent(out) :: &
dLp_dMp
real(pReal), dimension(3,3), intent(in) :: &
real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress
integer, intent(in) :: &
ph, &
@ -111,59 +111,59 @@ submodule(phase:mechanical) plastic
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
integer, intent(in) :: &
ph, &
en
real(pReal), dimension(plasticState(ph)%sizeDotState) :: &
real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
dotState
end function isotropic_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
integer, intent(in) :: &
ph, &
en
real(pReal), dimension(plasticState(ph)%sizeDotState) :: &
real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
dotState
end function phenopowerlaw_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
integer, intent(in) :: &
ph, &
en
real(pReal), dimension(plasticState(ph)%sizeDotState) :: &
real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
dotState
end function plastic_kinehardening_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
integer, intent(in) :: &
ph, &
en
real(pReal), dimension(plasticState(ph)%sizeDotState) :: &
real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
dotState
end function dislotwin_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
integer, intent(in) :: &
ph, &
en
real(pReal), dimension(plasticState(ph)%sizeDotState) :: &
real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
dotState
end function dislotungsten_dotState
module subroutine nonlocal_dotState(Mp,timestep,ph,en)
real(pReal), dimension(3,3), intent(in) :: &
real(pREAL), dimension(3,3), intent(in) :: &
Mp !< MandelStress
real(pReal), intent(in) :: &
real(pREAL), intent(in) :: &
timestep !< substepped crystallite time increment
integer, intent(in) :: &
ph, &
@ -189,7 +189,7 @@ submodule(phase:mechanical) plastic
end subroutine nonlocal_dependentState
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
integer, intent(in) :: &
ph, &
@ -197,7 +197,7 @@ submodule(phase:mechanical) plastic
end subroutine plastic_kinehardening_deltaState
module subroutine plastic_nonlocal_deltaState(Mp,ph,en)
real(pReal), dimension(3,3), intent(in) :: &
real(pREAL), dimension(3,3), intent(in) :: &
Mp
integer, intent(in) :: &
ph, &
@ -234,27 +234,27 @@ module subroutine plastic_LpAndItsTangents(Lp, dLp_dS, dLp_dFi, &
S, Fi, ph,en)
integer, intent(in) :: &
ph,en
real(pReal), intent(in), dimension(3,3) :: &
real(pREAL), intent(in), dimension(3,3) :: &
S, & !< 2nd Piola-Kirchhoff stress
Fi !< intermediate deformation gradient
real(pReal), intent(out), dimension(3,3) :: &
real(pREAL), intent(out), dimension(3,3) :: &
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_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
real(pReal), dimension(3,3) :: &
real(pREAL), dimension(3,3) :: &
Mp !< Mandel stress work conjugate with Lp
integer :: &
i, j
if (phase_plasticity(ph) == PLASTIC_NONE_ID) then
Lp = 0.0_pReal
dLp_dFi = 0.0_pReal
dLp_dS = 0.0_pReal
Lp = 0.0_pREAL
dLp_dFi = 0.0_pREAL
dLp_dS = 0.0_pREAL
else
Mp = matmul(matmul(transpose(Fi),Fi),S)
@ -300,11 +300,11 @@ module function plastic_dotState(subdt,ph,en) result(dotState)
integer, intent(in) :: &
ph, &
en
real(pReal), intent(in) :: &
real(pREAL), intent(in) :: &
subdt !< timestep
real(pReal), dimension(3,3) :: &
real(pREAL), dimension(3,3) :: &
Mp
real(pReal), dimension(plasticState(ph)%sizeDotState) :: &
real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
dotState
@ -376,7 +376,7 @@ module function plastic_deltaState(ph, en) result(broken)
en
logical :: broken
real(pReal), dimension(3,3) :: &
real(pREAL), dimension(3,3) :: &
Mp
integer :: &
mySize
@ -434,7 +434,7 @@ function plastic_active(plastic_label) result(active_plastic)
phase => phases%get_dict(ph)
mech => phase%get_dict('mechanical')
pl => mech%get_dict('plastic',defaultVal = emptyDict)
active_plastic(ph) = pl%get_asString('type',defaultVal='none') == plastic_label
active_plastic(ph) = pl%get_asStr('type',defaultVal='none') == plastic_label
end do
end function plastic_active

194
src/phase_mechanical_plastic_dislotungsten.f90
View File

@ -8,11 +8,11 @@
submodule(phase:plastic) dislotungsten
type :: tParameters
real(pReal) :: &
D = 1.0_pReal, & !< grain size
D_0 = 1.0_pReal, & !< prefactor for self-diffusion coefficient
Q_cl = 1.0_pReal !< activation energy for dislocation climb
real(pReal), allocatable, dimension(:) :: &
real(pREAL) :: &
D = 1.0_pREAL, & !< grain size
D_0 = 1.0_pREAL, & !< prefactor for self-diffusion coefficient
Q_cl = 1.0_pREAL !< activation energy for dislocation climb
real(pREAL), allocatable, dimension(:) :: &
b_sl, & !< magnitude of Burgers vector [m]
d_caron, & !< distance of spontaneous annhihilation
i_sl, & !< Adj. parameter for distance between 2 forest dislocations
@ -26,10 +26,10 @@ submodule(phase:plastic) dislotungsten
h, & !< height of the kink pair
w, & !< width of the kink pair
omega !< attempt frequency for kink pair nucleation
real(pReal), allocatable, dimension(:,:) :: &
real(pREAL), allocatable, dimension(:,:) :: &
h_sl_sl, & !< slip resistance from slip activity
forestProjection
real(pReal), allocatable, dimension(:,:,:) :: &
real(pREAL), allocatable, dimension(:,:,:) :: &
P_sl, &
P_nS_pos, &
P_nS_neg
@ -37,7 +37,7 @@ submodule(phase:plastic) dislotungsten
sum_N_sl !< total number of active slip system
character(len=:), allocatable :: &
isotropic_bound
character(len=pStringLen), allocatable, dimension(:) :: &
character(len=pSTRLEN), allocatable, dimension(:) :: &
output
logical :: &
dipoleFormation !< flag indicating consideration of dipole formation
@ -53,14 +53,14 @@ submodule(phase:plastic) dislotungsten
end type tIndexDotState
type :: tDislotungstenState
real(pReal), dimension(:,:), pointer :: &
real(pREAL), dimension(:,:), pointer :: &
rho_mob, &
rho_dip, &
gamma_sl
end type tDislotungstenState
type :: tDislotungstenDependentState
real(pReal), dimension(:,:), allocatable :: &
real(pREAL), dimension(:,:), allocatable :: &
Lambda_sl, &
tau_pass
end type tDislotungstenDependentState
@ -89,7 +89,7 @@ module function plastic_dislotungsten_init() result(myPlasticity)
startIndex, endIndex
integer, dimension(:), allocatable :: &
N_sl
real(pReal),dimension(:), allocatable :: &
real(pREAL),dimension(:), allocatable :: &
rho_mob_0, & !< initial dislocation density
rho_dip_0, & !< initial dipole density
a !< non-Schmid coefficients
@ -135,12 +135,12 @@ module function plastic_dislotungsten_init() result(myPlasticity)
if (len(refs) > 0) print'(/,1x,a)', refs
#if defined (__GFORTRAN__)
prm%output = output_as1dString(pl)
prm%output = output_as1dStr(pl)
#else
prm%output = pl%get_as1dString('output',defaultVal=emptyStringArray)
prm%output = pl%get_as1dStr('output',defaultVal=emptyStrArray)
#endif
prm%isotropic_bound = pl%get_asString('isotropic_bound',defaultVal='isostrain')
prm%isotropic_bound = pl%get_asStr('isotropic_bound',defaultVal='isostrain')
!--------------------------------------------------------------------------------------------------
! slip related parameters
@ -151,7 +151,7 @@ module function plastic_dislotungsten_init() result(myPlasticity)
prm%P_sl = lattice_SchmidMatrix_slip(N_sl,phase_lattice(ph),phase_cOverA(ph))
if (phase_lattice(ph) == 'cI') then
a = pl%get_as1dFloat('a_nonSchmid',defaultVal = emptyRealArray)
a = pl%get_as1dReal('a_nonSchmid',defaultVal = emptyRealArray)
prm%P_nS_pos = lattice_nonSchmidMatrix(N_sl,a,+1)
prm%P_nS_neg = lattice_nonSchmidMatrix(N_sl,a,-1)
else
@ -159,30 +159,30 @@ module function plastic_dislotungsten_init() result(myPlasticity)
prm%P_nS_neg = prm%P_sl
end if
prm%h_sl_sl = lattice_interaction_SlipBySlip(N_sl,pl%get_as1dFloat('h_sl-sl'), &
prm%h_sl_sl = lattice_interaction_SlipBySlip(N_sl,pl%get_as1dReal('h_sl-sl'), &
phase_lattice(ph))
prm%forestProjection = lattice_forestProjection_edge(N_sl,phase_lattice(ph),&
phase_cOverA(ph))
prm%forestProjection = transpose(prm%forestProjection)
rho_mob_0 = pl%get_as1dFloat('rho_mob_0', requiredSize=size(N_sl))
rho_dip_0 = pl%get_as1dFloat('rho_dip_0', requiredSize=size(N_sl))
prm%b_sl = pl%get_as1dFloat('b_sl', requiredSize=size(N_sl))
prm%Q_s = pl%get_as1dFloat('Q_s', requiredSize=size(N_sl))
rho_mob_0 = pl%get_as1dReal('rho_mob_0', requiredSize=size(N_sl))
rho_dip_0 = pl%get_as1dReal('rho_dip_0', requiredSize=size(N_sl))
prm%b_sl = pl%get_as1dReal('b_sl', requiredSize=size(N_sl))
prm%Q_s = pl%get_as1dReal('Q_s', requiredSize=size(N_sl))
prm%i_sl = pl%get_as1dFloat('i_sl', requiredSize=size(N_sl))
prm%tau_Peierls = pl%get_as1dFloat('tau_Peierls', requiredSize=size(N_sl))
prm%p = pl%get_as1dFloat('p_sl', requiredSize=size(N_sl))
prm%q = pl%get_as1dFloat('q_sl', requiredSize=size(N_sl))
prm%h = pl%get_as1dFloat('h', requiredSize=size(N_sl))
prm%w = pl%get_as1dFloat('w', requiredSize=size(N_sl))
prm%omega = pl%get_as1dFloat('omega', requiredSize=size(N_sl))
prm%B = pl%get_as1dFloat('B', requiredSize=size(N_sl))
prm%i_sl = pl%get_as1dReal('i_sl', requiredSize=size(N_sl))
prm%tau_Peierls = pl%get_as1dReal('tau_Peierls', requiredSize=size(N_sl))
prm%p = pl%get_as1dReal('p_sl', requiredSize=size(N_sl))
prm%q = pl%get_as1dReal('q_sl', requiredSize=size(N_sl))
prm%h = pl%get_as1dReal('h', requiredSize=size(N_sl))
prm%w = pl%get_as1dReal('w', requiredSize=size(N_sl))
prm%omega = pl%get_as1dReal('omega', requiredSize=size(N_sl))
prm%B = pl%get_as1dReal('B', requiredSize=size(N_sl))
prm%D = pl%get_asFloat('D')
prm%D_0 = pl%get_asFloat('D_0')
prm%Q_cl = pl%get_asFloat('Q_cl')
prm%f_at = pl%get_asFloat('f_at') * prm%b_sl**3
prm%D = pl%get_asReal('D')
prm%D_0 = pl%get_asReal('D_0')
prm%Q_cl = pl%get_asReal('Q_cl')
prm%f_at = pl%get_asReal('f_at') * prm%b_sl**3
prm%dipoleformation = .not. pl%get_asBool('no_dipole_formation', defaultVal = .false.)
@ -200,19 +200,19 @@ module function plastic_dislotungsten_init() result(myPlasticity)
prm%B = math_expand(prm%B, N_sl)
prm%i_sl = math_expand(prm%i_sl, N_sl)
prm%f_at = math_expand(prm%f_at, N_sl)
prm%d_caron = pl%get_asFloat('D_a') * prm%b_sl
prm%d_caron = pl%get_asReal('D_a') * prm%b_sl
! sanity checks
if ( prm%D_0 < 0.0_pReal) extmsg = trim(extmsg)//' D_0'
if ( prm%Q_cl <= 0.0_pReal) extmsg = trim(extmsg)//' Q_cl'
if (any(rho_mob_0 < 0.0_pReal)) extmsg = trim(extmsg)//' rho_mob_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%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%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%f_at <= 0.0_pReal)) extmsg = trim(extmsg)//' f_at or b_sl'
if ( prm%D_0 < 0.0_pREAL) extmsg = trim(extmsg)//' D_0'
if ( prm%Q_cl <= 0.0_pREAL) extmsg = trim(extmsg)//' Q_cl'
if (any(rho_mob_0 < 0.0_pREAL)) extmsg = trim(extmsg)//' rho_mob_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%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%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%f_at <= 0.0_pREAL)) extmsg = trim(extmsg)//' f_at or b_sl'
else slipActive
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]
stt%rho_mob => plasticState(ph)%state(startIndex:endIndex,:)
stt%rho_mob = spread(rho_mob_0,2,Nmembers)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_rho',defaultVal=1.0_pReal)
if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_rho'
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'
startIndex = endIndex + 1
endIndex = endIndex + prm%sum_N_sl
idx_dot%rho_dip = [startIndex,endIndex]
stt%rho_dip => plasticState(ph)%state(startIndex:endIndex,:)
stt%rho_dip = spread(rho_dip_0,2,Nmembers)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_rho',defaultVal=1.0_pReal)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_rho',defaultVal=1.0_pREAL)
startIndex = endIndex + 1
endIndex = endIndex + prm%sum_N_sl
idx_dot%gamma_sl = [startIndex,endIndex]
stt%gamma_sl => plasticState(ph)%state(startIndex:endIndex,:)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_gamma',defaultVal=1.0e-6_pReal)
if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_gamma'
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'
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%Lambda_sl(prm%sum_N_sl,Nmembers), source=0.0_pREAL)
allocate(dst%tau_pass(prm%sum_N_sl,Nmembers), source=0.0_pREAL)
end associate
@ -275,11 +275,11 @@ end function plastic_dislotungsten_init
!--------------------------------------------------------------------------------------------------
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 !< 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
real(pReal), dimension(3,3), intent(in) :: &
real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress
integer, intent(in) :: &
ph, &
@ -287,16 +287,16 @@ pure module subroutine dislotungsten_LpAndItsTangent(Lp,dLp_dMp, &
integer :: &
i,k,l,m,n
real(pReal) :: &
real(pREAL) :: &
T !< temperature
real(pReal), dimension(param(ph)%sum_N_sl) :: &
real(pREAL), dimension(param(ph)%sum_N_sl) :: &
dot_gamma_pos,dot_gamma_neg, &
ddot_gamma_dtau_pos,ddot_gamma_dtau_neg
T = thermal_T(ph,en)
Lp = 0.0_pReal
dLp_dMp = 0.0_pReal
Lp = 0.0_pREAL
dLp_dMp = 0.0_pREAL
associate(prm => param(ph))
@ -319,15 +319,15 @@ end subroutine dislotungsten_LpAndItsTangent
!--------------------------------------------------------------------------------------------------
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
integer, intent(in) :: &
ph, &
en
real(pReal), dimension(plasticState(ph)%sizeDotState) :: &
real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
dotState
real(pReal), dimension(param(ph)%sum_N_sl) :: &
real(pREAL), dimension(param(ph)%sum_N_sl) :: &
dot_gamma_pos, dot_gamma_neg,&
tau_pos,&
tau_neg, &
@ -335,7 +335,7 @@ module function dislotungsten_dotState(Mp,ph,en) result(dotState)
dot_rho_dip_formation, &
dot_rho_dip_climb, &
d_hat
real(pReal) :: &
real(pREAL) :: &
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)
where(dEq0((tau_pos+tau_neg)*0.5_pReal))
dot_rho_dip_formation = 0.0_pReal
dot_rho_dip_climb = 0.0_pReal
where(dEq0((tau_pos+tau_neg)*0.5_pREAL))
dot_rho_dip_formation = 0.0_pREAL
dot_rho_dip_climb = 0.0_pREAL
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
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, &
0.0_pReal, &
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, &
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)) &
* (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?
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))
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
dot_rho_mob = dot_gamma_sl/(prm%b_sl*dst%Lambda_sl(:,en)) & ! multiplication
- 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 &
- (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
end associate
@ -389,7 +389,7 @@ module subroutine dislotungsten_dependentState(ph,en)
ph, &
en
real(pReal), dimension(param(ph)%sum_N_sl) :: &
real(pREAL), dimension(param(ph)%sum_N_sl) :: &
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 &
* 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
dst%Lambda_sl(:,en) = Lambda_sl_inv**(-1.0_pReal)
dst%Lambda_sl(:,en) = Lambda_sl_inv**(-1.0_pREAL)
end associate
@ -458,24 +458,24 @@ end subroutine plastic_dislotungsten_result
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)
real(pReal), dimension(3,3), intent(in) :: &
real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress
real(pReal), intent(in) :: &
real(pREAL), intent(in) :: &
T !< temperature
integer, intent(in) :: &
ph, &
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_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_neg, &
tau_pos_out, &
tau_neg_out
real(pReal), dimension(param(ph)%sum_N_sl) :: &
real(pREAL), dimension(param(ph)%sum_N_sl) :: &
StressRatio, &
StressRatio_p,StressRatio_pminus1, &
dvel, &
@ -495,7 +495,7 @@ pure subroutine kinetics(Mp,T,ph,en, &
if (present(tau_neg_out)) tau_neg_out = tau_neg
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)
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)
StressRatio = tau_eff/prm%tau_Peierls
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)
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)
else where significantPositiveTau
dot_gamma_pos = 0.0_pReal
dot_gamma_pos = 0.0_pREAL
end where significantPositiveTau
if (present(ddot_gamma_dtau_pos)) then
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
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
else where significantPositiveTau2
ddot_gamma_dtau_pos = 0.0_pReal
ddot_gamma_dtau_pos = 0.0_pREAL
end where significantPositiveTau2
end if
@ -533,28 +533,28 @@ pure subroutine kinetics(Mp,T,ph,en, &
significantNegativeTau: where(tau_eff > tol_math_check)
StressRatio = tau_eff/prm%tau_Peierls
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)
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)
else where significantNegativeTau
dot_gamma_neg = 0.0_pReal
dot_gamma_neg = 0.0_pREAL
end where significantNegativeTau
if (present(ddot_gamma_dtau_neg)) then
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
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
else where significantNegativeTau2
ddot_gamma_dtau_neg = 0.0_pReal
ddot_gamma_dtau_neg = 0.0_pREAL
end where significantNegativeTau2
end if

432
src/phase_mechanical_plastic_dislotwin.f90
View File

@ -9,31 +9,31 @@
!--------------------------------------------------------------------------------------------------
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
real(pReal) :: &
Q_cl = 1.0_pReal, & !< activation energy for dislocation climb
omega = 1.0_pReal, & !< frequency factor for dislocation climb
D = 1.0_pReal, & !< grain size
p_sb = 1.0_pReal, & !< p-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_tr = 1.0_pReal, & !< adjustment parameter to calculate MFP for transformation
L_tw = 1.0_pReal, & !< length of twin nuclei
L_tr = 1.0_pReal, & !< length of trans nuclei
x_c = 1.0_pReal, & !< critical distance for formation of twin/trans nucleus
V_cs = 1.0_pReal, & !< cross slip volume
tau_sb = 1.0_pReal, & !< value for shearband resistance
gamma_0_sb = 1.0_pReal, & !< value for shearband velocity_0
E_sb = 1.0_pReal, & !< activation energy for shear bands
h = 1.0_pReal, & !< stack height of hex nucleus
cOverA_hP = 1.0_pReal, &
V_mol = 1.0_pReal, &
rho = 1.0_pReal
real(pREAL) :: &
Q_cl = 1.0_pREAL, & !< activation energy for dislocation climb
omega = 1.0_pREAL, & !< frequency factor for dislocation climb
D = 1.0_pREAL, & !< grain size
p_sb = 1.0_pREAL, & !< p-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_tr = 1.0_pREAL, & !< adjustment parameter to calculate MFP for transformation
L_tw = 1.0_pREAL, & !< length of twin nuclei
L_tr = 1.0_pREAL, & !< length of trans nuclei
x_c = 1.0_pREAL, & !< critical distance for formation of twin/trans nucleus
V_cs = 1.0_pREAL, & !< cross slip volume
tau_sb = 1.0_pREAL, & !< value for shearband resistance
gamma_0_sb = 1.0_pREAL, & !< value for shearband velocity_0
E_sb = 1.0_pREAL, & !< activation energy for shear bands
h = 1.0_pREAL, & !< stack height of hex nucleus
cOverA_hP = 1.0_pREAL, &
V_mol = 1.0_pREAL, &
rho = 1.0_pREAL
type(tPolynomial) :: &
Gamma_sf, & !< stacking fault energy
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_tw, & !< absolute length of Burgers vector [m] for each twin 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
B, & !< drag coefficient
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_tw, & !< components of slip-twin 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
n0_sl, & !< slip system normal
forestProjection
real(pReal), allocatable, dimension(:,:,:) :: &
real(pREAL), allocatable, dimension(:,:,:) :: &
P_sl, &
P_tw, &
P_tr
@ -75,7 +75,7 @@ submodule(phase:plastic) dislotwin
character(len=:), allocatable :: &
lattice_tr, &
isotropic_bound
character(len=pStringLen), allocatable, dimension(:) :: &
character(len=pSTRLEN), allocatable, dimension(:) :: &
output
logical :: &
extendedDislocations, & !< consider split into partials for climb calculation
@ -96,7 +96,7 @@ submodule(phase:plastic) dislotwin
end type tIndexDotState
type :: tDislotwinState
real(pReal), dimension(:,:), pointer :: &
real(pREAL), dimension(:,:), pointer :: &
rho_mob, &
rho_dip, &
gamma_sl, &
@ -105,7 +105,7 @@ submodule(phase:plastic) dislotwin
end type tDislotwinState
type :: tDislotwinDependentState
real(pReal), dimension(:,:), allocatable :: &
real(pREAL), dimension(:,:), allocatable :: &
Lambda_sl, & !< mean free path between 2 obstacles seen by a moving dislocation
Lambda_tw, & !< mean free path between 2 obstacles seen by a growing twin
Lambda_tr, & !< mean free path between 2 obstacles seen by a growing martensite
@ -136,8 +136,8 @@ module function plastic_dislotwin_init() result(myPlasticity)
startIndex, endIndex
integer, dimension(:), allocatable :: &
N_sl
real(pReal) :: a_cF
real(pReal), allocatable, dimension(:) :: &
real(pREAL) :: a_cF
real(pREAL), allocatable, dimension(:) :: &
rho_mob_0, & !< initial unipolar dislocation density per slip system
rho_dip_0 !< initial dipole dislocation density per slip system
character(len=:), allocatable :: &
@ -188,12 +188,12 @@ module function plastic_dislotwin_init() result(myPlasticity)
if (len(refs) > 0) print'(/,1x,a)', refs
#if defined (__GFORTRAN__)
prm%output = output_as1dString(pl)
prm%output = output_as1dStr(pl)
#else
prm%output = pl%get_as1dString('output',defaultVal=emptyStringArray)
prm%output = pl%get_as1dStr('output',defaultVal=emptyStrArray)
#endif
prm%isotropic_bound = pl%get_asString('isotropic_bound',defaultVal='isostrain')
prm%isotropic_bound = pl%get_asStr('isotropic_bound',defaultVal='isostrain')
!--------------------------------------------------------------------------------------------------
! slip related parameters
@ -202,7 +202,7 @@ module function plastic_dislotwin_init() result(myPlasticity)
slipActive: if (prm%sum_N_sl > 0) then
prm%systems_sl = lattice_labels_slip(N_sl,phase_lattice(ph))
prm%P_sl = lattice_SchmidMatrix_slip(N_sl,phase_lattice(ph),phase_cOverA(ph))
prm%h_sl_sl = lattice_interaction_SlipBySlip(N_sl,pl%get_as1dFloat('h_sl-sl'),phase_lattice(ph))
prm%h_sl_sl = lattice_interaction_SlipBySlip(N_sl,pl%get_as1dReal('h_sl-sl'),phase_lattice(ph))
prm%forestProjection = lattice_forestProjection_edge(N_sl,phase_lattice(ph),phase_cOverA(ph))
prm%forestProjection = transpose(prm%forestProjection)
@ -210,27 +210,27 @@ module function plastic_dislotwin_init() result(myPlasticity)
prm%fccTwinTransNucleation = phase_lattice(ph) == 'cF' .and. (N_sl(1) == 12)
if (prm%fccTwinTransNucleation) prm%fcc_twinNucleationSlipPair = lattice_CF_TWINNUCLEATIONSLIPPAIR
rho_mob_0 = pl%get_as1dFloat('rho_mob_0', requiredSize=size(N_sl))
rho_dip_0 = pl%get_as1dFloat('rho_dip_0', requiredSize=size(N_sl))
prm%v_0 = pl%get_as1dFloat('v_0', requiredSize=size(N_sl))
prm%b_sl = pl%get_as1dFloat('b_sl', requiredSize=size(N_sl))
prm%Q_sl = pl%get_as1dFloat('Q_sl', requiredSize=size(N_sl))
prm%i_sl = pl%get_as1dFloat('i_sl', requiredSize=size(N_sl))
prm%p = pl%get_as1dFloat('p_sl', requiredSize=size(N_sl))
prm%q = pl%get_as1dFloat('q_sl', requiredSize=size(N_sl))
prm%tau_0 = pl%get_as1dFloat('tau_0', requiredSize=size(N_sl))
prm%B = pl%get_as1dFloat('B', requiredSize=size(N_sl), &
defaultVal=[(0.0_pReal, i=1,size(N_sl))])
rho_mob_0 = pl%get_as1dReal('rho_mob_0', requiredSize=size(N_sl))
rho_dip_0 = pl%get_as1dReal('rho_dip_0', requiredSize=size(N_sl))
prm%v_0 = pl%get_as1dReal('v_0', requiredSize=size(N_sl))
prm%b_sl = pl%get_as1dReal('b_sl', requiredSize=size(N_sl))
prm%Q_sl = pl%get_as1dReal('Q_sl', requiredSize=size(N_sl))
prm%i_sl = pl%get_as1dReal('i_sl', requiredSize=size(N_sl))
prm%p = pl%get_as1dReal('p_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%B = pl%get_as1dReal('B', requiredSize=size(N_sl), &
defaultVal=[(0.0_pREAL, i=1,size(N_sl))])
prm%Q_cl = pl%get_asFloat('Q_cl')
prm%Q_cl = pl%get_asReal('Q_cl')
prm%extendedDislocations = pl%get_asBool('extend_dislocations',defaultVal = .false.)
prm%omitDipoles = pl%get_asBool('omit_dipoles',defaultVal = .false.)
! multiplication factor according to crystal structure (nearest neighbors bcc vs fcc/hex)
! details: Argon & Moffat, Acta Metallurgica, Vol. 29, pg 293 to 299, 1981
prm%omega = pl%get_asFloat('omega', defaultVal = 1000.0_pReal) &
* merge(12.0_pReal,8.0_pReal,any(phase_lattice(ph) == ['cF','hP']))
prm%omega = pl%get_asReal('omega', defaultVal = 1000.0_pREAL) &
* merge(12.0_pREAL,8.0_pREAL,any(phase_lattice(ph) == ['cF','hP']))
! expand: family => system
rho_mob_0 = math_expand(rho_mob_0, N_sl)
@ -243,20 +243,20 @@ module function plastic_dislotwin_init() result(myPlasticity)
prm%q = math_expand(prm%q, N_sl)
prm%tau_0 = math_expand(prm%tau_0, N_sl)
prm%B = math_expand(prm%B, N_sl)
prm%d_caron = pl%get_asFloat('D_a') * prm%b_sl
prm%d_caron = pl%get_asReal('D_a') * prm%b_sl
! sanity checks
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_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%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%i_sl <= 0.0_pReal)) extmsg = trim(extmsg)//' i_sl'
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%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 ( 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_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%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%i_sl <= 0.0_pREAL)) extmsg = trim(extmsg)//' i_sl'
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%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'
else slipActive
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)
@ -270,15 +270,15 @@ module function plastic_dislotwin_init() result(myPlasticity)
twinActive: if (prm%sum_N_tw > 0) then
prm%systems_tw = lattice_labels_twin(prm%N_tw,phase_lattice(ph))
prm%P_tw = lattice_SchmidMatrix_twin(prm%N_tw,phase_lattice(ph),phase_cOverA(ph))
prm%h_tw_tw = lattice_interaction_TwinByTwin(prm%N_tw,pl%get_as1dFloat('h_tw-tw'), &
prm%h_tw_tw = lattice_interaction_TwinByTwin(prm%N_tw,pl%get_as1dReal('h_tw-tw'), &
phase_lattice(ph))
prm%b_tw = pl%get_as1dFloat('b_tw', requiredSize=size(prm%N_tw))
prm%t_tw = pl%get_as1dFloat('t_tw', requiredSize=size(prm%N_tw))
prm%r = pl%get_as1dFloat('p_tw', requiredSize=size(prm%N_tw))
prm%b_tw = pl%get_as1dReal('b_tw', requiredSize=size(prm%N_tw))
prm%t_tw = pl%get_as1dReal('t_tw', requiredSize=size(prm%N_tw))
prm%r = pl%get_as1dReal('p_tw', requiredSize=size(prm%N_tw))
prm%L_tw = pl%get_asFloat('L_tw')
prm%i_tw = pl%get_asFloat('i_tw')
prm%L_tw = pl%get_asReal('L_tw')
prm%i_tw = pl%get_asReal('i_tw')
prm%gamma_char_tw = lattice_characteristicShear_Twin(prm%N_tw,phase_lattice(ph),phase_cOverA(ph))
@ -289,11 +289,11 @@ module function plastic_dislotwin_init() result(myPlasticity)
! sanity checks
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%i_tw < 0.0_pReal) extmsg = trim(extmsg)//' i_tw'
if (any(prm%b_tw < 0.0_pReal)) extmsg = trim(extmsg)//' b_tw'
if (any(prm%t_tw < 0.0_pReal)) extmsg = trim(extmsg)//' t_tw'
if (any(prm%r < 0.0_pReal)) extmsg = trim(extmsg)//' p_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 (any(prm%b_tw < 0.0_pREAL)) extmsg = trim(extmsg)//' b_tw'
if (any(prm%t_tw < 0.0_pREAL)) extmsg = trim(extmsg)//' t_tw'
if (any(prm%r < 0.0_pREAL)) extmsg = trim(extmsg)//' p_tw'
else twinActive
allocate(prm%gamma_char_tw,prm%b_tw,prm%t_tw,prm%r,source=emptyRealArray)
allocate(prm%h_tw_tw(0,0))
@ -304,34 +304,34 @@ module function plastic_dislotwin_init() result(myPlasticity)
prm%N_tr = pl%get_as1dInt('N_tr', defaultVal=emptyIntArray)
prm%sum_N_tr = sum(abs(prm%N_tr))
transActive: if (prm%sum_N_tr > 0) then
prm%b_tr = pl%get_as1dFloat('b_tr')
prm%b_tr = pl%get_as1dReal('b_tr')
prm%b_tr = math_expand(prm%b_tr,prm%N_tr)
prm%i_tr = pl%get_asFloat('i_tr')
prm%i_tr = pl%get_asReal('i_tr')
prm%Delta_G = polynomial(pl,'Delta_G','T')
prm%L_tr = pl%get_asFloat('L_tr')
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%cOverA_hP = pl%get_asFloat('c/a_hP')
prm%rho = 4.0_pReal/(sqrt(3.0_pReal)*a_cF**2)/N_A
prm%V_mol = pl%get_asFloat('V_mol')
prm%h_tr_tr = lattice_interaction_TransByTrans(prm%N_tr,pl%get_as1dFloat('h_tr-tr'),&
prm%L_tr = pl%get_asReal('L_tr')
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%cOverA_hP = pl%get_asReal('c/a_hP')
prm%rho = 4.0_pREAL/(sqrt(3.0_pREAL)*a_cF**2)/N_A
prm%V_mol = pl%get_asReal('V_mol')
prm%h_tr_tr = lattice_interaction_TransByTrans(prm%N_tr,pl%get_as1dReal('h_tr-tr'),&
phase_lattice(ph))
prm%P_tr = lattice_SchmidMatrix_trans(prm%N_tr,'hP',prm%cOverA_hP)
prm%t_tr = pl%get_as1dFloat('t_tr')
prm%t_tr = pl%get_as1dReal('t_tr')
prm%t_tr = math_expand(prm%t_tr,prm%N_tr)
prm%s = pl%get_as1dFloat('p_tr')
prm%s = pl%get_as1dReal('p_tr')
prm%s = math_expand(prm%s,prm%N_tr)
! sanity checks
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%V_mol < 0.0_pReal) extmsg = trim(extmsg)//' V_mol'
if ( prm%i_tr < 0.0_pReal) extmsg = trim(extmsg)//' i_tr'
if (any(prm%t_tr < 0.0_pReal)) extmsg = trim(extmsg)//' t_tr'
if (any(prm%s < 0.0_pReal)) extmsg = trim(extmsg)//' p_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%i_tr < 0.0_pREAL) extmsg = trim(extmsg)//' i_tr'
if (any(prm%t_tr < 0.0_pREAL)) extmsg = trim(extmsg)//' t_tr'
if (any(prm%s < 0.0_pREAL)) extmsg = trim(extmsg)//' p_tr'
else transActive
allocate(prm%s,prm%b_tr,prm%t_tr,source=emptyRealArray)
allocate(prm%h_tr_tr(0,0))
@ -339,43 +339,43 @@ module function plastic_dislotwin_init() result(myPlasticity)
!--------------------------------------------------------------------------------------------------
! shearband related parameters
prm%gamma_0_sb = pl%get_asFloat('gamma_0_sb',defaultVal=0.0_pReal)
if (prm%gamma_0_sb > 0.0_pReal) then
prm%tau_sb = pl%get_asFloat('tau_sb')
prm%E_sb = pl%get_asFloat('Q_sb')
prm%p_sb = pl%get_asFloat('p_sb')
prm%q_sb = pl%get_asFloat('q_sb')
prm%gamma_0_sb = pl%get_asReal('gamma_0_sb',defaultVal=0.0_pREAL)
if (prm%gamma_0_sb > 0.0_pREAL) then
prm%tau_sb = pl%get_asReal('tau_sb')
prm%E_sb = pl%get_asReal('Q_sb')
prm%p_sb = pl%get_asReal('p_sb')
prm%q_sb = pl%get_asReal('q_sb')
! sanity checks
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%p_sb <= 0.0_pReal) extmsg = trim(extmsg)//' p_sb'
if (prm%q_sb <= 0.0_pReal) extmsg = trim(extmsg)//' q_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%p_sb <= 0.0_pREAL) extmsg = trim(extmsg)//' p_sb'
if (prm%q_sb <= 0.0_pREAL) extmsg = trim(extmsg)//' q_sb'
end if
!--------------------------------------------------------------------------------------------------
! parameters required for several mechanisms and their interactions
if (prm%sum_N_sl + prm%sum_N_tw + prm%sum_N_tw > 0) &
prm%D = pl%get_asFloat('D')
prm%D = pl%get_asReal('D')
if (prm%sum_N_tw + prm%sum_N_tr > 0) then
prm%x_c = pl%get_asFloat('x_c')
prm%V_cs = pl%get_asFloat('V_cs')
if (prm%x_c < 0.0_pReal) extmsg = trim(extmsg)//' x_c'
if (prm%V_cs < 0.0_pReal) extmsg = trim(extmsg)//' V_cs'
prm%x_c = pl%get_asReal('x_c')
prm%V_cs = pl%get_asReal('V_cs')
if (prm%x_c < 0.0_pREAL) extmsg = trim(extmsg)//' x_c'
if (prm%V_cs < 0.0_pREAL) extmsg = trim(extmsg)//' V_cs'
end if
if (prm%sum_N_tw + prm%sum_N_tr > 0 .or. prm%extendedDislocations) &
prm%Gamma_sf = polynomial(pl,'Gamma_sf','T')
slipAndTwinActive: if (prm%sum_N_sl * prm%sum_N_tw > 0) then
prm%h_sl_tw = lattice_interaction_SlipByTwin(N_sl,prm%N_tw,pl%get_as1dFloat('h_sl-tw'), &
prm%h_sl_tw = lattice_interaction_SlipByTwin(N_sl,prm%N_tw,pl%get_as1dReal('h_sl-tw'), &
phase_lattice(ph))
if (prm%fccTwinTransNucleation .and. size(prm%N_tw) /= 1) extmsg = trim(extmsg)//' N_tw: nucleation'
end if slipAndTwinActive
slipAndTransActive: if (prm%sum_N_sl * prm%sum_N_tr > 0) then
prm%h_sl_tr = lattice_interaction_SlipByTrans(N_sl,prm%N_tr,pl%get_as1dFloat('h_sl-tr'), &
prm%h_sl_tr = lattice_interaction_SlipByTrans(N_sl,prm%N_tr,pl%get_as1dReal('h_sl-tr'), &
phase_lattice(ph))
if (prm%fccTwinTransNucleation .and. size(prm%N_tr) /= 1) extmsg = trim(extmsg)//' N_tr: nucleation'
end if slipAndTransActive
@ -402,41 +402,41 @@ module function plastic_dislotwin_init() result(myPlasticity)
idx_dot%rho_mob = [startIndex,endIndex]
stt%rho_mob=>plasticState(ph)%state(startIndex:endIndex,:)
stt%rho_mob= spread(rho_mob_0,2,Nmembers)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_rho',defaultVal=1.0_pReal)
if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_rho'
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'
startIndex = endIndex + 1
endIndex = endIndex + prm%sum_N_sl
idx_dot%rho_dip = [startIndex,endIndex]
stt%rho_dip=>plasticState(ph)%state(startIndex:endIndex,:)
stt%rho_dip= spread(rho_dip_0,2,Nmembers)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_rho',defaultVal=1.0_pReal)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_rho',defaultVal=1.0_pREAL)
startIndex = endIndex + 1
endIndex = endIndex + prm%sum_N_sl
idx_dot%gamma_sl = [startIndex,endIndex]
stt%gamma_sl=>plasticState(ph)%state(startIndex:endIndex,:)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_gamma',defaultVal=1.0e-6_pReal)
if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_gamma'
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'
startIndex = endIndex + 1
endIndex = endIndex + prm%sum_N_tw
idx_dot%f_tw = [startIndex,endIndex]
stt%f_tw=>plasticState(ph)%state(startIndex:endIndex,:)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_f_tw',defaultVal=1.0e-6_pReal)
if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_f_tw'
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'
startIndex = endIndex + 1
endIndex = endIndex + prm%sum_N_tr
idx_dot%f_tr = [startIndex,endIndex]
stt%f_tr=>plasticState(ph)%state(startIndex:endIndex,:)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_f_tr',defaultVal=1.0e-6_pReal)
if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_f_tr'
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'
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_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%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_tw(prm%sum_N_tw,Nmembers),source=0.0_pREAL)
allocate(dst%Lambda_tr(prm%sum_N_tr,Nmembers),source=0.0_pREAL)
end associate
@ -456,21 +456,21 @@ module function plastic_dislotwin_homogenizedC(ph,en) result(homogenizedC)
integer, intent(in) :: &
ph, en
real(pReal), dimension(6,6) :: &
real(pREAL), dimension(6,6) :: &
homogenizedC, &
C
real(pReal), dimension(:,:,:), allocatable :: &
real(pREAL), dimension(:,:,:), allocatable :: &
C66_tw, &
C66_tr
integer :: i
real(pReal) :: f_matrix
real(pREAL) :: f_matrix
C = elastic_C66(ph,en)
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_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)
real(pReal), dimension(3,3), intent(out) :: Lp
real(pReal), dimension(3,3,3,3), intent(out) :: dLp_dMp
real(pReal), dimension(3,3), intent(in) :: Mp
real(pREAL), dimension(3,3), intent(out) :: Lp
real(pREAL), dimension(3,3,3,3), intent(out) :: dLp_dMp
real(pREAL), dimension(3,3), intent(in) :: Mp
integer, intent(in) :: ph,en
integer :: i,k,l,m,n
real(pReal) :: &
real(pREAL) :: &
f_matrix,StressRatio_p,&
E_kB_T, &
ddot_gamma_dtau, &
tau, &
T
real(pReal), dimension(param(ph)%sum_N_sl) :: &
real(pREAL), dimension(param(ph)%sum_N_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
real(pReal), dimension(param(ph)%sum_N_tr) :: &
real(pREAL), dimension(param(ph)%sum_N_tr) :: &
dot_gamma_tr,ddot_gamma_dtau_tr
real(pReal):: dot_gamma_sb
real(pReal), dimension(3,3) :: eigVectors, P_sb
real(pReal), dimension(3) :: eigValues
real(pReal), dimension(3,6), parameter :: &
real(pREAL):: dot_gamma_sb
real(pREAL), dimension(3,3) :: eigVectors, P_sb
real(pREAL), dimension(3) :: eigValues
real(pREAL), dimension(3,6), parameter :: &
sb_sComposition = &
reshape(real([&
1, 0, 1, &
@ -532,7 +532,7 @@ module subroutine dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en)
1,-1, 0, &
0, 1, 1, &
0, 1,-1 &
],pReal),[ 3,6]), &
],pREAL),[ 3,6]), &
sb_mComposition = &
reshape(real([&
1, 0,-1, &
@ -541,16 +541,16 @@ module subroutine dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en)
1, 1, 0, &
0, 1,-1, &
0, 1, 1 &
],pReal),[ 3,6])
],pREAL),[ 3,6])
T = thermal_T(ph,en)
Lp = 0.0_pReal
dLp_dMp = 0.0_pReal
Lp = 0.0_pREAL
dLp_dMp = 0.0_pREAL
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_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?
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)))
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
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 &
* (abs(tau)/prm%tau_sb)**(prm%p_sb-1.0_pReal) &
* (1.0_pReal-StressRatio_p)**(prm%q_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)
Lp = Lp + dot_gamma_sb * P_sb
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)
real(pReal), dimension(3,3), intent(in):: &
real(pREAL), dimension(3,3), intent(in):: &
Mp !< Mandel stress
integer, intent(in) :: &
ph, &
en
real(pReal), dimension(plasticState(ph)%sizeDotState) :: &
real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
dotState
integer :: i
real(pReal) :: &
real(pREAL) :: &
f_matrix, &
d_hat, &
v_cl, & !< climb velocity
tau, &
sigma_cl, & !< climb stress
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_climb, &
dot_gamma_sl
real(pReal), dimension(param(ph)%sum_N_tw) :: &
real(pREAL), dimension(param(ph)%sum_N_tw) :: &
dot_gamma_tw
real(pReal), dimension(param(ph)%sum_N_tr) :: &
real(pREAL), dimension(param(ph)%sum_N_tr) :: &
dot_gamma_tr
real(pReal) :: &
real(pREAL) :: &
mu, nu, &
T
@ -657,7 +657,7 @@ module function dislotwin_dotState(Mp,ph,en) result(dotState)
nu = elastic_nu(ph,en,prm%isotropic_bound)
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_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))
significantSlipStress: if (dEq0(tau) .or. prm%omitDipoles) then
dot_rho_dip_formation(i) = 0.0_pReal
dot_rho_dip_climb(i) = 0.0_pReal
dot_rho_dip_formation(i) = 0.0_pREAL
dot_rho_dip_climb(i) = 0.0_pREAL
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, 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)
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
! Argon & Moffat, Acta Metallurgica, Vol. 29, pg 293 to 299, 1981
sigma_cl = dot_product(prm%n0_sl(1:3,i),matmul(Mp,prm%n0_sl(1:3,i)))
if (prm%extendedDislocations) then
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
b_d = 1.0_pReal
b_d = 1.0_pREAL
end if
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)
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)
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))
end if
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_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 &
- 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
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, &
en
real(pReal) :: &
real(pREAL) :: &
sumf_tw, sumf_tr
real(pReal), dimension(param(ph)%sum_N_sl) :: &
real(pREAL), dimension(param(ph)%sum_N_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
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
f_over_t_tr
real(pReal) :: &
real(pREAL) :: &
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
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) &
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)
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)
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)
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)
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)
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)
!* 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)))
@ -834,22 +834,22 @@ end subroutine plastic_dislotwin_result
pure subroutine kinetics_sl(Mp,T,ph,en, &
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
real(pReal), intent(in) :: &
real(pREAL), intent(in) :: &
T !< temperature
integer, intent(in) :: &
ph, &
en
real(pReal), dimension(param(ph)%sum_N_sl), intent(out) :: &
real(pREAL), dimension(param(ph)%sum_N_sl), intent(out) :: &
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, &
tau_sl
real(pReal), dimension(param(ph)%sum_N_sl) :: &
real(pREAL), dimension(param(ph)%sum_N_sl) :: &
ddot_gamma_dtau
real(pReal), dimension(param(ph)%sum_N_sl) :: &
real(pREAL), dimension(param(ph)%sum_N_sl) :: &
tau, &
stressRatio, &
StressRatio_p, &
@ -873,23 +873,23 @@ pure subroutine kinetics_sl(Mp,T,ph,en, &
stressRatio = tau_eff/prm%tau_0
StressRatio_p = stressRatio** prm%p
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
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)
dV_wait_inverse_dTau = -1.0_pReal * v_wait_inverse * prm%p * prm%q * Q_kB_T &
* (stressRatio**(prm%p-1.0_pReal)) &
* (1.0_pReal-StressRatio_p)**(prm%q-1.0_pReal) &
dV_wait_inverse_dTau = -1.0_pREAL * v_wait_inverse * prm%p * prm%q * Q_kB_T &
* (stressRatio**(prm%p-1.0_pREAL)) &
* (1.0_pREAL-StressRatio_p)**(prm%q-1.0_pREAL) &
/ prm%tau_0
dV_run_inverse_dTau = -1.0_pReal * v_run_inverse/tau_eff
dV_dTau = -1.0_pReal * (dV_wait_inverse_dTau+dV_run_inverse_dTau) &
dV_run_inverse_dTau = -1.0_pREAL * v_run_inverse/tau_eff
dV_dTau = -1.0_pREAL * (dV_wait_inverse_dTau+dV_run_inverse_dTau) &
/ (v_wait_inverse+v_run_inverse)**2
ddot_gamma_dtau = dV_dTau*stt%rho_mob(:,en)*prm%b_sl
else where significantStress
dot_gamma_sl = 0.0_pReal
ddot_gamma_dtau = 0.0_pReal
dot_gamma_sl = 0.0_pREAL
ddot_gamma_dtau = 0.0_pREAL
end where significantStress
end associate
@ -910,21 +910,21 @@ end subroutine kinetics_sl
pure subroutine kinetics_tw(Mp,T,abs_dot_gamma_sl,ph,en,&
dot_gamma_tw,ddot_gamma_dtau_tw)
real(pReal), dimension(3,3), intent(in) :: &
real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress
real(pReal), intent(in) :: &
real(pREAL), intent(in) :: &
T !< temperature
integer, intent(in) :: &
ph, &
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
real(pReal), dimension(param(ph)%sum_N_tw), intent(out) :: &
real(pREAL), dimension(param(ph)%sum_N_tw), intent(out) :: &
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
real(pReal) :: &
real(pREAL) :: &
tau, tau_r, tau_hat, &
dot_N_0, &
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)
Gamma_sf = prm%Gamma_sf%at(T)
tau_hat = 3.0_pReal*prm%b_tw(1)*mu/prm%L_tw &
+ 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))
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_hat = 3.0_pREAL*prm%b_tw(1)*mu/prm%L_tw &
+ 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))
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
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
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))
dP_ncs_dtau = prm%V_cs / (K_B * T) * (P_ncs - 1.0_pReal)
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)
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)
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)
else
dot_gamma_tw(i) = 0.0_pReal
if (present(ddot_gamma_dtau_tw)) ddot_gamma_dtau_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
end if
end do
@ -986,21 +986,21 @@ end subroutine kinetics_tw
pure subroutine kinetics_tr(Mp,T,abs_dot_gamma_sl,ph,en,&
dot_gamma_tr,ddot_gamma_dtau_tr)
real(pReal), dimension(3,3), intent(in) :: &
real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress
real(pReal), intent(in) :: &
real(pREAL), intent(in) :: &
T !< temperature
integer, intent(in) :: &
ph, &
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
real(pReal), dimension(param(ph)%sum_N_tr), intent(out) :: &
real(pREAL), dimension(param(ph)%sum_N_tr), intent(out) :: &
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
real(pReal) :: &
real(pREAL) :: &
tau, tau_r, tau_hat, &
dot_N_0, &
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)
Gamma_sf = prm%Gamma_sf%at(T)
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))
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_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))
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)
do i = 1, prm%sum_N_tr
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
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))
dP_ncs_dtau = prm%V_cs / (K_B * T) * (P_ncs - 1.0_pReal)
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)
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
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
else
dot_gamma_tr(i) = 0.0_pReal
if (present(ddot_gamma_dtau_tr)) ddot_gamma_dtau_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
end if
end do

112
src/phase_mechanical_plastic_isotropic.f90
View File

@ -10,7 +10,7 @@
submodule(phase:plastic) isotropic
type :: tParameters
real(pReal) :: &
real(pREAL) :: &
M, & !< Taylor factor
dot_gamma_0, & !< reference strain rate
n, & !< stress exponent
@ -25,12 +25,12 @@ submodule(phase:plastic) isotropic
c_2
logical :: &
dilatation
character(len=pStringLen), allocatable, dimension(:) :: &
character(len=pSTRLEN), allocatable, dimension(:) :: &
output
end type tParameters
type :: tIsotropicState
real(pReal), pointer, dimension(:) :: &
real(pREAL), pointer, dimension(:) :: &
xi
end type tIsotropicState
@ -52,7 +52,7 @@ module function plastic_isotropic_init() result(myPlasticity)
ph, &
Nmembers, &
sizeState, sizeDotState
real(pReal) :: &
real(pREAL) :: &
xi_0 !< initial critical stress
character(len=:), allocatable :: &
refs, &
@ -93,34 +93,34 @@ module function plastic_isotropic_init() result(myPlasticity)
if (len(refs) > 0) print'(/,1x,a)', refs
#if defined (__GFORTRAN__)
prm%output = output_as1dString(pl)
prm%output = output_as1dStr(pl)
#else
prm%output = pl%get_as1dString('output',defaultVal=emptyStringArray)
prm%output = pl%get_as1dStr('output',defaultVal=emptyStrArray)
#endif
xi_0 = pl%get_asFloat('xi_0')
prm%xi_inf = pl%get_asFloat('xi_inf')
prm%dot_gamma_0 = pl%get_asFloat('dot_gamma_0')
prm%n = pl%get_asFloat('n')
prm%h_0 = pl%get_asFloat('h_0')
prm%h = pl%get_asFloat('h', defaultVal=3.0_pReal) ! match for fcc random polycrystal
prm%M = pl%get_asFloat('M')
prm%h_ln = pl%get_asFloat('h_ln', defaultVal=0.0_pReal)
prm%c_1 = pl%get_asFloat('c_1', defaultVal=0.0_pReal)
prm%c_4 = pl%get_asFloat('c_4', defaultVal=0.0_pReal)
prm%c_3 = pl%get_asFloat('c_3', defaultVal=0.0_pReal)
prm%c_2 = pl%get_asFloat('c_2', defaultVal=0.0_pReal)
prm%a = pl%get_asFloat('a')
xi_0 = pl%get_asReal('xi_0')
prm%xi_inf = pl%get_asReal('xi_inf')
prm%dot_gamma_0 = pl%get_asReal('dot_gamma_0')
prm%n = pl%get_asReal('n')
prm%h_0 = pl%get_asReal('h_0')
prm%h = pl%get_asReal('h', defaultVal=3.0_pREAL) ! match for fcc random polycrystal
prm%M = pl%get_asReal('M')
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_4 = pl%get_asReal('c_4', 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%a = pl%get_asReal('a')
prm%dilatation = pl%get_asBool('dilatation',defaultVal = .false.)
!--------------------------------------------------------------------------------------------------
! sanity checks
if (xi_0 < 0.0_pReal) extmsg = trim(extmsg)//' xi_0'
if (prm%dot_gamma_0 <= 0.0_pReal) extmsg = trim(extmsg)//' dot_gamma_0'
if (prm%n <= 0.0_pReal) extmsg = trim(extmsg)//' n'
if (prm%a <= 0.0_pReal) extmsg = trim(extmsg)//' a'
if (prm%M <= 0.0_pReal) extmsg = trim(extmsg)//' M'
if (xi_0 < 0.0_pREAL) extmsg = trim(extmsg)//' xi_0'
if (prm%dot_gamma_0 <= 0.0_pREAL) extmsg = trim(extmsg)//' dot_gamma_0'
if (prm%n <= 0.0_pREAL) extmsg = trim(extmsg)//' n'
if (prm%a <= 0.0_pREAL) extmsg = trim(extmsg)//' a'
if (prm%M <= 0.0_pREAL) extmsg = trim(extmsg)//' M'
!--------------------------------------------------------------------------------------------------
! allocate state arrays
@ -135,8 +135,8 @@ module function plastic_isotropic_init() result(myPlasticity)
! state aliases and initialization
stt%xi => plasticState(ph)%state(1,:)
stt%xi = xi_0
plasticState(ph)%atol(1) = pl%get_asFloat('atol_xi',defaultVal=1.0_pReal)
if (plasticState(ph)%atol(1) < 0.0_pReal) extmsg = trim(extmsg)//' atol_xi'
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'
end associate
@ -154,20 +154,20 @@ end function plastic_isotropic_init
!--------------------------------------------------------------------------------------------------
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
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
real(pReal), dimension(3,3), intent(in) :: &
real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress
integer, intent(in) :: &
ph, &
en
real(pReal), dimension(3,3) :: &
real(pREAL), dimension(3,3) :: &
Mp_dev !< deviatoric part of the Mandel stress
real(pReal) :: &
real(pREAL) :: &
dot_gamma, & !< strainrate
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
@ -181,20 +181,20 @@ module subroutine isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en)
squarenorm_Mp_dev = math_tensordot(Mp_dev,Mp_dev)
norm_Mp_dev = sqrt(squarenorm_Mp_dev)
if (norm_Mp_dev > 0.0_pReal) then
dot_gamma = prm%dot_gamma_0 * (sqrt(1.5_pReal) * norm_Mp_dev/(prm%M*stt%xi(en)))**prm%n
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
Lp = dot_gamma * Mp_dev/norm_Mp_dev
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) &
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) &
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
else
Lp = 0.0_pReal
dLp_dMp = 0.0_pReal
Lp = 0.0_pREAL
dLp_dMp = 0.0_pREAL
end if
end associate
@ -207,18 +207,18 @@ end subroutine isotropic_LpAndItsTangent
!--------------------------------------------------------------------------------------------------
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
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
real(pReal), dimension(3,3), intent(in) :: &
real(pREAL), dimension(3,3), intent(in) :: &
Mi !< Mandel stress
integer, intent(in) :: &
ph, &
en
real(pReal) :: &
real(pREAL) :: &
tr !< trace of spherical part of Mandel stress (= 3 x pressure)
integer :: &
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))
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 &
* prm%dot_gamma_0 * (3.0_pReal*prm%M*stt%xi(en))**(-prm%n) &
* tr * abs(tr)**(prm%n-1.0_pReal)
* prm%dot_gamma_0 * (3.0_pREAL*prm%M*stt%xi(en))**(-prm%n) &
* 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)
else
Li = 0.0_pReal
dLi_dMi = 0.0_pReal
Li = 0.0_pREAL
dLi_dMi = 0.0_pREAL
end if
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)
real(pReal), dimension(3,3), intent(in) :: &
real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress
integer, intent(in) :: &
ph, &
en
real(pReal), dimension(plasticState(ph)%sizeDotState) :: &
real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
dotState
real(pReal) :: &
real(pREAL) :: &
dot_gamma, & !< strainrate
xi_inf_star, & !< saturation xi
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))), &
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
xi_inf_star = prm%xi_inf
else
xi_inf_star = prm%xi_inf &
+ asinh( (dot_gamma / prm%c_1)**(1.0_pReal / prm%c_2))**(1.0_pReal / prm%c_3) &
/ prm%c_4 * (dot_gamma / prm%dot_gamma_0)**(1.0_pReal / prm%n)
+ 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)
end if
dot_xi = 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
dot_xi = 0.0_pReal
dot_xi = 0.0_pREAL
end if
end associate

126
src/phase_mechanical_plastic_kinehardening.f90
View File

@ -8,10 +8,10 @@
submodule(phase:plastic) kinehardening
type :: tParameters
real(pReal) :: &
n = 1.0_pReal, & !< stress exponent for slip
dot_gamma_0 = 1.0_pReal !< reference shear strain rate for slip
real(pReal), allocatable, dimension(:) :: &
real(pREAL) :: &
n = 1.0_pREAL, & !< stress exponent for slip
dot_gamma_0 = 1.0_pREAL !< reference shear strain rate for slip
real(pREAL), allocatable, dimension(:) :: &
h_0_xi, & !< initial hardening rate of forest stress per slip family
!! θ_0,for
h_0_chi, & !< initial hardening rate of back stress per slip family
@ -22,9 +22,9 @@ submodule(phase:plastic) kinehardening
!! θ_1,bs
xi_inf, & !< back-extrapolated forest 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
real(pReal), allocatable, dimension(:,:,:) :: &
real(pREAL), allocatable, dimension(:,:,:) :: &
P, &
P_nS_pos, &
P_nS_neg
@ -32,7 +32,7 @@ submodule(phase:plastic) kinehardening
sum_N_sl
logical :: &
nonSchmidActive = .false.
character(len=pStringLen), allocatable, dimension(:) :: &
character(len=pSTRLEN), allocatable, dimension(:) :: &
output
character(len=:), allocatable, dimension(:) :: &
systems_sl
@ -46,7 +46,7 @@ submodule(phase:plastic) kinehardening
end type tIndexDotState
type :: tKinehardeningState
real(pReal), pointer, dimension(:,:) :: &
real(pREAL), pointer, dimension(:,:) :: &
xi, & !< forest stress
!! τ_for
chi, & !< back stress
@ -82,7 +82,7 @@ module function plastic_kinehardening_init() result(myPlasticity)
startIndex, endIndex
integer, dimension(:), allocatable :: &
N_sl
real(pReal), dimension(:), allocatable :: &
real(pREAL), dimension(:), allocatable :: &
xi_0, & !< initial forest stress
!! τ_for,0
a !< non-Schmid coefficients
@ -128,9 +128,9 @@ module function plastic_kinehardening_init() result(myPlasticity)
if (len(refs) > 0) print'(/,1x,a)', refs
#if defined (__GFORTRAN__)
prm%output = output_as1dString(pl)
prm%output = output_as1dStr(pl)
#else
prm%output = pl%get_as1dString('output',defaultVal=emptyStringArray)
prm%output = pl%get_as1dStr('output',defaultVal=emptyStrArray)
#endif
!--------------------------------------------------------------------------------------------------
@ -142,7 +142,7 @@ module function plastic_kinehardening_init() result(myPlasticity)
prm%P = lattice_SchmidMatrix_slip(N_sl,phase_lattice(ph),phase_cOverA(ph))
if (phase_lattice(ph) == 'cI') then
a = pl%get_as1dFloat('a_nonSchmid',defaultVal=emptyRealArray)
a = pl%get_as1dReal('a_nonSchmid',defaultVal=emptyRealArray)
prm%nonSchmidActive = size(a) > 0
prm%P_nS_pos = lattice_nonSchmidMatrix(N_sl,a,+1)
prm%P_nS_neg = lattice_nonSchmidMatrix(N_sl,a,-1)
@ -150,19 +150,19 @@ module function plastic_kinehardening_init() result(myPlasticity)
prm%P_nS_pos = prm%P
prm%P_nS_neg = prm%P
end if
prm%h_sl_sl = lattice_interaction_SlipBySlip(N_sl,pl%get_as1dFloat('h_sl-sl'), &
prm%h_sl_sl = lattice_interaction_SlipBySlip(N_sl,pl%get_as1dReal('h_sl-sl'), &
phase_lattice(ph))
xi_0 = pl%get_as1dFloat('xi_0', requiredSize=size(N_sl))
prm%xi_inf = pl%get_as1dFloat('xi_inf', requiredSize=size(N_sl))
prm%chi_inf = pl%get_as1dFloat('chi_inf', requiredSize=size(N_sl))
prm%h_0_xi = pl%get_as1dFloat('h_0_xi', requiredSize=size(N_sl))
prm%h_0_chi = pl%get_as1dFloat('h_0_chi', requiredSize=size(N_sl))
prm%h_inf_xi = pl%get_as1dFloat('h_inf_xi', requiredSize=size(N_sl))
prm%h_inf_chi = pl%get_as1dFloat('h_inf_chi', requiredSize=size(N_sl))
xi_0 = pl%get_as1dReal('xi_0', requiredSize=size(N_sl))
prm%xi_inf = pl%get_as1dReal('xi_inf', requiredSize=size(N_sl))
prm%chi_inf = pl%get_as1dReal('chi_inf', requiredSize=size(N_sl))
prm%h_0_xi = pl%get_as1dReal('h_0_xi', requiredSize=size(N_sl))
prm%h_0_chi = pl%get_as1dReal('h_0_chi', requiredSize=size(N_sl))
prm%h_inf_xi = pl%get_as1dReal('h_inf_xi', requiredSize=size(N_sl))
prm%h_inf_chi = pl%get_as1dReal('h_inf_chi', requiredSize=size(N_sl))
prm%dot_gamma_0 = pl%get_asFloat('dot_gamma_0')
prm%n = pl%get_asFloat('n')
prm%dot_gamma_0 = pl%get_asReal('dot_gamma_0')
prm%n = pl%get_asReal('n')
! expand: family => system
xi_0 = math_expand(xi_0, N_sl)
@ -175,11 +175,11 @@ module function plastic_kinehardening_init() result(myPlasticity)
!--------------------------------------------------------------------------------------------------
! sanity checks
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 (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%chi_inf <= 0.0_pReal)) extmsg = trim(extmsg)//' chi_inf'
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 (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%chi_inf <= 0.0_pREAL)) extmsg = trim(extmsg)//' chi_inf'
else slipActive
xi_0 = emptyRealArray
@ -208,21 +208,21 @@ module function plastic_kinehardening_init() result(myPlasticity)
idx_dot%xi = [startIndex,endIndex]
stt%xi => plasticState(ph)%state(startIndex:endIndex,:)
stt%xi = spread(xi_0, 2, Nmembers)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_xi',defaultVal=1.0_pReal)
if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_xi'
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'
startIndex = endIndex + 1
endIndex = endIndex + prm%sum_N_sl
idx_dot%chi = [startIndex,endIndex]
stt%chi => plasticState(ph)%state(startIndex:endIndex,:)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_xi',defaultVal=1.0_pReal)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_xi',defaultVal=1.0_pREAL)
startIndex = endIndex + 1
endIndex = endIndex + prm%sum_N_sl
idx_dot%gamma = [startIndex,endIndex]
stt%gamma => plasticState(ph)%state(startIndex:endIndex,:)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_gamma',defaultVal=1.0e-6_pReal)
if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_gamma'
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'
o = plasticState(ph)%offsetDeltaState
startIndex = endIndex + 1
@ -257,12 +257,12 @@ end function plastic_kinehardening_init
!--------------------------------------------------------------------------------------------------
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
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
real(pReal), dimension(3,3), intent(in) :: &
real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress
integer, intent(in) :: &
ph, &
@ -270,12 +270,12 @@ pure module subroutine kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en)
integer :: &
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, &
ddot_gamma_dtau_pos,ddot_gamma_dtau_neg
Lp = 0.0_pReal
dLp_dMp = 0.0_pReal
Lp = 0.0_pREAL
dLp_dMp = 0.0_pREAL
associate(prm => param(ph))
@ -299,17 +299,17 @@ end subroutine kinehardening_LpAndItsTangent
!--------------------------------------------------------------------------------------------------
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
integer, intent(in) :: &
ph, &
en
real(pReal), dimension(plasticState(ph)%sizeDotState) :: &
real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
dotState
real(pReal) :: &
real(pREAL) :: &
sumGamma
real(pReal), dimension(param(ph)%sum_N_sl) :: &
real(pREAL), dimension(param(ph)%sum_N_sl) :: &
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) &
* ( prm%h_inf_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) &
)
dot_chi = stt%sgn_gamma(:,en)*dot_gamma &
* ( prm%h_inf_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))) &
)
@ -347,13 +347,13 @@ end function plastic_kinehardening_dotState
!--------------------------------------------------------------------------------------------------
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
integer, intent(in) :: &
ph, &
en
real(pReal), dimension(param(ph)%sum_N_sl) :: &
real(pREAL), dimension(param(ph)%sum_N_sl) :: &
dot_gamma_pos,dot_gamma_neg, &
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)
sgn_gamma = merge(state(ph)%sgn_gamma(:,en), &
sign(1.0_pReal,dot_gamma_pos+dot_gamma_neg), &
dEq0(dot_gamma_pos+dot_gamma_neg,1e-10_pReal))
sign(1.0_pREAL,dot_gamma_pos+dot_gamma_neg), &
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%chi_flip (:,en) = abs(stt%chi (:,en)) - stt%chi_flip (:,en)
dlt%gamma_flip(:,en) = stt%gamma(:,en) - stt%gamma_flip(:,en)
else where
dlt%sgn_gamma (:,en) = 0.0_pReal
dlt%chi_flip (:,en) = 0.0_pReal
dlt%gamma_flip(:,en) = 0.0_pReal
dlt%sgn_gamma (:,en) = 0.0_pREAL
dlt%chi_flip (:,en) = 0.0_pREAL
dlt%gamma_flip(:,en) = 0.0_pREAL
end where
end associate
@ -434,20 +434,20 @@ end subroutine plastic_kinehardening_result
pure subroutine kinetics(Mp,ph,en, &
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
integer, intent(in) :: &
ph, &
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_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_neg
real(pReal), dimension(param(ph)%sum_N_sl) :: &
real(pREAL), dimension(param(ph)%sum_N_sl) :: &
tau_pos, &
tau_neg
integer :: i
@ -458,35 +458,35 @@ pure subroutine kinetics(Mp,ph,en, &
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_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
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)
else where
dot_gamma_pos = 0.0_pReal
dot_gamma_pos = 0.0_pREAL
end where
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)
else where
dot_gamma_neg = 0.0_pReal
dot_gamma_neg = 0.0_pREAL
end where
if (present(ddot_gamma_dtau_pos)) then
where(dNeq0(dot_gamma_pos))
ddot_gamma_dtau_pos = dot_gamma_pos*prm%n/tau_pos
else where
ddot_gamma_dtau_pos = 0.0_pReal
ddot_gamma_dtau_pos = 0.0_pREAL
end where
end if
if (present(ddot_gamma_dtau_neg)) then
where(dNeq0(dot_gamma_neg))
ddot_gamma_dtau_neg = dot_gamma_neg*prm%n/tau_neg
else where
ddot_gamma_dtau_neg = 0.0_pReal
ddot_gamma_dtau_neg = 0.0_pREAL
end where
end if

534
src/phase_mechanical_plastic_nonlocal.f90
View File

File diff suppressed because it is too large Load Diff

184
src/phase_mechanical_plastic_phenopowerlaw.f90
View File

@ -7,30 +7,30 @@
submodule(phase:plastic) phenopowerlaw
type :: tParameters
real(pReal) :: &
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
n_sl = 1.0_pReal, & !< stress exponent for slip
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
c_1 = 1.0_pReal, &
c_2 = 1.0_pReal, &
c_3 = 1.0_pReal, &
c_4 = 1.0_pReal, &
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_tw = 1.0_pReal, & !< reference hardening twin - twin
a_sl = 1.0_pReal
real(pReal), allocatable, dimension(:) :: &
real(pREAL) :: &
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
n_sl = 1.0_pREAL, & !< stress exponent for slip
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
c_1 = 1.0_pREAL, &
c_2 = 1.0_pREAL, &
c_3 = 1.0_pREAL, &
c_4 = 1.0_pREAL, &
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_tw = 1.0_pREAL, & !< reference hardening twin - twin
a_sl = 1.0_pREAL
real(pREAL), allocatable, dimension(:) :: &
xi_inf_sl, & !< maximum critical shear stress for slip
h_int, & !< per family hardening activity (optional)
gamma_char !< characteristic shear for twins
real(pReal), allocatable, dimension(:,:) :: &
real(pREAL), allocatable, dimension(:,:) :: &
h_sl_sl, & !< slip resistance from slip activity
h_sl_tw, & !< slip resistance from twin activity
h_tw_sl, & !< twin resistance from slip activity
h_tw_tw !< twin resistance from twin activity
real(pReal), allocatable, dimension(:,:,:) :: &
real(pREAL), allocatable, dimension(:,:,:) :: &
P_sl, &
P_tw, &
P_nS_pos, &
@ -40,7 +40,7 @@ submodule(phase:plastic) phenopowerlaw
sum_N_tw !< total number of active twin systems
logical :: &
nonSchmidActive = .false.
character(len=pStringLen), allocatable, dimension(:) :: &
character(len=pSTRLEN), allocatable, dimension(:) :: &
output
character(len=:), allocatable, dimension(:) :: &
systems_sl, &
@ -56,7 +56,7 @@ submodule(phase:plastic) phenopowerlaw
end type tIndexDotState
type :: tPhenopowerlawState
real(pReal), pointer, dimension(:,:) :: &
real(pREAL), pointer, dimension(:,:) :: &
xi_sl, &
xi_tw, &
gamma_sl, &
@ -87,7 +87,7 @@ module function plastic_phenopowerlaw_init() result(myPlasticity)
integer, dimension(:), allocatable :: &
N_sl, & !< number of slip-systems for a given slip 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_tw, & !< initial critical shear stress for twin
a !< non-Schmid coefficients
@ -129,9 +129,9 @@ module function plastic_phenopowerlaw_init() result(myPlasticity)
if (len(refs) > 0) print'(/,1x,a)', refs
#if defined (__GFORTRAN__)
prm%output = output_as1dString(pl)
prm%output = output_as1dStr(pl)
#else
prm%output = pl%get_as1dString('output',defaultVal=emptyStringArray)
prm%output = pl%get_as1dStr('output',defaultVal=emptyStrArray)
#endif
!--------------------------------------------------------------------------------------------------
@ -143,7 +143,7 @@ module function plastic_phenopowerlaw_init() result(myPlasticity)
prm%P_sl = lattice_SchmidMatrix_slip(N_sl,phase_lattice(ph),phase_cOverA(ph))
if (phase_lattice(ph) == 'cI') then
a = pl%get_as1dFloat('a_nonSchmid',defaultVal=emptyRealArray)
a = pl%get_as1dReal('a_nonSchmid',defaultVal=emptyRealArray)
if (size(a) > 0) prm%nonSchmidActive = .true.
prm%P_nS_pos = lattice_nonSchmidMatrix(N_sl,a,+1)
prm%P_nS_neg = lattice_nonSchmidMatrix(N_sl,a,-1)
@ -151,17 +151,17 @@ module function plastic_phenopowerlaw_init() result(myPlasticity)
prm%P_nS_pos = prm%P_sl
prm%P_nS_neg = prm%P_sl
end if
prm%h_sl_sl = lattice_interaction_SlipBySlip(N_sl,pl%get_as1dFloat('h_sl-sl'),phase_lattice(ph))
prm%h_sl_sl = lattice_interaction_SlipBySlip(N_sl,pl%get_as1dReal('h_sl-sl'),phase_lattice(ph))
xi_0_sl = pl%get_as1dFloat('xi_0_sl', requiredSize=size(N_sl))
prm%xi_inf_sl = pl%get_as1dFloat('xi_inf_sl', requiredSize=size(N_sl))
prm%h_int = pl%get_as1dFloat('h_int', requiredSize=size(N_sl), &
defaultVal=[(0.0_pReal,i=1,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%h_int = pl%get_as1dReal('h_int', requiredSize=size(N_sl), &
defaultVal=[(0.0_pREAL,i=1,size(N_sl))])
prm%dot_gamma_0_sl = pl%get_asFloat('dot_gamma_0_sl')
prm%n_sl = pl%get_asFloat('n_sl')
prm%a_sl = pl%get_asFloat('a_sl')
prm%h_0_sl_sl = pl%get_asFloat('h_0_sl-sl')
prm%dot_gamma_0_sl = pl%get_asReal('dot_gamma_0_sl')
prm%n_sl = pl%get_asReal('n_sl')
prm%a_sl = pl%get_asReal('a_sl')
prm%h_0_sl_sl = pl%get_asReal('h_0_sl-sl')
! expand: family => system
xi_0_sl = math_expand(xi_0_sl, N_sl)
@ -169,11 +169,11 @@ module function plastic_phenopowerlaw_init() result(myPlasticity)
prm%h_int = math_expand(prm%h_int, N_sl)
! sanity checks
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%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(prm%xi_inf_sl <= 0.0_pReal)) extmsg = trim(extmsg)//' xi_inf_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%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(prm%xi_inf_sl <= 0.0_pREAL)) extmsg = trim(extmsg)//' xi_inf_sl'
else slipActive
xi_0_sl = emptyRealArray
@ -188,26 +188,26 @@ module function plastic_phenopowerlaw_init() result(myPlasticity)
twinActive: if (prm%sum_N_tw > 0) then
prm%systems_tw = lattice_labels_twin(N_tw,phase_lattice(ph))
prm%P_tw = lattice_SchmidMatrix_twin(N_tw,phase_lattice(ph),phase_cOverA(ph))
prm%h_tw_tw = lattice_interaction_TwinByTwin(N_tw,pl%get_as1dFloat('h_tw-tw'),phase_lattice(ph))
prm%h_tw_tw = lattice_interaction_TwinByTwin(N_tw,pl%get_as1dReal('h_tw-tw'),phase_lattice(ph))
prm%gamma_char = lattice_characteristicShear_twin(N_tw,phase_lattice(ph),phase_cOverA(ph))
xi_0_tw = pl%get_as1dFloat('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_asFloat('c_1',defaultVal=0.0_pReal)
prm%c_2 = pl%get_asFloat('c_2',defaultVal=1.0_pReal)
prm%c_3 = pl%get_asFloat('c_3',defaultVal=0.0_pReal)
prm%c_4 = pl%get_asFloat('c_4',defaultVal=0.0_pReal)
prm%dot_gamma_0_tw = pl%get_asFloat('dot_gamma_0_tw')
prm%n_tw = pl%get_asFloat('n_tw')
prm%f_sat_sl_tw = pl%get_asFloat('f_sat_sl-tw')
prm%h_0_tw_tw = pl%get_asFloat('h_0_tw-tw')
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_3 = pl%get_asReal('c_3',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%n_tw = pl%get_asReal('n_tw')
prm%f_sat_sl_tw = pl%get_asReal('f_sat_sl-tw')
prm%h_0_tw_tw = pl%get_asReal('h_0_tw-tw')
! expand: family => system
xi_0_tw = math_expand(xi_0_tw,N_tw)
! sanity checks
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%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'
else twinActive
xi_0_tw = emptyRealArray
@ -218,15 +218,15 @@ module function plastic_phenopowerlaw_init() result(myPlasticity)
!--------------------------------------------------------------------------------------------------
! slip-twin related parameters
slipAndTwinActive: if (prm%sum_N_sl > 0 .and. prm%sum_N_tw > 0) then
prm%h_0_tw_sl = pl%get_asFloat('h_0_tw-sl')
prm%h_sl_tw = lattice_interaction_SlipByTwin(N_sl,N_tw,pl%get_as1dFloat('h_sl-tw'), &
prm%h_0_tw_sl = pl%get_asReal('h_0_tw-sl')
prm%h_sl_tw = lattice_interaction_SlipByTwin(N_sl,N_tw,pl%get_as1dReal('h_sl-tw'), &
phase_lattice(ph))
prm%h_tw_sl = lattice_interaction_TwinBySlip(N_tw,N_sl,pl%get_as1dFloat('h_tw-sl'), &
prm%h_tw_sl = lattice_interaction_TwinBySlip(N_tw,N_sl,pl%get_as1dReal('h_tw-sl'), &
phase_lattice(ph))
else slipAndTwinActive
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
prm%h_0_tw_sl = 0.0_pReal
prm%h_0_tw_sl = 0.0_pREAL
end if slipAndTwinActive
!--------------------------------------------------------------------------------------------------
@ -246,28 +246,28 @@ module function plastic_phenopowerlaw_init() result(myPlasticity)
idx_dot%xi_sl = [startIndex,endIndex]
stt%xi_sl => plasticState(ph)%state(startIndex:endIndex,:)
stt%xi_sl = spread(xi_0_sl, 2, Nmembers)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_xi',defaultVal=1.0_pReal)
if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_xi'
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'
startIndex = endIndex + 1
endIndex = endIndex + prm%sum_N_tw
idx_dot%xi_tw = [startIndex,endIndex]
stt%xi_tw => plasticState(ph)%state(startIndex:endIndex,:)
stt%xi_tw = spread(xi_0_tw, 2, Nmembers)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_xi',defaultVal=1.0_pReal)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_xi',defaultVal=1.0_pREAL)
startIndex = endIndex + 1
endIndex = endIndex + prm%sum_N_sl
idx_dot%gamma_sl = [startIndex,endIndex]
stt%gamma_sl => plasticState(ph)%state(startIndex:endIndex,:)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_gamma',defaultVal=1.0e-6_pReal)
if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_gamma'
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'
startIndex = endIndex + 1
endIndex = endIndex + prm%sum_N_tw
idx_dot%gamma_tw = [startIndex,endIndex]
stt%gamma_tw => plasticState(ph)%state(startIndex:endIndex,:)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_gamma',defaultVal=1.0e-6_pReal)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asReal('atol_gamma',defaultVal=1.0e-6_pREAL)
end associate
@ -287,12 +287,12 @@ end function plastic_phenopowerlaw_init
!--------------------------------------------------------------------------------------------------
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
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
real(pReal), dimension(3,3), intent(in) :: &
real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress
integer, intent(in) :: &
ph, &
@ -300,14 +300,14 @@ pure module subroutine phenopowerlaw_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en)
integer :: &
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, &
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
Lp = 0.0_pReal
dLp_dMp = 0.0_pReal
Lp = 0.0_pREAL
dLp_dMp = 0.0_pREAL
associate(prm => param(ph))
@ -338,18 +338,18 @@ end subroutine phenopowerlaw_LpAndItsTangent
!--------------------------------------------------------------------------------------------------
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
integer, intent(in) :: &
ph, &
en
real(pReal), dimension(plasticState(ph)%sizeDotState) :: &
real(pREAL), dimension(plasticState(ph)%sizeDotState) :: &
dotState
real(pReal) :: &
real(pREAL) :: &
xi_sl_sat_offset,&
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, &
left_SlipSlip
@ -365,10 +365,10 @@ module function phenopowerlaw_dotState(Mp,ph,en) result(dotState)
sumF = sum(stt%gamma_tw(:,en)/prm%gamma_char)
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, &
1.0_pReal-stt%xi_sl(:,en) / (prm%xi_inf_sl+xi_sl_sat_offset))
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))
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) &
+ matmul(prm%h_sl_tw,dot_gamma_tw)
@ -431,20 +431,20 @@ end subroutine plastic_phenopowerlaw_result
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)
real(pReal), dimension(3,3), intent(in) :: &
real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress
integer, intent(in) :: &
ph, &
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_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_neg
real(pReal), dimension(param(ph)%sum_N_sl) :: &
real(pREAL), dimension(param(ph)%sum_N_sl) :: &
tau_sl_pos, &
tau_sl_neg
integer :: i
@ -454,35 +454,35 @@ pure subroutine kinetics_sl(Mp,ph,en, &
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_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
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)
else where
dot_gamma_sl_pos = 0.0_pReal
dot_gamma_sl_pos = 0.0_pREAL
end where
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)
else where
dot_gamma_sl_neg = 0.0_pReal
dot_gamma_sl_neg = 0.0_pREAL
end where
if (present(ddot_gamma_dtau_sl_pos)) then
where(dNeq0(dot_gamma_sl_pos))
ddot_gamma_dtau_sl_pos = dot_gamma_sl_pos*prm%n_sl/tau_sl_pos
else where
ddot_gamma_dtau_sl_pos = 0.0_pReal
ddot_gamma_dtau_sl_pos = 0.0_pREAL
end where
end if
if (present(ddot_gamma_dtau_sl_neg)) then
where(dNeq0(dot_gamma_sl_neg))
ddot_gamma_dtau_sl_neg = dot_gamma_sl_neg*prm%n_sl/tau_sl_neg
else where
ddot_gamma_dtau_sl_neg = 0.0_pReal
ddot_gamma_dtau_sl_neg = 0.0_pREAL
end where
end if
@ -501,18 +501,18 @@ end subroutine kinetics_sl
pure subroutine kinetics_tw(Mp,ph,en,&
dot_gamma_tw,ddot_gamma_dtau_tw)
real(pReal), dimension(3,3), intent(in) :: &
real(pREAL), dimension(3,3), intent(in) :: &
Mp !< Mandel stress
integer, intent(in) :: &
ph, &
en
real(pReal), dimension(param(ph)%sum_N_tw), intent(out) :: &
real(pREAL), dimension(param(ph)%sum_N_tw), intent(out) :: &
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
real(pReal), dimension(param(ph)%sum_N_tw) :: &
real(pREAL), dimension(param(ph)%sum_N_tw) :: &
tau_tw
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)]
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
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
* prm%dot_gamma_0_tw*(abs(tau_tw)/stt%xi_tw(:,en))**prm%n_tw
else where
dot_gamma_tw = 0.0_pReal
dot_gamma_tw = 0.0_pREAL
end where
if (present(ddot_gamma_dtau_tw)) then
where(dNeq0(dot_gamma_tw))
ddot_gamma_dtau_tw = dot_gamma_tw*prm%n_tw/tau_tw
else where
ddot_gamma_dtau_tw = 0.0_pReal
ddot_gamma_dtau_tw = 0.0_pREAL
end where
end if

44
src/phase_thermal.f90
View File

@ -4,9 +4,9 @@
submodule(phase) thermal
type :: tThermalParameters
real(pReal) :: C_p = 0.0_pReal !< heat capacity
real(pReal), dimension(3,3) :: K = 0.0_pReal !< thermal conductivity
character(len=pStringLen), allocatable, dimension(:) :: output
real(pREAL) :: C_p = 0.0_pREAL !< heat capacity
real(pREAL), dimension(3,3) :: K = 0.0_pREAL !< thermal conductivity
character(len=pSTRLEN), allocatable, dimension(:) :: output
end type tThermalParameters
integer, dimension(:), allocatable :: &
@ -22,7 +22,7 @@ submodule(phase) thermal
end enum
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
integer(kind(THERMAL_UNDEFINED_ID)), dimension(:,:), allocatable :: &
thermal_source
@ -57,14 +57,14 @@ submodule(phase) thermal
integer, intent(in) :: &
ph, &
en
real(pReal) :: f_T
real(pREAL) :: f_T
end function dissipation_f_T
module function externalheat_f_T(ph,en) result(f_T)
integer, intent(in) :: &
ph, &
en
real(pReal) :: f_T
real(pREAL) :: f_T
end function externalheat_f_T
end interface
@ -100,7 +100,7 @@ module subroutine thermal_init(phases)
do ph = 1, phases%length
Nmembers = count(material_ID_phase == ph)
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)
thermal => phase%get_dict('thermal',defaultVal=emptyDict)
@ -109,15 +109,15 @@ module subroutine thermal_init(phases)
print'(/,1x,a,i0,a)', 'phase ',ph,': '//phases%key(ph)
refs = config_listReferences(thermal,indent=3)
if (len(refs) > 0) print'(/,1x,a)', refs
param(ph)%C_p = thermal%get_asFloat('C_p')
param(ph)%K(1,1) = thermal%get_asFloat('K_11')
if (any(phase_lattice(ph) == ['hP','tI'])) param(ph)%K(3,3) = thermal%get_asFloat('K_33')
param(ph)%C_p = thermal%get_asReal('C_p')
param(ph)%K(1,1) = thermal%get_asReal('K_11')
if (any(phase_lattice(ph) == ['hP','tI'])) param(ph)%K(3,3) = thermal%get_asReal('K_33')
param(ph)%K = lattice_symmetrize_33(param(ph)%K,phase_lattice(ph))
#if defined(__GFORTRAN__)
param(ph)%output = output_as1dString(thermal)
param(ph)%output = output_as1dStr(thermal)
#else
param(ph)%output = thermal%get_as1dString('output',defaultVal=emptyStringArray)
param(ph)%output = thermal%get_as1dStr('output',defaultVal=emptyStrArray)
#endif
sources => thermal%get_list('source',defaultVal=emptyList)
thermal_Nsources(ph) = sources%length
@ -156,13 +156,13 @@ end subroutine thermal_init
module function phase_f_T(ph,en) result(f)
integer, intent(in) :: ph, en
real(pReal) :: f
real(pREAL) :: f
integer :: so
f = 0.0_pReal
f = 0.0_pREAL
do so = 1, thermal_Nsources(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)
integer, intent(in) :: co, ce
real(pReal) :: mu
real(pREAL) :: mu
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)
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)
@ -236,7 +236,7 @@ end function phase_K_T
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
logical :: converged_
@ -251,7 +251,7 @@ end function phase_thermal_constitutive
!--------------------------------------------------------------------------------------------------
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
logical :: &
broken
@ -323,7 +323,7 @@ end subroutine thermal_forward
pure module function thermal_T(ph,en) result(T)
integer, intent(in) :: ph, en
real(pReal) :: T
real(pREAL) :: T
T = current(ph)%T(en)
@ -337,7 +337,7 @@ end function thermal_T
module function thermal_dot_T(ph,en) result(dot_T)
integer, intent(in) :: ph, en
real(pReal) :: dot_T
real(pREAL) :: dot_T
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)
real(pReal), intent(in) :: T, dot_T
real(pREAL), intent(in) :: T, dot_T
integer, intent(in) :: ce, co
@ -387,7 +387,7 @@ function thermal_active(source_label,src_length) result(active_source)
sources => thermal%get_list('source',defaultVal=emptyList)
do s = 1, sources%length
src => sources%get_dict(s)
active_source(s,p) = src%get_asString('type') == source_label
active_source(s,p) = src%get_asStr('type') == source_label
end do
end do

8
src/phase_thermal_dissipation.f90
View File

@ -8,7 +8,7 @@
submodule(phase:thermal) dissipation
type :: tParameters !< container type for internal constitutive parameters
real(pReal) :: &
real(pREAL) :: &
kappa !< TAYLOR-QUINNEY factor
end type tParameters
@ -61,7 +61,7 @@ module function dissipation_init(source_length) result(mySources)
refs = config_listReferences(src,indent=3)
if (len(refs) > 0) print'(/,1x,a)', refs
prm%kappa = src%get_asFloat('kappa')
prm%kappa = src%get_asReal('kappa')
Nmembers = count(material_ID_phase == ph)
call phase_allocateState(thermalState(ph)%p(so),Nmembers,0,0,0)
@ -80,9 +80,9 @@ end function dissipation_init
module function dissipation_f_T(ph,en) result(f_T)
integer, intent(in) :: ph, en
real(pReal) :: &
real(pREAL) :: &
f_T
real(pReal), dimension(3,3) :: &
real(pREAL), dimension(3,3) :: &
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))

4
src/phase_thermal_externalheat.f90
View File

@ -92,7 +92,7 @@ module subroutine externalheat_dotState(ph, en)
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
@ -105,7 +105,7 @@ module function externalheat_f_T(ph,en) result(f_T)
integer, intent(in) :: &
ph, &
en
real(pReal) :: &
real(pREAL) :: &
f_T
integer :: &

52
src/polynomials.f90
View File

@ -12,8 +12,8 @@ module polynomials
private
type, public :: tPolynomial
real(pReal), dimension(:), allocatable :: coef
real(pReal) :: x_ref = huge(0.0_pReal)
real(pREAL), dimension(:), allocatable :: coef
real(pREAL) :: x_ref = huge(0.0_pREAL)
contains
procedure, public :: at => eval
end type tPolynomial
@ -47,8 +47,8 @@ end subroutine polynomials_init
!--------------------------------------------------------------------------------------------------
pure function polynomial_from_coef(coef,x_ref) result(p)
real(pReal), dimension(0:), intent(in) :: coef
real(pReal), intent(in) :: x_ref
real(pREAL), dimension(0:), intent(in) :: coef
real(pREAL), intent(in) :: x_ref
type(tPolynomial) :: p
@ -67,23 +67,23 @@ function polynomial_from_dict(dict,y,x) result(p)
character(len=*), intent(in) :: y, x
type(tPolynomial) :: p
real(pReal), dimension(:), allocatable :: coef
real(pReal) :: x_ref
real(pREAL), dimension(:), allocatable :: coef
real(pREAL) :: x_ref
integer :: i, o
character(len=1) :: o_s
allocate(coef(1),source=dict%get_asFloat(y))
allocate(coef(1),source=dict%get_asReal(y))
if (dict%contains(y//','//x)) then
x_ref = dict%get_asFloat(x//'_ref')
coef = [coef,dict%get_asFloat(y//','//x)]
x_ref = dict%get_asReal(x//'_ref')
coef = [coef,dict%get_asReal(y//','//x)]
end if
do o = 2,4
write(o_s,'(I0.0)') o
if (dict%contains(y//','//x//'^'//o_s)) then
x_ref = dict%get_asFloat(x//'_ref')
coef = [coef,[(0.0_pReal,i=size(coef),o-1)],dict%get_asFloat(y//','//x//'^'//o_s)]
x_ref = dict%get_asReal(x//'_ref')
coef = [coef,[(0.0_pREAL,i=size(coef),o-1)],dict%get_asReal(y//','//x//'^'//o_s)]
end if
end do
@ -99,8 +99,8 @@ end function polynomial_from_dict
pure function eval(self,x) result(y)
class(tPolynomial), intent(in) :: self
real(pReal), intent(in) :: x
real(pReal) :: y
real(pREAL), intent(in) :: x
real(pREAL) :: y
integer :: o
@ -123,21 +123,21 @@ end function eval
subroutine selfTest()
type(tPolynomial) :: p1, p2
real(pReal), dimension(5) :: coef
real(pREAL), dimension(5) :: coef
integer :: i
real(pReal) :: x_ref, x, y
real(pREAL) :: x_ref, x, y
type(tDict), pointer :: dict
character(len=pStringLen), dimension(size(coef)) :: coef_s
character(len=pStringLen) :: x_ref_s, x_s, YAML_s
character(len=pSTRLEN), dimension(size(coef)) :: coef_s
character(len=pSTRLEN) :: x_ref_s, x_s, YAML_s
call random_number(coef)
call random_number(x_ref)
call random_number(x)
coef = coef*10_pReal -0.5_pReal
x_ref = x_ref*10_pReal -0.5_pReal
x = x*10_pReal -0.5_pReal
coef = coef*10_pREAL -0.5_pREAL
x_ref = x_ref*10_pREAL -0.5_pREAL
x = x*10_pREAL -0.5_pREAL
p1 = polynomial([coef(1)],x_ref)
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
dict => YAML_parse_str_asDict(trim(YAML_s))
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
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//&
'C,T: '//trim(adjustl(coef_s(2)))//IO_EOL//&
'T_ref: '//trim(adjustl(x_ref_s))//IO_EOL
dict => YAML_parse_str_asDict(trim(YAML_s))
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//&
'C,T^2: '//trim(adjustl(coef_s(3)))//IO_EOL//&
'T_ref: '//trim(adjustl(x_ref_s))//IO_EOL
dict => YAML_parse_str_asDict(trim(YAML_s))
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//&
'Y,X^3: '//trim(adjustl(coef_s(2)))//IO_EOL//&
'X_ref: '//trim(adjustl(x_ref_s))//IO_EOL
dict => YAML_parse_str_asDict(trim(YAML_s))
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//&
'Y,X^4: '//trim(adjustl(coef_s(2)))//IO_EOL//&
'X_ref: '//trim(adjustl(x_ref_s))//IO_EOL
dict => YAML_parse_str_asDict(trim(YAML_s))
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

62
src/prec.f90
View File

@ -19,27 +19,27 @@ module prec
public
! 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 :: pI64 = selected_int_kind(18) !< number with at least up to +-1e18 (typically 64 bit)
#ifdef PETSC
PetscInt, private :: dummy_int
integer, parameter :: pPETSCINT = kind(dummy_int)
PetscScalar, private :: dummy_scalar
real(pReal), parameter, private :: pPETSCSCALAR = kind(dummy_scalar)
real(pREAL), parameter, private :: pPETSCSCALAR = kind(dummy_scalar)
#endif
integer, parameter :: pSTRINGLEN = 256 !< default string length
integer, parameter :: pSTRLEN = 256 !< default string length
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_MIN = tiny(0.0_pReal) !< smallest normalized floating point number
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
integer, dimension(0), parameter :: emptyIntArray = [integer::]
real(pReal), dimension(0), parameter :: emptyRealArray = [real(pReal)::]
character(len=pStringLen), dimension(0), parameter :: emptyStringArray = [character(len=pStringLen)::]
real(pREAL), dimension(0), parameter :: emptyRealArray = [real(pREAL)::]
character(len=pSTRLEN), dimension(0), parameter :: emptyStrArray = [character(len=pSTRLEN)::]
contains
@ -54,11 +54,11 @@ subroutine prec_init()
print'(/,a,i3)', ' integer size / bit: ',bit_size(0)
print'( a,i19)', ' maximum value: ',huge(0)
print'(/,a,i3)', ' float size / bit: ',storage_size(0.0_pReal)
print'( a,e10.3)', ' maximum value: ',huge(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)', ' minimum value: ',PREAL_MIN
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()
@ -74,8 +74,8 @@ end subroutine prec_init
!--------------------------------------------------------------------------------------------------
logical elemental pure function dEq(a,b,tol)
real(pReal), intent(in) :: a,b
real(pReal), intent(in), optional :: tol
real(pREAL), intent(in) :: a,b
real(pREAL), intent(in), optional :: tol
if (present(tol)) then
@ -95,8 +95,8 @@ end function dEq
!--------------------------------------------------------------------------------------------------
logical elemental pure function dNeq(a,b,tol)
real(pReal), intent(in) :: a,b
real(pReal), intent(in), optional :: tol
real(pREAL), intent(in) :: a,b
real(pREAL), intent(in), optional :: tol
dNeq = .not. dEq(a,b,tol)
@ -112,14 +112,14 @@ end function dNeq
!--------------------------------------------------------------------------------------------------
logical elemental pure function dEq0(a,tol)
real(pReal), intent(in) :: a
real(pReal), intent(in), optional :: tol
real(pREAL), intent(in) :: a
real(pREAL), intent(in), optional :: tol
if (present(tol)) then
dEq0 = abs(a) <= tol
else
dEq0 = abs(a) <= PREAL_MIN * 10.0_pReal
dEq0 = abs(a) <= PREAL_MIN * 10.0_pREAL
end if
end function dEq0
@ -133,8 +133,8 @@ end function dEq0
!--------------------------------------------------------------------------------------------------
logical elemental pure function dNeq0(a,tol)
real(pReal), intent(in) :: a
real(pReal), intent(in), optional :: tol
real(pREAL), intent(in) :: a
real(pREAL), intent(in), optional :: tol
dNeq0 = .not. dEq0(a,tol)
@ -151,8 +151,8 @@ end function dNeq0
!--------------------------------------------------------------------------------------------------
logical elemental pure function cEq(a,b,tol)
complex(pReal), intent(in) :: a,b
real(pReal), intent(in), optional :: tol
complex(pREAL), intent(in) :: a,b
real(pREAL), intent(in), optional :: tol
if (present(tol)) then
@ -173,8 +173,8 @@ end function cEq
!--------------------------------------------------------------------------------------------------
logical elemental pure function cNeq(a,b,tol)
complex(pReal), intent(in) :: a,b
real(pReal), intent(in), optional :: tol
complex(pREAL), intent(in) :: a,b
real(pREAL), intent(in), optional :: tol
cNeq = .not. cEq(a,b,tol)
@ -248,13 +248,13 @@ end function prec_bytesToC_INT64_T
subroutine prec_selfTest()
integer, allocatable, dimension(:) :: realloc_lhs_test
real(pReal), dimension(1) :: f
real(pREAL), dimension(1) :: f
integer(pI64), dimension(1) :: i
real(pReal), dimension(2) :: r
real(pREAL), dimension(2) :: r
#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
realloc_lhs_test = [1,2]
if (any(realloc_lhs_test/=[1,2])) error stop 'LHS allocation'
@ -267,11 +267,11 @@ subroutine prec_selfTest()
! https://www.binaryconvert.com
! https://www.rapidtables.com/convert/number/binary-to-decimal.html
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'
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'
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'
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'
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'

36
src/result.f90
View File

@ -141,9 +141,9 @@ end subroutine result_closeJobFile
subroutine result_addIncrement(inc,time)
integer, intent(in) :: inc
real(pReal), intent(in) :: time
real(pREAL), intent(in) :: time
character(len=pStringLen) :: incChar
character(len=pSTRLEN) :: incChar
write(incChar,'(i10)') inc
@ -251,7 +251,7 @@ end subroutine result_addAttribute_int
subroutine result_addAttribute_real(attrLabel,attrValue,path)
character(len=*), intent(in) :: attrLabel
real(pReal), intent(in) :: attrValue
real(pREAL), intent(in) :: attrValue
character(len=*), intent(in), optional :: path
@ -296,7 +296,7 @@ end subroutine result_addAttribute_int_array
subroutine result_addAttribute_real_array(attrLabel,attrValue,path)
character(len=*), intent(in) :: attrLabel
real(pReal), intent(in), dimension(:) :: attrValue
real(pREAL), intent(in), dimension(:) :: attrValue
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), optional :: SIunit
real(pReal), intent(in), dimension(:) :: dataset
real(pREAL), intent(in), dimension(:) :: dataset
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), optional :: SIunit
character(len=*), intent(in), dimension(:), optional :: systems
real(pReal), intent(in), dimension(:,:) :: dataset
real(pREAL), intent(in), dimension(:,:) :: dataset
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), optional :: SIunit
logical, intent(in), optional :: transposed
real(pReal), intent(in), dimension(:,:,:) :: dataset
real(pREAL), intent(in), dimension(:,:,:) :: dataset
integer :: i
integer(HID_T) :: groupHandle
real(pReal), dimension(:,:,:), allocatable :: dataset_transposed
real(pREAL), dimension(:,:,:), allocatable :: dataset_transposed
groupHandle = result_openGroup(group)
@ -488,7 +488,7 @@ subroutine result_mapping_phase(ID,entry,label)
plist_id, &
dt_id
integer(SIZE_T) :: type_size_string, type_size_int
integer(SIZE_T) :: type_size_str, type_size_int
integer :: hdferr, ce, co
integer(MPI_INTEGER_KIND) :: err_MPI
@ -536,23 +536,23 @@ subroutine result_mapping_phase(ID,entry,label)
call HDF5_chkerr(hdferr)
call H5Tset_size_f(dt_id, int(len(label(1)),SIZE_T), hdferr)
call HDF5_chkerr(hdferr)
call H5Tget_size_f(dt_id, type_size_string, hdferr)
call H5Tget_size_f(dt_id, type_size_str, hdferr)
call HDF5_chkerr(hdferr)
pI64_t = h5kind_to_type(kind(entryGlobal),H5_INTEGER_KIND)
call H5Tget_size_f(pI64_t, type_size_int, hdferr)
call HDF5_chkerr(hdferr)
call H5Tcreate_f(H5T_COMPOUND_F, type_size_string + type_size_int, dtype_id, hdferr)
call H5Tcreate_f(H5T_COMPOUND_F, type_size_str + type_size_int, dtype_id, hdferr)
call HDF5_chkerr(hdferr)
call H5Tinsert_f(dtype_id, 'label', 0_SIZE_T, dt_id,hdferr)
call HDF5_chkerr(hdferr)
call H5Tinsert_f(dtype_id, 'entry', type_size_string, pI64_t, hdferr)
call H5Tinsert_f(dtype_id, 'entry', type_size_str, pI64_t, hdferr)
call HDF5_chkerr(hdferr)
!--------------------------------------------------------------------------------------------------
! create memory types for each component of the compound type
call H5Tcreate_f(H5T_COMPOUND_F, type_size_string, label_id, hdferr)
call H5Tcreate_f(H5T_COMPOUND_F, type_size_str, label_id, hdferr)
call HDF5_chkerr(hdferr)
call H5Tinsert_f(label_id, 'label', 0_SIZE_T, dt_id, hdferr)
call HDF5_chkerr(hdferr)
@ -644,7 +644,7 @@ subroutine result_mapping_homogenization(ID,entry,label)
plist_id, &
dt_id
integer(SIZE_T) :: type_size_string, type_size_int
integer(SIZE_T) :: type_size_str, type_size_int
integer :: hdferr, ce
integer(MPI_INTEGER_KIND) :: err_MPI
@ -688,23 +688,23 @@ subroutine result_mapping_homogenization(ID,entry,label)
call HDF5_chkerr(hdferr)
call H5Tset_size_f(dt_id, int(len(label(1)),SIZE_T), hdferr)
call HDF5_chkerr(hdferr)
call H5Tget_size_f(dt_id, type_size_string, hdferr)
call H5Tget_size_f(dt_id, type_size_str, hdferr)
call HDF5_chkerr(hdferr)
pI64_t = h5kind_to_type(kind(entryGlobal),H5_INTEGER_KIND)
call H5Tget_size_f(pI64_t, type_size_int, hdferr)
call HDF5_chkerr(hdferr)
call H5Tcreate_f(H5T_COMPOUND_F, type_size_string + type_size_int, dtype_id, hdferr)
call H5Tcreate_f(H5T_COMPOUND_F, type_size_str + type_size_int, dtype_id, hdferr)
call HDF5_chkerr(hdferr)
call H5Tinsert_f(dtype_id, 'label', 0_SIZE_T, dt_id,hdferr)
call HDF5_chkerr(hdferr)
call H5Tinsert_f(dtype_id, 'entry', type_size_string, pI64_t, hdferr)
call H5Tinsert_f(dtype_id, 'entry', type_size_str, pI64_t, hdferr)
call HDF5_chkerr(hdferr)
!--------------------------------------------------------------------------------------------------
! create memory types for each component of the compound type
call H5Tcreate_f(H5T_COMPOUND_F, type_size_string, label_id, hdferr)
call H5Tcreate_f(H5T_COMPOUND_F, type_size_str, label_id, hdferr)
call HDF5_chkerr(hdferr)
call H5Tinsert_f(label_id, 'label', 0_SIZE_T, dt_id, hdferr)
call HDF5_chkerr(hdferr)

324
src/rotations.f90
View File

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

8
src/system_routines.f90
View File

@ -47,7 +47,7 @@ module system_routines
use prec
implicit none(type,external)
character(kind=C_CHAR), dimension(pStringLen+1), intent(out) :: hostname ! NULL-terminated array
character(kind=C_CHAR), dimension(pSTRLEN+1), intent(out) :: hostname ! NULL-terminated array
integer(C_INT), intent(out) :: stat
end subroutine getHostName_C
@ -56,7 +56,7 @@ module system_routines
use prec
implicit none(type,external)
character(kind=C_CHAR), dimension(pStringLen+1), intent(out) :: username ! NULL-terminated array
character(kind=C_CHAR), dimension(pSTRLEN+1), intent(out) :: username ! NULL-terminated array
integer(C_INT), intent(out) :: stat
end subroutine getUserName_C
@ -135,7 +135,7 @@ function getHostName()
character(len=:), allocatable :: getHostName
character(kind=C_CHAR), dimension(pStringLen+1) :: getHostName_Cstring
character(kind=C_CHAR), dimension(pSTRLEN+1) :: getHostName_Cstring
integer(C_INT) :: stat
@ -157,7 +157,7 @@ function getUserName()
character(len=:), allocatable :: getUserName
character(kind=C_CHAR), dimension(pStringLen+1) :: getUserName_Cstring
character(kind=C_CHAR), dimension(pSTRLEN+1) :: getUserName_Cstring
integer(C_INT) :: stat

32
src/tables.f90
View File

@ -13,7 +13,7 @@ module tables
private
type, public :: tTable
real(pReal), dimension(:), allocatable :: x,y
real(pREAL), dimension(:), allocatable :: x,y
contains
procedure, public :: at => eval
end type tTable
@ -47,7 +47,7 @@ end subroutine tables_init
!--------------------------------------------------------------------------------------------------
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
@ -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(x) /= size(y)) call IO_error(603,ext_msg='shape mismatch in tabulated data')
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')
end if
@ -75,7 +75,7 @@ function table_from_dict(dict,x_label,y_label) result(t)
type(tTable) :: t
t = tTable(dict%get_as1dFloat(x_label),dict%get_as1dFloat(y_label))
t = tTable(dict%get_as1dReal(x_label),dict%get_as1dReal(y_label))
end function table_from_dict
@ -86,8 +86,8 @@ end function table_from_dict
pure function eval(self,x) result(y)
class(tTable), intent(in) :: self
real(pReal), intent(in) :: x
real(pReal) :: y
real(pREAL), intent(in) :: x
real(pREAL) :: y
integer :: i
@ -109,25 +109,25 @@ end function eval
subroutine selfTest()
type(tTable) :: t
real(pReal), dimension(*), parameter :: &
x = real([ 1., 2., 3., 4.],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), &
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)
real(pREAL), dimension(*), parameter :: &
x = real([ 1., 2., 3., 4.],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), &
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
type(tDict), pointer :: dict
type(tList), pointer :: l_x, l_y
real(pReal) :: r
real(pREAL) :: r
call random_number(r)
t = table(real([0.],pReal),real([r],pReal))
if (dNeq(r,t%at(r),1.0e-9_pReal)) error stop 'table eval/mono'
t = table(real([0.],pREAL),real([r],pREAL))
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)
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
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()
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)