From c1d4b64b13484180c2284ed823f4e93df04e260f Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 24 Mar 2019 10:48:46 +0100 Subject: [PATCH 01/47] better use intrinsic F2003 features --- src/DAMASK_interface.f90 | 95 +++++++--------------------------------- 1 file changed, 16 insertions(+), 79 deletions(-) diff --git a/src/DAMASK_interface.f90 b/src/DAMASK_interface.f90 index 143561f5d..aab41ff29 100644 --- a/src/DAMASK_interface.f90 +++ b/src/DAMASK_interface.f90 @@ -29,10 +29,7 @@ module DAMASK_interface getGeometryFile, & getLoadCaseFile, & rectifyPath, & - makeRelativePath, & - IIO_stringValue, & - IIO_intValue, & - IIO_stringPos + makeRelativePath contains !-------------------------------------------------------------------------------------------------- @@ -93,11 +90,13 @@ subroutine DAMASK_interface_init() implicit none character(len=1024) :: & commandLine, & !< command line call as string - loadcaseArg = '', & !< -l argument given to the executable + arg, & !< individual argument + loadCaseArg = '', & !< -l argument given to the executable geometryArg = '', & !< -g argument given to the executable workingDirArg = '', & !< -w argument given to the executable userName !< name of user calling the executable integer :: & + stat, & i, & #ifdef _OPENMP threadLevel, & @@ -105,8 +104,6 @@ subroutine DAMASK_interface_init() worldrank = 0, & worldsize = 0, & typeSize - integer, allocatable, dimension(:) :: & - chunkPos integer, dimension(8) :: & dateAndTime integer :: mpi_err @@ -198,10 +195,9 @@ subroutine DAMASK_interface_init() call quit(1) endif - call get_command(commandLine) - chunkPos = IIO_stringPos(commandLine) - do i = 2, chunkPos(1) - select case(IIO_stringValue(commandLine,chunkPos,i)) ! extract key + do i = 1, command_argument_count() + call get_command_argument(i,arg) + select case(trim(arg)) ! extract key case ('-h','--help') write(6,'(a)') ' #######################################################################' write(6,'(a)') ' DAMASK Command Line Interface:' @@ -240,14 +236,17 @@ subroutine DAMASK_interface_init() write(6,'(a,/)')' Prints this message and exits' call quit(0) ! normal Termination case ('-l', '--load', '--loadcase') - if ( i < chunkPos(1)) loadcaseArg = trim(IIO_stringValue(commandLine,chunkPos,i+1)) + call get_command_argument(i+1,loadCaseArg) case ('-g', '--geom', '--geometry') - if (i < chunkPos(1)) geometryArg = trim(IIO_stringValue(commandLine,chunkPos,i+1)) + call get_command_argument(i+1,geometryArg) case ('-w', '-d', '--wd', '--directory', '--workingdir', '--workingdirectory') - if (i < chunkPos(1)) workingDirArg = trim(IIO_stringValue(commandLine,chunkPos,i+1)) + call get_command_argument(i+1,workingDirArg) case ('-r', '--rs', '--restart') - if (i < chunkPos(1)) then - interface_restartInc = IIO_IntValue(commandLine,chunkPos,i+1) + call get_command_argument(i+1,arg) + read(arg,*,iostat=stat) interface_restartInc + if (interface_restartInc < 0 .or. stat /=0) then + write(6,'(a)') ' Could not parse restart increment: '//trim(arg) + call quit(1) endif end select enddo @@ -261,6 +260,7 @@ subroutine DAMASK_interface_init() geometryFile = getGeometryFile(geometryArg) loadCaseFile = getLoadCaseFile(loadCaseArg) + call get_command(commandLine) call get_environment_variable('USER',userName) ! ToDo: https://stackoverflow.com/questions/8953424/how-to-get-the-username-in-c-c-in-linux write(6,'(/,a,i4.1)') ' MPI processes: ',worldsize @@ -498,67 +498,4 @@ subroutine setSIGUSR2(signal) bind(C) end subroutine setSIGUSR2 - -!-------------------------------------------------------------------------------------------------- -!> @brief taken from IO, check IO_stringValue for documentation -!-------------------------------------------------------------------------------------------------- -pure function IIO_stringValue(string,chunkPos,myChunk) - - implicit none - 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=chunkPos(myChunk*2+1)-chunkPos(myChunk*2)+1) :: IIO_stringValue - character(len=*), intent(in) :: string !< raw input with known start and end of each chunk - - IIO_stringValue = string(chunkPos(myChunk*2):chunkPos(myChunk*2+1)) - -end function IIO_stringValue - - -!-------------------------------------------------------------------------------------------------- -!> @brief taken from IO, check IO_intValue for documentation -!-------------------------------------------------------------------------------------------------- -integer pure function IIO_intValue(string,chunkPos,myChunk) - - implicit none - character(len=*), intent(in) :: string !< raw input with known start and end of each chunk - integer, intent(in) :: myChunk !< position number of desired sub string - integer, dimension(:), intent(in) :: chunkPos !< positions of start and end of each tag/chunk in given string - - - valuePresent: if (myChunk > chunkPos(1) .or. myChunk < 1) then - IIO_intValue = 0 - else valuePresent - read(UNIT=string(chunkPos(myChunk*2):chunkPos(myChunk*2+1)),ERR=100,FMT=*) IIO_intValue - endif valuePresent - return -100 IIO_intValue = huge(1) - -end function IIO_intValue - - -!-------------------------------------------------------------------------------------------------- -!> @brief taken from IO, check IO_stringPos for documentation -!-------------------------------------------------------------------------------------------------- -pure function IIO_stringPos(string) - - implicit none - integer, dimension(:), allocatable :: IIO_stringPos - character(len=*), intent(in) :: string !< string in which chunks are searched for - - character(len=*), parameter :: SEP=achar(44)//achar(32)//achar(9)//achar(10)//achar(13) ! comma and whitespaces - integer :: left, right - - allocate(IIO_stringPos(1), source=0) - right = 0 - - do while (verify(string(right+1:),SEP)>0) - left = right + verify(string(right+1:),SEP) - right = left + scan(string(left:),SEP) - 2 - IIO_stringPos = [IIO_stringPos,left, right] - IIO_stringPos(1) = IIO_stringPos(1)+1 - enddo - -end function IIO_stringPos - end module From 0f2013e78a06c36ce7d3cf1504dcae85430d03fc Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 24 Mar 2019 11:01:27 +0100 Subject: [PATCH 02/47] modernized - no pInt - consistent 2-blank indentation - use of parameter structure --- src/source_thermal_dissipation.f90 | 194 ++++++++++++++--------------- 1 file changed, 94 insertions(+), 100 deletions(-) diff --git a/src/source_thermal_dissipation.f90 b/src/source_thermal_dissipation.f90 index bdee3f4f3..23d6e8b58 100644 --- a/src/source_thermal_dissipation.f90 +++ b/src/source_thermal_dissipation.f90 @@ -5,38 +5,33 @@ !> @details to be done !-------------------------------------------------------------------------------------------------- module source_thermal_dissipation - use prec, only: & - pReal, & - pInt - - implicit none - private - integer(pInt), dimension(:), allocatable, public, protected :: & - source_thermal_dissipation_offset, & !< which source is my current thermal dissipation mechanism? - source_thermal_dissipation_instance !< instance of thermal dissipation source mechanism - - integer(pInt), dimension(:,:), allocatable, target, public :: & - source_thermal_dissipation_sizePostResult !< size of each post result output - - character(len=64), dimension(:,:), allocatable, target, public :: & - source_thermal_dissipation_output !< name of each post result output - - real(pReal), dimension(:), allocatable, private :: & - source_thermal_dissipation_coldworkCoeff - - - type, private :: tParameters !< container type for internal constitutive parameters - real(pReal) :: & - coldworkCoeff - end type tParameters - - type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) - - - public :: & - source_thermal_dissipation_init, & - source_thermal_dissipation_getRateAndItsTangent - + use prec, only: & + pReal + + implicit none + private + integer, dimension(:), allocatable, public, protected :: & + source_thermal_dissipation_offset, & !< which source is my current thermal dissipation mechanism? + source_thermal_dissipation_instance !< instance of thermal dissipation source mechanism + + integer, dimension(:,:), allocatable, target, public :: & + source_thermal_dissipation_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + source_thermal_dissipation_output !< name of each post result output + + type, private :: tParameters !< container type for internal constitutive parameters + real(pReal) :: & + kappa + end type tParameters + + type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) + + + public :: & + source_thermal_dissipation_init, & + source_thermal_dissipation_getRateAndItsTangent + contains @@ -45,61 +40,60 @@ contains !> @details reads in material parameters, allocates arrays, and does sanity checks !-------------------------------------------------------------------------------------------------- subroutine source_thermal_dissipation_init - use debug, only: & - debug_level,& - debug_constitutive,& - debug_levelBasic - use material, only: & - material_allocateSourceState, & - phase_source, & - phase_Nsources, & - phase_Noutput, & - SOURCE_thermal_dissipation_label, & - SOURCE_thermal_dissipation_ID, & - material_phase, & - sourceState - use config, only: & - config_phase, & - material_Nphase - - implicit none - integer(pInt) :: Ninstance,instance,source,sourceOffset - integer(pInt) :: NofMyPhase,p - - write(6,'(/,a)') ' <<<+- source_'//SOURCE_thermal_dissipation_label//' init -+>>>' - + use debug, only: & + debug_level,& + debug_constitutive,& + debug_levelBasic + use material, only: & + material_allocateSourceState, & + phase_source, & + phase_Nsources, & + phase_Noutput, & + SOURCE_thermal_dissipation_label, & + SOURCE_thermal_dissipation_ID, & + material_phase + use config, only: & + config_phase, & + material_Nphase - Ninstance = int(count(phase_source == SOURCE_thermal_dissipation_ID),pInt) - if (Ninstance == 0_pInt) return - if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & - write(6,'(a16,1x,i5,/)') '# instances:',Ninstance + implicit none + integer :: Ninstance,instance,source,sourceOffset + integer :: NofMyPhase,p - allocate(source_thermal_dissipation_offset(material_Nphase), source=0_pInt) - allocate(source_thermal_dissipation_instance(material_Nphase), source=0_pInt) - do p = 1, material_Nphase - source_thermal_dissipation_instance(p) = count(phase_source(:,1:p) == SOURCE_thermal_dissipation_ID) - do source = 1, phase_Nsources(p) - if (phase_source(source,p) == SOURCE_thermal_dissipation_ID) & - source_thermal_dissipation_offset(p) = source - enddo - enddo - - allocate(source_thermal_dissipation_sizePostResult(maxval(phase_Noutput),Ninstance),source=0_pInt) - allocate(source_thermal_dissipation_output (maxval(phase_Noutput),Ninstance)) - source_thermal_dissipation_output = '' - - allocate(source_thermal_dissipation_coldworkCoeff(Ninstance), source=0.0_pReal) - - do p=1, size(config_phase) - if (all(phase_source(:,p) /= SOURCE_THERMAL_DISSIPATION_ID)) cycle - instance = source_thermal_dissipation_instance(p) - source_thermal_dissipation_coldworkCoeff(instance) = config_phase(p)%getFloat('dissipation_coldworkcoeff') - NofMyPhase=count(material_phase==p) - sourceOffset = source_thermal_dissipation_offset(p) - - call material_allocateSourceState(p,sourceOffset,NofMyPhase,0_pInt,0_pInt,0_pInt) + write(6,'(/,a)') ' <<<+- source_'//SOURCE_thermal_dissipation_label//' init -+>>>' - enddo + + Ninstance = count(phase_source == SOURCE_thermal_dissipation_ID) + if (Ninstance == 0) return + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0) & + write(6,'(a16,1x,i5,/)') '# instances:',Ninstance + + allocate(source_thermal_dissipation_offset(material_Nphase), source=0) + allocate(source_thermal_dissipation_instance(material_Nphase), source=0) + allocate(param(Ninstance)) + + do p = 1, material_Nphase + source_thermal_dissipation_instance(p) = count(phase_source(:,1:p) == SOURCE_thermal_dissipation_ID) + do source = 1, phase_Nsources(p) + if (phase_source(source,p) == SOURCE_thermal_dissipation_ID) & + source_thermal_dissipation_offset(p) = source + enddo + enddo + + allocate(source_thermal_dissipation_sizePostResult(maxval(phase_Noutput),Ninstance),source=0) + allocate(source_thermal_dissipation_output (maxval(phase_Noutput),Ninstance)) + source_thermal_dissipation_output = '' + + do p=1, size(config_phase) + if (all(phase_source(:,p) /= SOURCE_THERMAL_DISSIPATION_ID)) cycle + instance = source_thermal_dissipation_instance(p) + param(instance)%kappa = config_phase(p)%getFloat('dissipation_coldworkcoeff') + NofMyPhase=count(material_phase==p) + sourceOffset = source_thermal_dissipation_offset(p) + + call material_allocateSourceState(p,sourceOffset,NofMyPhase,0,0,0) + + enddo end subroutine source_thermal_dissipation_init @@ -109,23 +103,23 @@ end subroutine source_thermal_dissipation_init !-------------------------------------------------------------------------------------------------- subroutine source_thermal_dissipation_getRateAndItsTangent(TDot, dTDOT_dT, Tstar, Lp, phase) - implicit none - integer(pInt), intent(in) :: & - phase - real(pReal), intent(in), dimension(3,3) :: & - Tstar - real(pReal), intent(in), dimension(3,3) :: & - Lp - real(pReal), intent(out) :: & - TDot, & - dTDOT_dT - integer(pInt) :: & - instance - - instance = source_thermal_dissipation_instance(phase) + implicit none + integer, intent(in) :: & + phase + real(pReal), intent(in), dimension(3,3) :: & + Tstar + real(pReal), intent(in), dimension(3,3) :: & + Lp + real(pReal), intent(out) :: & + TDot, & + dTDOT_dT + integer :: & + instance - TDot = source_thermal_dissipation_coldworkCoeff(instance)*sum(abs(Tstar*Lp)) - dTDOT_dT = 0.0_pReal + instance = source_thermal_dissipation_instance(phase) + + TDot = param(instance)%kappa*sum(abs(Tstar*Lp)) + dTDOT_dT = 0.0_pReal end subroutine source_thermal_dissipation_getRateAndItsTangent From 320f39925ae884f0492946679ddf2ff3c24b828f Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 24 Mar 2019 11:18:59 +0100 Subject: [PATCH 03/47] modernized - no pInt - consistent indentation by 2 spaces - no leftovers from old file parsing --- src/constitutive.f90 | 3 +- src/source_thermal_externalheat.f90 | 135 +++++++++++++--------------- 2 files changed, 64 insertions(+), 74 deletions(-) diff --git a/src/constitutive.f90 b/src/constitutive.f90 index dfe8679c3..96b29d846 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -877,7 +877,8 @@ subroutine constitutive_collectDotState(S, FeArray, Fi, FpArray, subdt, ipc, ip, call source_damage_anisoDuctile_dotState ( ipc, ip, el) case (SOURCE_thermal_externalheat_ID) sourceType - call source_thermal_externalheat_dotState( ipc, ip, el) + of = phasememberAt(ipc,ip,el) + call source_thermal_externalheat_dotState(material_phase(ipc,ip,el),of) end select sourceType diff --git a/src/source_thermal_externalheat.f90 b/src/source_thermal_externalheat.f90 index 3723d6196..377513c57 100644 --- a/src/source_thermal_externalheat.f90 +++ b/src/source_thermal_externalheat.f90 @@ -6,29 +6,28 @@ !-------------------------------------------------------------------------------------------------- module source_thermal_externalheat use prec, only: & - pReal, & - pInt + pReal implicit none private - integer(pInt), dimension(:), allocatable, public, protected :: & + integer, dimension(:), allocatable, public, protected :: & source_thermal_externalheat_offset, & !< which source is my current thermal dissipation mechanism? source_thermal_externalheat_instance !< instance of thermal dissipation source mechanism - integer(pInt), dimension(:,:), allocatable, target, public :: & + integer, dimension(:,:), allocatable, target, public :: & source_thermal_externalheat_sizePostResult !< size of each post result output - character(len=64), dimension(:,:), allocatable, target, public :: & + character(len=64), dimension(:,:), allocatable, target, public :: & source_thermal_externalheat_output !< name of each post result output - integer(pInt), dimension(:), allocatable, target, public :: & + integer, dimension(:), allocatable, target, public :: & source_thermal_externalheat_Noutput !< number of outputs per instance of this source type, private :: tParameters !< container type for internal constitutive parameters real(pReal), dimension(:), allocatable :: & time, & heat_rate - integer(pInt) :: & + integer :: & nIntervals end type tParameters @@ -66,20 +65,18 @@ subroutine source_thermal_externalheat_init implicit none - real(pReal), allocatable, dimension(:) :: tempVar - integer(pInt) :: maxNinstance,instance,source,sourceOffset - integer(pInt) :: NofMyPhase,p + integer :: maxNinstance,instance,source,sourceOffset,NofMyPhase,p write(6,'(/,a)') ' <<<+- source_'//SOURCE_thermal_externalheat_label//' init -+>>>' - maxNinstance = int(count(phase_source == SOURCE_thermal_externalheat_ID),pInt) - if (maxNinstance == 0_pInt) return - if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & + maxNinstance = count(phase_source == SOURCE_thermal_externalheat_ID) + if (maxNinstance == 0) return + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0) & write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance - allocate(source_thermal_externalheat_offset(material_Nphase), source=0_pInt) - allocate(source_thermal_externalheat_instance(material_Nphase), source=0_pInt) + allocate(source_thermal_externalheat_offset(material_Nphase), source=0) + allocate(source_thermal_externalheat_instance(material_Nphase), source=0) do p = 1, material_Nphase source_thermal_externalheat_instance(p) = count(phase_source(:,1:p) == SOURCE_thermal_externalheat_ID) @@ -89,10 +86,10 @@ subroutine source_thermal_externalheat_init enddo enddo - allocate(source_thermal_externalheat_sizePostResult(maxval(phase_Noutput),maxNinstance),source=0_pInt) + allocate(source_thermal_externalheat_sizePostResult(maxval(phase_Noutput),maxNinstance),source=0) allocate(source_thermal_externalheat_output (maxval(phase_Noutput),maxNinstance)) source_thermal_externalheat_output = '' - allocate(source_thermal_externalheat_Noutput(maxNinstance), source=0_pInt) + allocate(source_thermal_externalheat_Noutput(maxNinstance), source=0) allocate(param(maxNinstance)) @@ -102,15 +99,13 @@ subroutine source_thermal_externalheat_init sourceOffset = source_thermal_externalheat_offset(p) NofMyPhase=count(material_phase==p) - tempVar = config_phase(p)%getFloats('externalheat_time') - param(instance)%nIntervals = size(tempVar) - 1_pInt + param(instance)%time = config_phase(p)%getFloats('externalheat_time') + param(instance)%nIntervals = size(param(instance)%time) - 1 - param(instance)%time= tempVar - tempVar = config_phase(p)%getFloats('externalheat_rate',requiredSize = size(tempVar)) - param(instance)%heat_rate = tempVar + param(instance)%heat_rate = config_phase(p)%getFloats('externalheat_rate',requiredSize = size(param(instance)%time)) - call material_allocateSourceState(p,sourceOffset,NofMyPhase,1_pInt,1_pInt,0_pInt) + call material_allocateSourceState(p,sourceOffset,NofMyPhase,1,1,0) enddo @@ -121,64 +116,58 @@ end subroutine source_thermal_externalheat_init !> @brief rate of change of state !> @details state only contains current time to linearly interpolate given heat powers !-------------------------------------------------------------------------------------------------- -subroutine source_thermal_externalheat_dotState(ipc, ip, el) - use material, only: & - phaseAt, phasememberAt, & - sourceState - - implicit none - integer(pInt), intent(in) :: & - ipc, & !< component-ID of integration point - ip, & !< integration point - el !< element - integer(pInt) :: & - phase, & - constituent, & - sourceOffset - - phase = phaseAt(ipc,ip,el) - constituent = phasememberAt(ipc,ip,el) - sourceOffset = source_thermal_externalheat_offset(phase) +subroutine source_thermal_externalheat_dotState(phase, of) + use material, only: & + sourceState - sourceState(phase)%p(sourceOffset)%dotState(1,constituent) = 1.0_pReal ! state is current time + implicit none + integer, intent(in) :: & + phase, & + of + integer :: & + sourceOffset + + sourceOffset = source_thermal_externalheat_offset(phase) + + sourceState(phase)%p(sourceOffset)%dotState(1,of) = 1.0_pReal ! state is current time end subroutine source_thermal_externalheat_dotState !-------------------------------------------------------------------------------------------------- !> @brief returns local heat generation rate !-------------------------------------------------------------------------------------------------- -subroutine source_thermal_externalheat_getRateAndItsTangent(TDot, dTDot_dT, phase, constituent) - use material, only: & - sourceState - - implicit none - integer(pInt), intent(in) :: & - phase, & - constituent - real(pReal), intent(out) :: & - TDot, & - dTDot_dT - integer(pInt) :: & - instance, sourceOffset, interval - real(pReal) :: & - frac_time - - instance = source_thermal_externalheat_instance(phase) - sourceOffset = source_thermal_externalheat_offset(phase) - - do interval = 1, param(instance)%nIntervals ! scan through all rate segments - frac_time = (sourceState(phase)%p(sourceOffset)%state(1,constituent) - & - param(instance)%time(interval)) / & - (param(instance)%time(interval+1) - & - param(instance)%time(interval)) ! fractional time within segment - if ( (frac_time < 0.0_pReal .and. interval == 1) & - .or. (frac_time >= 1.0_pReal .and. interval == param(instance)%nIntervals) & - .or. (frac_time >= 0.0_pReal .and. frac_time < 1.0_pReal) ) & - TDot = param(instance)%heat_rate(interval ) * (1.0_pReal - frac_time) + & - param(instance)%heat_rate(interval+1) * frac_time ! interpolate heat rate between segment boundaries... +subroutine source_thermal_externalheat_getRateAndItsTangent(TDot, dTDot_dT, phase, of) + use material, only: & + sourceState + + implicit none + integer, intent(in) :: & + phase, & + of + real(pReal), intent(out) :: & + TDot, & + dTDot_dT + integer :: & + instance, sourceOffset, interval + real(pReal) :: & + frac_time + + instance = source_thermal_externalheat_instance(phase) + sourceOffset = source_thermal_externalheat_offset(phase) + + do interval = 1, param(instance)%nIntervals ! scan through all rate segments + frac_time = (sourceState(phase)%p(sourceOffset)%state(1,of) - & + param(instance)%time(interval)) / & + (param(instance)%time(interval+1) - & + param(instance)%time(interval)) ! fractional time within segment + if ( (frac_time < 0.0_pReal .and. interval == 1) & + .or. (frac_time >= 1.0_pReal .and. interval == param(instance)%nIntervals) & + .or. (frac_time >= 0.0_pReal .and. frac_time < 1.0_pReal) ) & + TDot = param(instance)%heat_rate(interval ) * (1.0_pReal - frac_time) + & + param(instance)%heat_rate(interval+1) * frac_time ! interpolate heat rate between segment boundaries... ! ...or extrapolate if outside of bounds - enddo - dTDot_dT = 0.0 + enddo + dTDot_dT = 0.0 end subroutine source_thermal_externalheat_getRateAndItsTangent From dada4e69b6c8c622d724f034938b75ec5f462b32 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 24 Mar 2019 11:28:20 +0100 Subject: [PATCH 04/47] consistent use of 2 blanks, no pInt --- src/thermal_adiabatic.f90 | 552 +++++++++++++++++++------------------- 1 file changed, 276 insertions(+), 276 deletions(-) diff --git a/src/thermal_adiabatic.f90 b/src/thermal_adiabatic.f90 index ce6656188..8fdf55c97 100644 --- a/src/thermal_adiabatic.f90 +++ b/src/thermal_adiabatic.f90 @@ -1,40 +1,38 @@ !-------------------------------------------------------------------------------------------------- !> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH !> @brief material subroutine for adiabatic temperature evolution -!> @details to be done !-------------------------------------------------------------------------------------------------- module thermal_adiabatic - use prec, only: & - pReal, & - pInt - - implicit none - private - - integer(pInt), dimension(:,:), allocatable, target, public :: & - thermal_adiabatic_sizePostResult !< size of each post result output - character(len=64), dimension(:,:), allocatable, target, public :: & - thermal_adiabatic_output !< name of each post result output - - integer(pInt), dimension(:), allocatable, target, public :: & - thermal_adiabatic_Noutput !< number of outputs per instance of this thermal model - - enum, bind(c) - enumerator :: undefined_ID, & - temperature_ID - end enum - integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & - thermal_adiabatic_outputID !< ID of each post result output - - - public :: & - thermal_adiabatic_init, & - thermal_adiabatic_updateState, & - thermal_adiabatic_getSourceAndItsTangent, & - thermal_adiabatic_getSpecificHeat, & - thermal_adiabatic_getMassDensity, & - thermal_adiabatic_postResults - + use prec, only: & + pReal + + implicit none + private + + integer, dimension(:,:), allocatable, target, public :: & + thermal_adiabatic_sizePostResult !< size of each post result output + character(len=64), dimension(:,:), allocatable, target, public :: & + thermal_adiabatic_output !< name of each post result output + + integer, dimension(:), allocatable, target, public :: & + thermal_adiabatic_Noutput !< number of outputs per instance of this thermal model + + enum, bind(c) + enumerator :: undefined_ID, & + temperature_ID + end enum + integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & + thermal_adiabatic_outputID !< ID of each post result output + + + public :: & + thermal_adiabatic_init, & + thermal_adiabatic_updateState, & + thermal_adiabatic_getSourceAndItsTangent, & + thermal_adiabatic_getSpecificHeat, & + thermal_adiabatic_getMassDensity, & + thermal_adiabatic_postResults + contains @@ -43,195 +41,196 @@ contains !> @details reads in material parameters, allocates arrays, and does sanity checks !-------------------------------------------------------------------------------------------------- subroutine thermal_adiabatic_init - use material, only: & - thermal_type, & - thermal_typeInstance, & - homogenization_Noutput, & - THERMAL_ADIABATIC_label, & - THERMAL_adiabatic_ID, & - material_homogenizationAt, & - mappingHomogenization, & - thermalState, & - thermalMapping, & - thermal_initialT, & - temperature, & - temperatureRate - use config, only: & - config_homogenization - - implicit none - integer(pInt) :: maxNinstance,section,instance,i - integer(pInt) :: sizeState - integer(pInt) :: NofMyHomog - character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] - character(len=65536), dimension(:), allocatable :: outputs - - write(6,'(/,a)') ' <<<+- thermal_'//THERMAL_ADIABATIC_label//' init -+>>>' + use material, only: & + thermal_type, & + thermal_typeInstance, & + homogenization_Noutput, & + THERMAL_ADIABATIC_label, & + THERMAL_adiabatic_ID, & + material_homogenizationAt, & + mappingHomogenization, & + thermalState, & + thermalMapping, & + thermal_initialT, & + temperature, & + temperatureRate + use config, only: & + config_homogenization - maxNinstance = int(count(thermal_type == THERMAL_adiabatic_ID),pInt) - if (maxNinstance == 0_pInt) return + implicit none + integer :: maxNinstance,section,instance,i,sizeState,NofMyHomog + character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] + character(len=65536), dimension(:), allocatable :: outputs - allocate(thermal_adiabatic_sizePostResult (maxval(homogenization_Noutput),maxNinstance),source=0_pInt) - allocate(thermal_adiabatic_output (maxval(homogenization_Noutput),maxNinstance)) - thermal_adiabatic_output = '' - allocate(thermal_adiabatic_outputID (maxval(homogenization_Noutput),maxNinstance),source=undefined_ID) - allocate(thermal_adiabatic_Noutput (maxNinstance), source=0_pInt) - + write(6,'(/,a)') ' <<<+- thermal_'//THERMAL_ADIABATIC_label//' init -+>>>' + + maxNinstance = count(thermal_type == THERMAL_adiabatic_ID) + if (maxNinstance == 0) return + + allocate(thermal_adiabatic_sizePostResult (maxval(homogenization_Noutput),maxNinstance),source=0) + allocate(thermal_adiabatic_output (maxval(homogenization_Noutput),maxNinstance)) + thermal_adiabatic_output = '' + allocate(thermal_adiabatic_outputID (maxval(homogenization_Noutput),maxNinstance),source=undefined_ID) + allocate(thermal_adiabatic_Noutput (maxNinstance), source=0) - initializeInstances: do section = 1_pInt, size(thermal_type) - if (thermal_type(section) /= THERMAL_adiabatic_ID) cycle - NofMyHomog=count(material_homogenizationAt==section) - instance = thermal_typeInstance(section) - outputs = config_homogenization(section)%getStrings('(output)',defaultVal=emptyStringArray) - do i=1_pInt, size(outputs) - select case(outputs(i)) - case('temperature') - thermal_adiabatic_Noutput(instance) = thermal_adiabatic_Noutput(instance) + 1_pInt - thermal_adiabatic_outputID(thermal_adiabatic_Noutput(instance),instance) = temperature_ID - thermal_adiabatic_output(thermal_adiabatic_Noutput(instance),instance) = outputs(i) - thermal_adiabatic_sizePostResult(thermal_adiabatic_Noutput(instance),instance) = 1_pInt - end select - enddo - -! allocate state arrays - sizeState = 1_pInt - thermalState(section)%sizeState = sizeState - thermalState(section)%sizePostResults = sum(thermal_adiabatic_sizePostResult(:,instance)) - allocate(thermalState(section)%state0 (sizeState,NofMyHomog), source=thermal_initialT(section)) - allocate(thermalState(section)%subState0(sizeState,NofMyHomog), source=thermal_initialT(section)) - allocate(thermalState(section)%state (sizeState,NofMyHomog), source=thermal_initialT(section)) - - nullify(thermalMapping(section)%p) - thermalMapping(section)%p => mappingHomogenization(1,:,:) - deallocate(temperature(section)%p) - temperature(section)%p => thermalState(section)%state(1,:) - deallocate(temperatureRate(section)%p) - allocate (temperatureRate(section)%p(NofMyHomog), source=0.0_pReal) - - enddo initializeInstances + + initializeInstances: do section = 1, size(thermal_type) + if (thermal_type(section) /= THERMAL_adiabatic_ID) cycle + NofMyHomog=count(material_homogenizationAt==section) + instance = thermal_typeInstance(section) + outputs = config_homogenization(section)%getStrings('(output)',defaultVal=emptyStringArray) + do i=1, size(outputs) + select case(outputs(i)) + case('temperature') + thermal_adiabatic_Noutput(instance) = thermal_adiabatic_Noutput(instance) + 1 + thermal_adiabatic_outputID(thermal_adiabatic_Noutput(instance),instance) = temperature_ID + thermal_adiabatic_output(thermal_adiabatic_Noutput(instance),instance) = outputs(i) + thermal_adiabatic_sizePostResult(thermal_adiabatic_Noutput(instance),instance) = 1 + end select + enddo + + ! allocate state arrays + sizeState = 1 + thermalState(section)%sizeState = sizeState + thermalState(section)%sizePostResults = sum(thermal_adiabatic_sizePostResult(:,instance)) + allocate(thermalState(section)%state0 (sizeState,NofMyHomog), source=thermal_initialT(section)) + allocate(thermalState(section)%subState0(sizeState,NofMyHomog), source=thermal_initialT(section)) + allocate(thermalState(section)%state (sizeState,NofMyHomog), source=thermal_initialT(section)) + + nullify(thermalMapping(section)%p) + thermalMapping(section)%p => mappingHomogenization(1,:,:) + deallocate(temperature(section)%p) + temperature(section)%p => thermalState(section)%state(1,:) + deallocate(temperatureRate(section)%p) + allocate (temperatureRate(section)%p(NofMyHomog), source=0.0_pReal) + + enddo initializeInstances end subroutine thermal_adiabatic_init + !-------------------------------------------------------------------------------------------------- !> @brief calculates adiabatic change in temperature based on local heat generation model !-------------------------------------------------------------------------------------------------- function thermal_adiabatic_updateState(subdt, ip, el) - use numerics, only: & - err_thermal_tolAbs, & - err_thermal_tolRel - use material, only: & - material_homogenizationAt, & - mappingHomogenization, & - thermalState, & - temperature, & - temperatureRate, & - thermalMapping - - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point number - el !< element number - real(pReal), intent(in) :: & - subdt - logical, dimension(2) :: & - thermal_adiabatic_updateState - integer(pInt) :: & - homog, & - offset - real(pReal) :: & - T, Tdot, dTdot_dT + use numerics, only: & + err_thermal_tolAbs, & + err_thermal_tolRel + use material, only: & + material_homogenizationAt, & + mappingHomogenization, & + thermalState, & + temperature, & + temperatureRate, & + thermalMapping + + implicit none + integer, intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), intent(in) :: & + subdt - homog = material_homogenizationAt(el) - offset = mappingHomogenization(1,ip,el) + logical, dimension(2) :: & + thermal_adiabatic_updateState + integer :: & + homog, & + offset + real(pReal) :: & + T, Tdot, dTdot_dT - T = thermalState(homog)%subState0(1,offset) - call thermal_adiabatic_getSourceAndItsTangent(Tdot, dTdot_dT, T, ip, el) - T = T + subdt*Tdot/(thermal_adiabatic_getSpecificHeat(ip,el)*thermal_adiabatic_getMassDensity(ip,el)) - - thermal_adiabatic_updateState = [ abs(T - thermalState(homog)%state(1,offset)) & - <= err_thermal_tolAbs & - .or. abs(T - thermalState(homog)%state(1,offset)) & - <= err_thermal_tolRel*abs(thermalState(homog)%state(1,offset)), & - .true.] - - temperature (homog)%p(thermalMapping(homog)%p(ip,el)) = T - temperatureRate(homog)%p(thermalMapping(homog)%p(ip,el)) = & - (thermalState(homog)%state(1,offset) - thermalState(homog)%subState0(1,offset))/(subdt+tiny(0.0_pReal)) + homog = material_homogenizationAt(el) + offset = mappingHomogenization(1,ip,el) + + T = thermalState(homog)%subState0(1,offset) + call thermal_adiabatic_getSourceAndItsTangent(Tdot, dTdot_dT, T, ip, el) + T = T + subdt*Tdot/(thermal_adiabatic_getSpecificHeat(ip,el)*thermal_adiabatic_getMassDensity(ip,el)) + + thermal_adiabatic_updateState = [ abs(T - thermalState(homog)%state(1,offset)) & + <= err_thermal_tolAbs & + .or. abs(T - thermalState(homog)%state(1,offset)) & + <= err_thermal_tolRel*abs(thermalState(homog)%state(1,offset)), & + .true.] + temperature (homog)%p(thermalMapping(homog)%p(ip,el)) = T + temperatureRate(homog)%p(thermalMapping(homog)%p(ip,el)) = & + (thermalState(homog)%state(1,offset) - thermalState(homog)%subState0(1,offset))/(subdt+tiny(0.0_pReal)) + end function thermal_adiabatic_updateState !-------------------------------------------------------------------------------------------------- !> @brief returns heat generation rate !-------------------------------------------------------------------------------------------------- subroutine thermal_adiabatic_getSourceAndItsTangent(Tdot, dTdot_dT, T, ip, el) - use material, only: & - homogenization_Ngrains, & - material_homogenizationAt, & - mappingHomogenization, & - phaseAt, & - phasememberAt, & - thermal_typeInstance, & - phase_Nsources, & - phase_source, & - SOURCE_thermal_dissipation_ID, & - SOURCE_thermal_externalheat_ID - use source_thermal_dissipation, only: & - source_thermal_dissipation_getRateAndItsTangent - use source_thermal_externalheat, only: & - source_thermal_externalheat_getRateAndItsTangent - use crystallite, only: & - crystallite_S, & - crystallite_Lp - - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point number - el !< element number - real(pReal), intent(in) :: & - T - real(pReal), intent(out) :: & - Tdot, dTdot_dT - real(pReal) :: & - my_Tdot, my_dTdot_dT - integer(pInt) :: & - phase, & - homog, & - instance, & - grain, & - source, & - constituent - - homog = material_homogenizationAt(el) - instance = thermal_typeInstance(homog) - - Tdot = 0.0_pReal - dTdot_dT = 0.0_pReal - do grain = 1, homogenization_Ngrains(homog) - phase = phaseAt(grain,ip,el) - constituent = phasememberAt(grain,ip,el) - do source = 1, phase_Nsources(phase) - select case(phase_source(source,phase)) - case (SOURCE_thermal_dissipation_ID) - call source_thermal_dissipation_getRateAndItsTangent(my_Tdot, my_dTdot_dT, & - crystallite_S(1:3,1:3,grain,ip,el), & - crystallite_Lp(1:3,1:3,grain,ip,el), & - phase) - - case (SOURCE_thermal_externalheat_ID) - call source_thermal_externalheat_getRateAndItsTangent(my_Tdot, my_dTdot_dT, & - phase, constituent) - - case default - my_Tdot = 0.0_pReal - my_dTdot_dT = 0.0_pReal - end select - Tdot = Tdot + my_Tdot - dTdot_dT = dTdot_dT + my_dTdot_dT - enddo - enddo + use material, only: & + homogenization_Ngrains, & + material_homogenizationAt, & + mappingHomogenization, & + phaseAt, & + phasememberAt, & + thermal_typeInstance, & + phase_Nsources, & + phase_source, & + SOURCE_thermal_dissipation_ID, & + SOURCE_thermal_externalheat_ID + use source_thermal_dissipation, only: & + source_thermal_dissipation_getRateAndItsTangent + use source_thermal_externalheat, only: & + source_thermal_externalheat_getRateAndItsTangent + use crystallite, only: & + crystallite_S, & + crystallite_Lp - Tdot = Tdot/real(homogenization_Ngrains(homog),pReal) - dTdot_dT = dTdot_dT/real(homogenization_Ngrains(homog),pReal) + implicit none + integer, intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), intent(in) :: & + T + real(pReal), intent(out) :: & + Tdot, dTdot_dT + + real(pReal) :: & + my_Tdot, my_dTdot_dT + integer :: & + phase, & + homog, & + instance, & + grain, & + source, & + constituent + + homog = material_homogenizationAt(el) + instance = thermal_typeInstance(homog) + + Tdot = 0.0_pReal + dTdot_dT = 0.0_pReal + do grain = 1, homogenization_Ngrains(homog) + phase = phaseAt(grain,ip,el) + constituent = phasememberAt(grain,ip,el) + do source = 1, phase_Nsources(phase) + select case(phase_source(source,phase)) + case (SOURCE_thermal_dissipation_ID) + call source_thermal_dissipation_getRateAndItsTangent(my_Tdot, my_dTdot_dT, & + crystallite_S(1:3,1:3,grain,ip,el), & + crystallite_Lp(1:3,1:3,grain,ip,el), & + phase) + + case (SOURCE_thermal_externalheat_ID) + call source_thermal_externalheat_getRateAndItsTangent(my_Tdot, my_dTdot_dT, & + phase, constituent) + + case default + my_Tdot = 0.0_pReal + my_dTdot_dT = 0.0_pReal + end select + Tdot = Tdot + my_Tdot + dTdot_dT = dTdot_dT + my_dTdot_dT + enddo + enddo + + Tdot = Tdot/real(homogenization_Ngrains(homog),pReal) + dTdot_dT = dTdot_dT/real(homogenization_Ngrains(homog),pReal) end subroutine thermal_adiabatic_getSourceAndItsTangent @@ -239,34 +238,35 @@ end subroutine thermal_adiabatic_getSourceAndItsTangent !> @brief returns homogenized specific heat capacity !-------------------------------------------------------------------------------------------------- function thermal_adiabatic_getSpecificHeat(ip,el) - use lattice, only: & - lattice_specificHeat - use material, only: & - homogenization_Ngrains, & - material_phase - use mesh, only: & - mesh_element - - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point number - el !< element number - real(pReal) :: & - thermal_adiabatic_getSpecificHeat - integer(pInt) :: & - grain - - thermal_adiabatic_getSpecificHeat = 0.0_pReal + use lattice, only: & + lattice_specificHeat + use material, only: & + homogenization_Ngrains, & + material_phase + use mesh, only: & + mesh_element + implicit none + integer, intent(in) :: & + ip, & !< integration point number + el !< element number - do grain = 1, homogenization_Ngrains(mesh_element(3,el)) - thermal_adiabatic_getSpecificHeat = thermal_adiabatic_getSpecificHeat + & - lattice_specificHeat(material_phase(grain,ip,el)) - enddo - - thermal_adiabatic_getSpecificHeat = & - thermal_adiabatic_getSpecificHeat/real(homogenization_Ngrains(mesh_element(3,el)),pReal) + real(pReal) :: & + thermal_adiabatic_getSpecificHeat + integer :: & + grain + + thermal_adiabatic_getSpecificHeat = 0.0_pReal + + + do grain = 1, homogenization_Ngrains(mesh_element(3,el)) + thermal_adiabatic_getSpecificHeat = thermal_adiabatic_getSpecificHeat + & + lattice_specificHeat(material_phase(grain,ip,el)) + enddo + thermal_adiabatic_getSpecificHeat = & + thermal_adiabatic_getSpecificHeat/real(homogenization_Ngrains(mesh_element(3,el)),pReal) + end function thermal_adiabatic_getSpecificHeat @@ -274,33 +274,33 @@ end function thermal_adiabatic_getSpecificHeat !> @brief returns homogenized mass density !-------------------------------------------------------------------------------------------------- function thermal_adiabatic_getMassDensity(ip,el) - use lattice, only: & - lattice_massDensity - use material, only: & - homogenization_Ngrains, & - material_phase - use mesh, only: & - mesh_element + use lattice, only: & + lattice_massDensity + use material, only: & + homogenization_Ngrains, & + material_phase + use mesh, only: & + mesh_element + + implicit none + integer, intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal) :: & + thermal_adiabatic_getMassDensity + integer :: & + grain - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point number - el !< element number - real(pReal) :: & - thermal_adiabatic_getMassDensity - integer(pInt) :: & - grain - - thermal_adiabatic_getMassDensity = 0.0_pReal - - - do grain = 1, homogenization_Ngrains(mesh_element(3,el)) - thermal_adiabatic_getMassDensity = thermal_adiabatic_getMassDensity + & - lattice_massDensity(material_phase(grain,ip,el)) - enddo - - thermal_adiabatic_getMassDensity = & - thermal_adiabatic_getMassDensity/real(homogenization_Ngrains(mesh_element(3,el)),pReal) + thermal_adiabatic_getMassDensity = 0.0_pReal + + + do grain = 1, homogenization_Ngrains(mesh_element(3,el)) + thermal_adiabatic_getMassDensity = thermal_adiabatic_getMassDensity + & + lattice_massDensity(material_phase(grain,ip,el)) + enddo + + thermal_adiabatic_getMassDensity = & + thermal_adiabatic_getMassDensity/real(homogenization_Ngrains(mesh_element(3,el)),pReal) end function thermal_adiabatic_getMassDensity @@ -309,31 +309,31 @@ end function thermal_adiabatic_getMassDensity !> @brief return array of thermal results !-------------------------------------------------------------------------------------------------- function thermal_adiabatic_postResults(homog,instance,of) result(postResults) - use material, only: & - temperature - - implicit none - integer(pInt), intent(in) :: & - homog, & - instance, & - of - - real(pReal), dimension(sum(thermal_adiabatic_sizePostResult(:,instance))) :: & - postResults - - integer(pInt) :: & - o, c - - c = 0_pInt - - do o = 1_pInt,thermal_adiabatic_Noutput(instance) - select case(thermal_adiabatic_outputID(o,instance)) + use material, only: & + temperature - case (temperature_ID) - postResults(c+1_pInt) = temperature(homog)%p(of) - c = c + 1 - end select - enddo + implicit none + integer, intent(in) :: & + homog, & + instance, & + of + + real(pReal), dimension(sum(thermal_adiabatic_sizePostResult(:,instance))) :: & + postResults + + integer :: & + o, c + + c = 0 + + do o = 1,thermal_adiabatic_Noutput(instance) + select case(thermal_adiabatic_outputID(o,instance)) + + case (temperature_ID) + postResults(c+1) = temperature(homog)%p(of) + c = c + 1 + end select + enddo end function thermal_adiabatic_postResults From 728dac5a487f8ec098aee35c946c05846faac486 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 24 Mar 2019 11:40:05 +0100 Subject: [PATCH 05/47] separate module for linked list --- src/list.f90 | 506 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 506 insertions(+) create mode 100644 src/list.f90 diff --git a/src/list.f90 b/src/list.f90 new file mode 100644 index 000000000..93c19b903 --- /dev/null +++ b/src/list.f90 @@ -0,0 +1,506 @@ +!------------------------------------------------------------------------------------------------- +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @brief linked list +!-------------------------------------------------------------------------------------------------- +module list + use prec, only: & + pReal + + implicit none + private + type, private :: tPartitionedString + character(len=:), allocatable :: val + integer, dimension(:), allocatable :: pos + end type tPartitionedString + + type, public :: tPartitionedStringList + type(tPartitionedString) :: string + type(tPartitionedStringList), pointer :: next => null() + contains + procedure :: add => add + procedure :: show => show + procedure :: free => free + + ! currently, a finalize is needed for all shapes of tPartitionedStringList. + ! with Fortran 2015, we can define one recursive elemental function + ! https://software.intel.com/en-us/forums/intel-visual-fortran-compiler-for-windows/topic/543326 + final :: finalize, & + finalizeArray + + procedure :: keyExists => keyExists + procedure :: countKeys => countKeys + + procedure :: getFloat => getFloat + procedure :: getInt => getInt + procedure :: getString => getString + + procedure :: getFloats => getFloats + procedure :: getInts => getInts + procedure :: getStrings => getStrings + + + end type tPartitionedStringList + + private :: & + add, & + show, & + free, & + finalize, & + finalizeArray, & + keyExists, & + countKeys, & + getFloat, & + getInt, & + getString, & + getFloats, & + getInts, & + getStrings + +contains + +!-------------------------------------------------------------------------------------------------- +!> @brief add element +!> @details Adds a string together with the start/end position of chunks in this string. The new +!! element is added at the end of the list. Empty strings are not added. All strings are converted +!! to lower case. The data is not stored in the new element but in the current. +!-------------------------------------------------------------------------------------------------- +subroutine add(this,string) + use IO, only: & + IO_isBlank, & + IO_lc, & + IO_stringPos + + implicit none + class(tPartitionedStringList), target, intent(in) :: this + character(len=*), intent(in) :: string + type(tPartitionedStringList), pointer :: new, temp + + if (IO_isBlank(string)) return + + allocate(new) + temp => this + do while (associated(temp%next)) + temp => temp%next + enddo + temp%string%val = IO_lc (trim(string)) + temp%string%pos = IO_stringPos(trim(string)) + temp%next => new + +end subroutine add + + +!-------------------------------------------------------------------------------------------------- +!> @brief prints all elements +!> @details Strings are printed in order of insertion (FIFO) +!-------------------------------------------------------------------------------------------------- +subroutine show(this) + + implicit none + class(tPartitionedStringList), target, intent(in) :: this + type(tPartitionedStringList), pointer :: item + + item => this + do while (associated(item%next)) + write(6,'(a)') ' '//trim(item%string%val) + item => item%next + enddo + +end subroutine show + + +!-------------------------------------------------------------------------------------------------- +!> @brief empties list and frees associated memory +!> @details explicit interface to reset list. Triggers final statement (and following chain reaction) +!-------------------------------------------------------------------------------------------------- +subroutine free(this) + + implicit none + class(tPartitionedStringList), intent(inout) :: this + + if(associated(this%next)) deallocate(this%next) + +end subroutine free + + +!-------------------------------------------------------------------------------------------------- +!> @brief empties list and frees associated memory +!> @details called when variable goes out of scope. Triggers chain reaction for list +!-------------------------------------------------------------------------------------------------- +recursive subroutine finalize(this) + + implicit none + type(tPartitionedStringList), intent(inout) :: this + + if(associated(this%next)) deallocate(this%next) + +end subroutine finalize + + +!-------------------------------------------------------------------------------------------------- +!> @brief cleans entire array of linke lists +!> @details called when variable goes out of scope and deallocates the list at each array entry +!-------------------------------------------------------------------------------------------------- +subroutine finalizeArray(this) + + implicit none + integer :: i + type(tPartitionedStringList), intent(inout), dimension(:) :: this + type(tPartitionedStringList), pointer :: temp ! bug in Gfortran? + + do i=1, size(this) + if (associated(this(i)%next)) then + temp => this(i)%next + !deallocate(this(i)) !internal compiler error: in gfc_build_final_call, at fortran/trans.c:975 + deallocate(temp) + endif + enddo + +end subroutine finalizeArray + + +!-------------------------------------------------------------------------------------------------- +!> @brief reports wether a given key (string value at first position) exists in the list +!-------------------------------------------------------------------------------------------------- +logical function keyExists(this,key) + use IO, only: & + IO_stringValue + + implicit none + class(tPartitionedStringList), target, intent(in) :: this + character(len=*), intent(in) :: key + type(tPartitionedStringList), pointer :: item + + keyExists = .false. + + item => this + do while (associated(item%next) .and. .not. keyExists) + keyExists = trim(IO_stringValue(item%string%val,item%string%pos,1)) == trim(key) + item => item%next + enddo + +end function keyExists + + +!-------------------------------------------------------------------------------------------------- +!> @brief count number of key appearances +!> @details traverses list and counts each occurrence of specified key +!-------------------------------------------------------------------------------------------------- +integer function countKeys(this,key) + use IO, only: & + IO_stringValue + + implicit none + + class(tPartitionedStringList), target, intent(in) :: this + character(len=*), intent(in) :: key + type(tPartitionedStringList), pointer :: item + + countKeys = 0 + + item => this + do while (associated(item%next)) + if (trim(IO_stringValue(item%string%val,item%string%pos,1)) == trim(key)) & + countKeys = countKeys + 1 + item => item%next + enddo + +end function countKeys + + +!-------------------------------------------------------------------------------------------------- +!> @brief gets float value of for a given key from a linked list +!> @details gets the last value if the key occurs more than once. If key is not found exits with +!! error unless default is given +!-------------------------------------------------------------------------------------------------- +real(pReal) function getFloat(this,key,defaultVal) + use IO, only : & + IO_error, & + IO_stringValue, & + IO_FloatValue + + implicit none + class(tPartitionedStringList), target, intent(in) :: this + character(len=*), intent(in) :: key + real(pReal), intent(in), optional :: defaultVal + type(tPartitionedStringList), pointer :: item + logical :: found + + found = present(defaultVal) + if (found) getFloat = defaultVal + + item => this + do while (associated(item%next)) + if (trim(IO_stringValue(item%string%val,item%string%pos,1)) == trim(key)) then + found = .true. + if (item%string%pos(1) < 2) call IO_error(143,ext_msg=key) + getFloat = IO_FloatValue(item%string%val,item%string%pos,2) + endif + item => item%next + enddo + + if (.not. found) call IO_error(140,ext_msg=key) + +end function getFloat + + +!-------------------------------------------------------------------------------------------------- +!> @brief gets integer value of for a given key from a linked list +!> @details gets the last value if the key occurs more than once. If key is not found exits with +!! error unless default is given +!-------------------------------------------------------------------------------------------------- +integer function getInt(this,key,defaultVal) + use IO, only: & + IO_error, & + IO_stringValue, & + IO_IntValue + + implicit none + class(tPartitionedStringList), target, intent(in) :: this + character(len=*), intent(in) :: key + integer, intent(in), optional :: defaultVal + type(tPartitionedStringList), pointer :: item + logical :: found + + found = present(defaultVal) + if (found) getInt = defaultVal + + item => this + do while (associated(item%next)) + if (trim(IO_stringValue(item%string%val,item%string%pos,1)) == trim(key)) then + found = .true. + if (item%string%pos(1) < 2) call IO_error(143,ext_msg=key) + getInt = IO_IntValue(item%string%val,item%string%pos,2) + endif + item => item%next + enddo + + if (.not. found) call IO_error(140,ext_msg=key) + +end function getInt + + +!-------------------------------------------------------------------------------------------------- +!> @brief gets string value of for a given key from a linked list +!> @details gets the last value if the key occurs more than once. If key is not found exits with +!! error unless default is given. If raw is true, the the complete string is returned, otherwise +!! the individual chunks are returned +!-------------------------------------------------------------------------------------------------- +character(len=65536) function getString(this,key,defaultVal,raw) + use IO, only: & + IO_error, & + IO_stringValue + + implicit none + class(tPartitionedStringList), target, intent(in) :: this + character(len=*), intent(in) :: key + character(len=65536), intent(in), optional :: defaultVal + logical, intent(in), optional :: raw + type(tPartitionedStringList), pointer :: item + logical :: found, & + whole + if (present(raw)) then + whole = raw + else + whole = .false. + endif + + found = present(defaultVal) + if (found) then + getString = trim(defaultVal) + if (len_trim(getString) /= len_trim(defaultVal)) call IO_error(0,ext_msg='getString') + endif + + item => this + do while (associated(item%next)) + if (trim(IO_stringValue(item%string%val,item%string%pos,1)) == trim(key)) then + found = .true. + if (item%string%pos(1) < 2) call IO_error(143,ext_msg=key) + + if (whole) then + getString = trim(item%string%val(item%string%pos(4):)) ! raw string starting a second chunk + else + getString = IO_StringValue(item%string%val,item%string%pos,2) + endif + endif + item => item%next + enddo + + if (.not. found) call IO_error(140,ext_msg=key) + +end function getString + + +!-------------------------------------------------------------------------------------------------- +!> @brief gets array of float values of for a given key from a linked list +!> @details for cumulative keys, "()", values from all occurrences are return. Otherwise only all +!! values from the last occurrence. If key is not found exits with error unless default is given. +!-------------------------------------------------------------------------------------------------- +function getFloats(this,key,defaultVal,requiredSize) + use IO, only: & + IO_error, & + IO_stringValue, & + IO_FloatValue + + implicit none + real(pReal), dimension(:), allocatable :: getFloats + class(tPartitionedStringList), target, intent(in) :: this + character(len=*), intent(in) :: key + real(pReal), dimension(:), intent(in), optional :: defaultVal + integer, intent(in), optional :: requiredSize + type(tPartitionedStringList), pointer :: item + integer :: i + logical :: found, & + cumulative + + cumulative = (key(1:1) == '(' .and. key(len_trim(key):len_trim(key)) == ')') + found = .false. + + allocate(getFloats(0)) + + item => this + do while (associated(item%next)) + if (trim(IO_stringValue(item%string%val,item%string%pos,1)) == trim(key)) then + found = .true. + if (.not. cumulative) getFloats = [real(pReal)::] + if (item%string%pos(1) < 2) call IO_error(143,ext_msg=key) + do i = 2, item%string%pos(1) + getFloats = [getFloats,IO_FloatValue(item%string%val,item%string%pos,i)] + enddo + endif + item => item%next + enddo + + if (.not. found) then + if (present(defaultVal)) then; getFloats = defaultVal; else; call IO_error(140,ext_msg=key); endif + endif + if (present(requiredSize)) then + if(requiredSize /= size(getFloats)) call IO_error(146,ext_msg=key) + endif + +end function getFloats + + +!-------------------------------------------------------------------------------------------------- +!> @brief gets array of integer values of for a given key from a linked list +!> @details for cumulative keys, "()", values from all occurrences are return. Otherwise only all +!! values from the last occurrence. If key is not found exits with error unless default is given. +!-------------------------------------------------------------------------------------------------- +function getInts(this,key,defaultVal,requiredSize) + use IO, only: & + IO_error, & + IO_stringValue, & + IO_IntValue + + implicit none + integer, dimension(:), allocatable :: getInts + class(tPartitionedStringList), target, intent(in) :: this + character(len=*), intent(in) :: key + integer, dimension(:), intent(in), optional :: defaultVal + integer, intent(in), optional :: requiredSize + type(tPartitionedStringList), pointer :: item + integer :: i + logical :: found, & + cumulative + + cumulative = (key(1:1) == '(' .and. key(len_trim(key):len_trim(key)) == ')') + found = .false. + + allocate(getInts(0)) + + item => this + do while (associated(item%next)) + if (trim(IO_stringValue(item%string%val,item%string%pos,1)) == trim(key)) then + found = .true. + if (.not. cumulative) getInts = [integer::] + if (item%string%pos(1) < 2) call IO_error(143,ext_msg=key) + do i = 2, item%string%pos(1) + getInts = [getInts,IO_IntValue(item%string%val,item%string%pos,i)] + enddo + endif + item => item%next + enddo + + if (.not. found) then + if (present(defaultVal)) then; getInts = defaultVal; else; call IO_error(140,ext_msg=key); endif + endif + if (present(requiredSize)) then + if(requiredSize /= size(getInts)) call IO_error(146,ext_msg=key) + endif + +end function getInts + + +!-------------------------------------------------------------------------------------------------- +!> @brief gets array of string values of for a given key from a linked list +!> @details for cumulative keys, "()", values from all occurrences are return. Otherwise only all +!! values from the last occurrence. If key is not found exits with error unless default is given. +!! If raw is true, the the complete string is returned, otherwise the individual chunks are returned +!-------------------------------------------------------------------------------------------------- +function getStrings(this,key,defaultVal,raw) + use IO, only: & + IO_error, & + IO_StringValue + + implicit none + character(len=65536),dimension(:), allocatable :: getStrings + class(tPartitionedStringList), target, intent(in) :: this + character(len=*), intent(in) :: key + character(len=65536),dimension(:), intent(in), optional :: defaultVal + logical, intent(in), optional :: raw + type(tPartitionedStringList), pointer :: item + character(len=65536) :: str + integer :: i + logical :: found, & + whole, & + cumulative + + cumulative = (key(1:1) == '(' .and. key(len_trim(key):len_trim(key)) == ')') + if (present(raw)) then + whole = raw + else + whole = .false. + endif + found = .false. + + item => this + do while (associated(item%next)) + if (trim(IO_stringValue(item%string%val,item%string%pos,1)) == trim(key)) then + found = .true. + if (allocated(getStrings) .and. .not. cumulative) deallocate(getStrings) + if (item%string%pos(1) < 2) call IO_error(143,ext_msg=key) + + notAllocated: if (.not. allocated(getStrings)) then + if (whole) then + str = item%string%val(item%string%pos(4):) + getStrings = [str] + else + str = IO_StringValue(item%string%val,item%string%pos,2) + allocate(getStrings(1),source=str) + do i=3,item%string%pos(1) + str = IO_StringValue(item%string%val,item%string%pos,i) + getStrings = [getStrings,str] + enddo + endif + else notAllocated + if (whole) then + str = item%string%val(item%string%pos(4):) + getStrings = [getStrings,str] + else + do i=2,item%string%pos(1) + str = IO_StringValue(item%string%val,item%string%pos,i) + getStrings = [getStrings,str] + enddo + endif + endif notAllocated + endif + item => item%next + enddo + + if (.not. found) then + if (present(defaultVal)) then; getStrings = defaultVal; else; call IO_error(140,ext_msg=key); endif + endif + +end function getStrings + + +end module list From 293f869fe5521cef78f4aedaa5d0bcebd7b70ea4 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 24 Mar 2019 11:59:00 +0100 Subject: [PATCH 06/47] improved signal handling - possibility to catch SIGTERM - functions to set SIG(TERM/USR1/USR2) explicitly --- src/C_routines.c | 6 +- src/DAMASK_interface.f90 | 78 ++++++++++++++++++++---- src/system_routines.f90 | 125 +++++++++++++++++++++------------------ 3 files changed, 139 insertions(+), 70 deletions(-) diff --git a/src/C_routines.c b/src/C_routines.c index 3dccb7644..287cf3606 100644 --- a/src/C_routines.c +++ b/src/C_routines.c @@ -47,10 +47,14 @@ int chdir_c(const char *dir){ return chdir(dir); } +void signalterm_c(void (*handler)(int)){ + signal(SIGTERM, handler); +} + void signalusr1_c(void (*handler)(int)){ signal(SIGUSR1, handler); } void signalusr2_c(void (*handler)(int)){ signal(SIGUSR2, handler); -} \ No newline at end of file +} diff --git a/src/DAMASK_interface.f90 b/src/DAMASK_interface.f90 index aab41ff29..9d2e96571 100644 --- a/src/DAMASK_interface.f90 +++ b/src/DAMASK_interface.f90 @@ -13,8 +13,9 @@ module DAMASK_interface implicit none private logical, public, protected :: & - SIGUSR1, & !< user-defined signal 1 - SIGUSR2 !< user-defined signal 2 + SIGTERM, & !< termination signal + SIGUSR1, & !< 1. user-defined signal + SIGUSR2 !< 2. user-defined signal integer, public, protected :: & interface_restartInc = 0 !< Increment at which calculation starts character(len=1024), public, protected :: & @@ -23,7 +24,10 @@ module DAMASK_interface public :: & getSolverJobName, & - DAMASK_interface_init + DAMASK_interface_init, & + setSIGTERM, & + setSIGUSR1, & + setSIGUSR2 private :: & setWorkingDirectory, & getGeometryFile, & @@ -279,10 +283,12 @@ subroutine DAMASK_interface_init() if (interface_restartInc > 0) & write(6,'(a,i6.6)') ' Restart from increment: ', interface_restartInc - call signalusr1_c(c_funloc(setSIGUSR1)) - call signalusr2_c(c_funloc(setSIGUSR2)) - SIGUSR1 = .false. - SIGUSR2 = .false. + !call signalterm_c(c_funloc(catchSIGTERM)) + call signalusr1_c(c_funloc(catchSIGUSR1)) + call signalusr2_c(c_funloc(catchSIGUSR2)) + call setSIGTERM(.false.) + call setSIGUSR1(.false.) + call setSIGUSR2(.false.) end subroutine DAMASK_interface_init @@ -470,9 +476,36 @@ end function makeRelativePath !-------------------------------------------------------------------------------------------------- -!> @brief sets global variable SIGUSR1 to .true. if program receives SIGUSR1 +!> @brief sets global variable SIGTERM to .true. !-------------------------------------------------------------------------------------------------- -subroutine setSIGUSR1(signal) bind(C) +subroutine catchSIGTERM(signal) bind(C) + use :: iso_c_binding + + implicit none + integer(C_INT), value :: signal + SIGTERM = .true. + + write(6,'(a,i2.2,a)') ' received signal ',signal, ', set SIGTERM' + +end subroutine catchSIGTERM + + +!-------------------------------------------------------------------------------------------------- +!> @brief sets global variable SIGTERM +!-------------------------------------------------------------------------------------------------- +subroutine setSIGTERM(state) + + implicit none + logical, intent(in) :: state + SIGTERM = state + +end subroutine setSIGTERM + + +!-------------------------------------------------------------------------------------------------- +!> @brief sets global variable SIGUSR1 to .true. +!-------------------------------------------------------------------------------------------------- +subroutine catchSIGUSR1(signal) bind(C) use :: iso_c_binding implicit none @@ -481,13 +514,25 @@ subroutine setSIGUSR1(signal) bind(C) write(6,'(a,i2.2,a)') ' received signal ',signal, ', set SIGUSR1' +end subroutine catchSIGUSR1 + + +!-------------------------------------------------------------------------------------------------- +!> @brief sets global variable SIGUSR1 +!-------------------------------------------------------------------------------------------------- +subroutine setSIGUSR1(state) + + implicit none + logical, intent(in) :: state + SIGUSR1 = state + end subroutine setSIGUSR1 !-------------------------------------------------------------------------------------------------- !> @brief sets global variable SIGUSR2 to .true. if program receives SIGUSR2 !-------------------------------------------------------------------------------------------------- -subroutine setSIGUSR2(signal) bind(C) +subroutine catchSIGUSR2(signal) bind(C) use :: iso_c_binding implicit none @@ -496,6 +541,19 @@ subroutine setSIGUSR2(signal) bind(C) write(6,'(a,i2.2,a)') ' received signal ',signal, ', set SIGUSR2' +end subroutine catchSIGUSR2 + + +!-------------------------------------------------------------------------------------------------- +!> @brief sets global variable SIGUSR2 +!-------------------------------------------------------------------------------------------------- +subroutine setSIGUSR2(state) + + implicit none + logical, intent(in) :: state + SIGUSR2 = state + end subroutine setSIGUSR2 + end module diff --git a/src/system_routines.f90 b/src/system_routines.f90 index 27f0cae34..d7a27a4f9 100644 --- a/src/system_routines.f90 +++ b/src/system_routines.f90 @@ -3,69 +3,76 @@ !> @brief provides wrappers to C routines !-------------------------------------------------------------------------------------------------- module system_routines - use, intrinsic :: ISO_C_Binding, only: & - C_INT, & - C_CHAR, & - C_NULL_CHAR - - implicit none - private + use, intrinsic :: ISO_C_Binding, only: & + C_INT, & + C_CHAR, & + C_NULL_CHAR - public :: & - signalusr1_C, & - signalusr2_C, & - isDirectory, & - getCWD, & - getHostName, & - setCWD - -interface - - function isDirectory_C(path) bind(C) - use, intrinsic :: ISO_C_Binding, only: & - C_INT, & - C_CHAR - integer(C_INT) :: isDirectory_C - character(kind=C_CHAR), dimension(1024), intent(in) :: path ! C string is an array - end function isDirectory_C - - subroutine getCurrentWorkDir_C(str, stat) bind(C) - use, intrinsic :: ISO_C_Binding, only: & - C_INT, & - C_CHAR - character(kind=C_CHAR), dimension(1024), intent(out) :: str ! C string is an array - integer(C_INT),intent(out) :: stat - end subroutine getCurrentWorkDir_C - - subroutine getHostName_C(str, stat) bind(C) - use, intrinsic :: ISO_C_Binding, only: & - C_INT, & - C_CHAR - character(kind=C_CHAR), dimension(1024), intent(out) :: str ! C string is an array - integer(C_INT),intent(out) :: stat - end subroutine getHostName_C - - function chdir_C(path) bind(C) - use, intrinsic :: ISO_C_Binding, only: & - C_INT, & - C_CHAR - integer(C_INT) :: chdir_C - character(kind=C_CHAR), dimension(1024), intent(in) :: path ! C string is an array - end function chdir_C + implicit none + private + + public :: & + signalterm_C, & + signalusr1_C, & + signalusr2_C, & + isDirectory, & + getCWD, & + getHostName, & + setCWD - subroutine signalusr1_C(handler) bind(C) - use, intrinsic :: ISO_C_Binding, only: & - C_FUNPTR - type(C_FUNPTR), intent(in), value :: handler - end subroutine signalusr1_C + interface + function isDirectory_C(path) bind(C) + use, intrinsic :: ISO_C_Binding, only: & + C_INT, & + C_CHAR + integer(C_INT) :: isDirectory_C + character(kind=C_CHAR), dimension(1024), intent(in) :: path ! C string is an array + end function isDirectory_C + + subroutine getCurrentWorkDir_C(str, stat) bind(C) + use, intrinsic :: ISO_C_Binding, only: & + C_INT, & + C_CHAR + character(kind=C_CHAR), dimension(1024), intent(out) :: str ! C string is an array + integer(C_INT),intent(out) :: stat + end subroutine getCurrentWorkDir_C + + subroutine getHostName_C(str, stat) bind(C) + use, intrinsic :: ISO_C_Binding, only: & + C_INT, & + C_CHAR + character(kind=C_CHAR), dimension(1024), intent(out) :: str ! C string is an array + integer(C_INT),intent(out) :: stat + end subroutine getHostName_C + + function chdir_C(path) bind(C) + use, intrinsic :: ISO_C_Binding, only: & + C_INT, & + C_CHAR + integer(C_INT) :: chdir_C + character(kind=C_CHAR), dimension(1024), intent(in) :: path ! C string is an array + end function chdir_C + + subroutine signalterm_C(handler) bind(C) + use, intrinsic :: ISO_C_Binding, only: & + C_FUNPTR + type(C_FUNPTR), intent(in), value :: handler + end subroutine signalterm_C + + subroutine signalusr1_C(handler) bind(C) + use, intrinsic :: ISO_C_Binding, only: & + C_FUNPTR + type(C_FUNPTR), intent(in), value :: handler + end subroutine signalusr1_C + subroutine signalusr2_C(handler) bind(C) - use, intrinsic :: ISO_C_Binding, only: & - C_FUNPTR - type(C_FUNPTR), intent(in), value :: handler - end subroutine signalusr2_C - -end interface + use, intrinsic :: ISO_C_Binding, only: & + C_FUNPTR + type(C_FUNPTR), intent(in), value :: handler + end subroutine signalusr2_C + + end interface contains From 19af34e05431adbfd768a46a5ce0fbec5452cfa8 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 24 Mar 2019 12:07:51 +0100 Subject: [PATCH 07/47] cleaned - no Pint - consistent indentation --- src/thermal_conduction.f90 | 571 ++++++++++++++++++------------------- 1 file changed, 284 insertions(+), 287 deletions(-) diff --git a/src/thermal_conduction.f90 b/src/thermal_conduction.f90 index 20e8bb6a6..8dd352357 100644 --- a/src/thermal_conduction.f90 +++ b/src/thermal_conduction.f90 @@ -1,40 +1,38 @@ !-------------------------------------------------------------------------------------------------- !> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH !> @brief material subroutine for temperature evolution from heat conduction -!> @details to be done !-------------------------------------------------------------------------------------------------- module thermal_conduction - use prec, only: & - pReal, & - pInt - - implicit none - private - - integer(pInt), dimension(:,:), allocatable, target, public :: & - thermal_conduction_sizePostResult !< size of each post result output - character(len=64), dimension(:,:), allocatable, target, public :: & - thermal_conduction_output !< name of each post result output - - integer(pInt), dimension(:), allocatable, target, public :: & - thermal_conduction_Noutput !< number of outputs per instance of this damage - - enum, bind(c) - enumerator :: undefined_ID, & - temperature_ID - end enum - integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & - thermal_conduction_outputID !< ID of each post result output - - - public :: & - thermal_conduction_init, & - thermal_conduction_getSourceAndItsTangent, & - thermal_conduction_getConductivity33, & - thermal_conduction_getSpecificHeat, & - thermal_conduction_getMassDensity, & - thermal_conduction_putTemperatureAndItsRate, & - thermal_conduction_postResults + use prec, only: & + pReal + + implicit none + private + + integer, dimension(:,:), allocatable, target, public :: & + thermal_conduction_sizePostResult !< size of each post result output + character(len=64), dimension(:,:), allocatable, target, public :: & + thermal_conduction_output !< name of each post result output + + integer, dimension(:), allocatable, target, public :: & + thermal_conduction_Noutput !< number of outputs per instance of this damage + + enum, bind(c) + enumerator :: undefined_ID, & + temperature_ID + end enum + integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & + thermal_conduction_outputID !< ID of each post result output + + + public :: & + thermal_conduction_init, & + thermal_conduction_getSourceAndItsTangent, & + thermal_conduction_getConductivity33, & + thermal_conduction_getSpecificHeat, & + thermal_conduction_getMassDensity, & + thermal_conduction_putTemperatureAndItsRate, & + thermal_conduction_postResults contains @@ -44,73 +42,73 @@ contains !> @details reads in material parameters, allocates arrays, and does sanity checks !-------------------------------------------------------------------------------------------------- subroutine thermal_conduction_init - use material, only: & - thermal_type, & - thermal_typeInstance, & - homogenization_Noutput, & - THERMAL_conduction_label, & - THERMAL_conduction_ID, & - material_homogenizationAt, & - mappingHomogenization, & - thermalState, & - thermalMapping, & - thermal_initialT, & - temperature, & - temperatureRate - use config, only: & - config_homogenization - - implicit none - integer(pInt) :: maxNinstance,section,instance,i - integer(pInt) :: sizeState - integer(pInt) :: NofMyHomog - character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] - character(len=65536), dimension(:), allocatable :: outputs - - write(6,'(/,a)') ' <<<+- thermal_'//THERMAL_CONDUCTION_label//' init -+>>>' + use material, only: & + thermal_type, & + thermal_typeInstance, & + homogenization_Noutput, & + THERMAL_conduction_label, & + THERMAL_conduction_ID, & + material_homogenizationAt, & + mappingHomogenization, & + thermalState, & + thermalMapping, & + thermal_initialT, & + temperature, & + temperatureRate + use config, only: & + config_homogenization - maxNinstance = count(thermal_type == THERMAL_conduction_ID) - if (maxNinstance == 0_pInt) return + implicit none + integer :: maxNinstance,section,instance,i + integer :: sizeState + integer :: NofMyHomog + character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] + character(len=65536), dimension(:), allocatable :: outputs - allocate(thermal_conduction_sizePostResult (maxval(homogenization_Noutput),maxNinstance),source=0_pInt) - allocate(thermal_conduction_output (maxval(homogenization_Noutput),maxNinstance)) - thermal_conduction_output = '' - allocate(thermal_conduction_outputID (maxval(homogenization_Noutput),maxNinstance),source=undefined_ID) - allocate(thermal_conduction_Noutput (maxNinstance), source=0_pInt) - + write(6,'(/,a)') ' <<<+- thermal_'//THERMAL_CONDUCTION_label//' init -+>>>' + + maxNinstance = count(thermal_type == THERMAL_conduction_ID) + if (maxNinstance == 0) return + + allocate(thermal_conduction_sizePostResult (maxval(homogenization_Noutput),maxNinstance),source=0) + allocate(thermal_conduction_output (maxval(homogenization_Noutput),maxNinstance)) + thermal_conduction_output = '' + allocate(thermal_conduction_outputID (maxval(homogenization_Noutput),maxNinstance),source=undefined_ID) + allocate(thermal_conduction_Noutput (maxNinstance), source=0) - initializeInstances: do section = 1_pInt, size(thermal_type) - if (thermal_type(section) /= THERMAL_conduction_ID) cycle - NofMyHomog=count(material_homogenizationAt==section) - instance = thermal_typeInstance(section) - outputs = config_homogenization(section)%getStrings('(output)',defaultVal=emptyStringArray) - do i=1_pInt, size(outputs) - select case(outputs(i)) - case('temperature') - thermal_conduction_Noutput(instance) = thermal_conduction_Noutput(instance) + 1_pInt - thermal_conduction_outputID(thermal_conduction_Noutput(instance),instance) = temperature_ID - thermal_conduction_output(thermal_conduction_Noutput(instance),instance) = outputs(i) - thermal_conduction_sizePostResult(thermal_conduction_Noutput(instance),instance) = 1_pInt - end select - enddo - - -! allocate state arrays - sizeState = 0_pInt - thermalState(section)%sizeState = sizeState - thermalState(section)%sizePostResults = sum(thermal_conduction_sizePostResult(:,instance)) - allocate(thermalState(section)%state0 (sizeState,NofMyHomog)) - allocate(thermalState(section)%subState0(sizeState,NofMyHomog)) - allocate(thermalState(section)%state (sizeState,NofMyHomog)) - - nullify(thermalMapping(section)%p) - thermalMapping(section)%p => mappingHomogenization(1,:,:) - deallocate(temperature (section)%p) - allocate (temperature (section)%p(NofMyHomog), source=thermal_initialT(section)) - deallocate(temperatureRate(section)%p) - allocate (temperatureRate(section)%p(NofMyHomog), source=0.0_pReal) - - enddo initializeInstances + + initializeInstances: do section = 1, size(thermal_type) + if (thermal_type(section) /= THERMAL_conduction_ID) cycle + NofMyHomog=count(material_homogenizationAt==section) + instance = thermal_typeInstance(section) + outputs = config_homogenization(section)%getStrings('(output)',defaultVal=emptyStringArray) + do i=1, size(outputs) + select case(outputs(i)) + case('temperature') + thermal_conduction_Noutput(instance) = thermal_conduction_Noutput(instance) + 1 + thermal_conduction_outputID(thermal_conduction_Noutput(instance),instance) = temperature_ID + thermal_conduction_output(thermal_conduction_Noutput(instance),instance) = outputs(i) + thermal_conduction_sizePostResult(thermal_conduction_Noutput(instance),instance) = 1 + end select + enddo + + + ! allocate state arrays + sizeState = 0 + thermalState(section)%sizeState = sizeState + thermalState(section)%sizePostResults = sum(thermal_conduction_sizePostResult(:,instance)) + allocate(thermalState(section)%state0 (sizeState,NofMyHomog)) + allocate(thermalState(section)%subState0(sizeState,NofMyHomog)) + allocate(thermalState(section)%state (sizeState,NofMyHomog)) + + nullify(thermalMapping(section)%p) + thermalMapping(section)%p => mappingHomogenization(1,:,:) + deallocate(temperature (section)%p) + allocate (temperature (section)%p(NofMyHomog), source=thermal_initialT(section)) + deallocate(temperatureRate(section)%p) + allocate (temperatureRate(section)%p(NofMyHomog), source=0.0_pReal) + + enddo initializeInstances end subroutine thermal_conduction_init @@ -118,77 +116,77 @@ end subroutine thermal_conduction_init !> @brief returns heat generation rate !-------------------------------------------------------------------------------------------------- subroutine thermal_conduction_getSourceAndItsTangent(Tdot, dTdot_dT, T, ip, el) - use material, only: & - material_homogenizationAt, & - homogenization_Ngrains, & - mappingHomogenization, & - phaseAt, & - phasememberAt, & - thermal_typeInstance, & - phase_Nsources, & - phase_source, & - SOURCE_thermal_dissipation_ID, & - SOURCE_thermal_externalheat_ID - use source_thermal_dissipation, only: & - source_thermal_dissipation_getRateAndItsTangent - use source_thermal_externalheat, only: & - source_thermal_externalheat_getRateAndItsTangent - use crystallite, only: & - crystallite_S, & - crystallite_Lp - - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point number - el !< element number - real(pReal), intent(in) :: & - T - real(pReal), intent(out) :: & - Tdot, dTdot_dT - real(pReal) :: & - my_Tdot, my_dTdot_dT - integer(pInt) :: & - phase, & - homog, & - offset, & - instance, & - grain, & - source, & - constituent - - homog = material_homogenizationAt(el) - offset = mappingHomogenization(1,ip,el) - instance = thermal_typeInstance(homog) - - Tdot = 0.0_pReal - dTdot_dT = 0.0_pReal - do grain = 1, homogenization_Ngrains(homog) - phase = phaseAt(grain,ip,el) - constituent = phasememberAt(grain,ip,el) - do source = 1, phase_Nsources(phase) - select case(phase_source(source,phase)) - case (SOURCE_thermal_dissipation_ID) - call source_thermal_dissipation_getRateAndItsTangent(my_Tdot, my_dTdot_dT, & - crystallite_S(1:3,1:3,grain,ip,el), & - crystallite_Lp(1:3,1:3,grain,ip,el), & - phase) - - case (SOURCE_thermal_externalheat_ID) - call source_thermal_externalheat_getRateAndItsTangent(my_Tdot, my_dTdot_dT, & - phase, constituent) - - case default - my_Tdot = 0.0_pReal - my_dTdot_dT = 0.0_pReal - - end select - Tdot = Tdot + my_Tdot - dTdot_dT = dTdot_dT + my_dTdot_dT - enddo - enddo + use material, only: & + material_homogenizationAt, & + homogenization_Ngrains, & + mappingHomogenization, & + phaseAt, & + phasememberAt, & + thermal_typeInstance, & + phase_Nsources, & + phase_source, & + SOURCE_thermal_dissipation_ID, & + SOURCE_thermal_externalheat_ID + use source_thermal_dissipation, only: & + source_thermal_dissipation_getRateAndItsTangent + use source_thermal_externalheat, only: & + source_thermal_externalheat_getRateAndItsTangent + use crystallite, only: & + crystallite_S, & + crystallite_Lp - Tdot = Tdot/real(homogenization_Ngrains(homog),pReal) - dTdot_dT = dTdot_dT/real(homogenization_Ngrains(homog),pReal) + implicit none + integer, intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), intent(in) :: & + T + real(pReal), intent(out) :: & + Tdot, dTdot_dT + real(pReal) :: & + my_Tdot, my_dTdot_dT + integer :: & + phase, & + homog, & + offset, & + instance, & + grain, & + source, & + constituent + + homog = material_homogenizationAt(el) + offset = mappingHomogenization(1,ip,el) + instance = thermal_typeInstance(homog) + + Tdot = 0.0_pReal + dTdot_dT = 0.0_pReal + do grain = 1, homogenization_Ngrains(homog) + phase = phaseAt(grain,ip,el) + constituent = phasememberAt(grain,ip,el) + do source = 1, phase_Nsources(phase) + select case(phase_source(source,phase)) + case (SOURCE_thermal_dissipation_ID) + call source_thermal_dissipation_getRateAndItsTangent(my_Tdot, my_dTdot_dT, & + crystallite_S(1:3,1:3,grain,ip,el), & + crystallite_Lp(1:3,1:3,grain,ip,el), & + phase) + + case (SOURCE_thermal_externalheat_ID) + call source_thermal_externalheat_getRateAndItsTangent(my_Tdot, my_dTdot_dT, & + phase, constituent) + + case default + my_Tdot = 0.0_pReal + my_dTdot_dT = 0.0_pReal + + end select + Tdot = Tdot + my_Tdot + dTdot_dT = dTdot_dT + my_dTdot_dT + enddo + enddo + + Tdot = Tdot/real(homogenization_Ngrains(homog),pReal) + dTdot_dT = dTdot_dT/real(homogenization_Ngrains(homog),pReal) end subroutine thermal_conduction_getSourceAndItsTangent @@ -197,34 +195,34 @@ end subroutine thermal_conduction_getSourceAndItsTangent !> @brief returns homogenized thermal conductivity in reference configuration !-------------------------------------------------------------------------------------------------- function thermal_conduction_getConductivity33(ip,el) - use lattice, only: & - lattice_thermalConductivity33 - use material, only: & - homogenization_Ngrains, & - material_phase - use mesh, only: & - mesh_element - use crystallite, only: & - crystallite_push33ToRef - - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point number - el !< element number - real(pReal), dimension(3,3) :: & - thermal_conduction_getConductivity33 - integer(pInt) :: & - grain + use lattice, only: & + lattice_thermalConductivity33 + use material, only: & + homogenization_Ngrains, & + material_phase + use mesh, only: & + mesh_element + use crystallite, only: & + crystallite_push33ToRef + + implicit none + integer, intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), dimension(3,3) :: & + thermal_conduction_getConductivity33 + integer :: & + grain + - - thermal_conduction_getConductivity33 = 0.0_pReal - do grain = 1, homogenization_Ngrains(mesh_element(3,el)) - thermal_conduction_getConductivity33 = thermal_conduction_getConductivity33 + & - crystallite_push33ToRef(grain,ip,el,lattice_thermalConductivity33(:,:,material_phase(grain,ip,el))) - enddo - - thermal_conduction_getConductivity33 = & - thermal_conduction_getConductivity33/real(homogenization_Ngrains(mesh_element(3,el)),pReal) + thermal_conduction_getConductivity33 = 0.0_pReal + do grain = 1, homogenization_Ngrains(mesh_element(3,el)) + thermal_conduction_getConductivity33 = thermal_conduction_getConductivity33 + & + crystallite_push33ToRef(grain,ip,el,lattice_thermalConductivity33(:,:,material_phase(grain,ip,el))) + enddo + + thermal_conduction_getConductivity33 = & + thermal_conduction_getConductivity33/real(homogenization_Ngrains(mesh_element(3,el)),pReal) end function thermal_conduction_getConductivity33 @@ -233,33 +231,33 @@ end function thermal_conduction_getConductivity33 !> @brief returns homogenized specific heat capacity !-------------------------------------------------------------------------------------------------- function thermal_conduction_getSpecificHeat(ip,el) - use lattice, only: & - lattice_specificHeat - use material, only: & - homogenization_Ngrains, & - material_phase - use mesh, only: & - mesh_element - - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point number - el !< element number - real(pReal) :: & - thermal_conduction_getSpecificHeat - integer(pInt) :: & - grain - - thermal_conduction_getSpecificHeat = 0.0_pReal + use lattice, only: & + lattice_specificHeat + use material, only: & + homogenization_Ngrains, & + material_phase + use mesh, only: & + mesh_element + implicit none + integer, intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal) :: & + thermal_conduction_getSpecificHeat + integer :: & + grain + + thermal_conduction_getSpecificHeat = 0.0_pReal - do grain = 1, homogenization_Ngrains(mesh_element(3,el)) - thermal_conduction_getSpecificHeat = thermal_conduction_getSpecificHeat + & - lattice_specificHeat(material_phase(grain,ip,el)) - enddo - - thermal_conduction_getSpecificHeat = & - thermal_conduction_getSpecificHeat/real(homogenization_Ngrains(mesh_element(3,el)),pReal) + + do grain = 1, homogenization_Ngrains(mesh_element(3,el)) + thermal_conduction_getSpecificHeat = thermal_conduction_getSpecificHeat + & + lattice_specificHeat(material_phase(grain,ip,el)) + enddo + + thermal_conduction_getSpecificHeat = & + thermal_conduction_getSpecificHeat/real(homogenization_Ngrains(mesh_element(3,el)),pReal) end function thermal_conduction_getSpecificHeat @@ -267,33 +265,33 @@ end function thermal_conduction_getSpecificHeat !> @brief returns homogenized mass density !-------------------------------------------------------------------------------------------------- function thermal_conduction_getMassDensity(ip,el) - use lattice, only: & - lattice_massDensity - use material, only: & - homogenization_Ngrains, & - material_phase - use mesh, only: & - mesh_element - - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point number - el !< element number - real(pReal) :: & - thermal_conduction_getMassDensity - integer(pInt) :: & - grain - - thermal_conduction_getMassDensity = 0.0_pReal + use lattice, only: & + lattice_massDensity + use material, only: & + homogenization_Ngrains, & + material_phase + use mesh, only: & + mesh_element + implicit none + integer, intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal) :: & + thermal_conduction_getMassDensity + integer :: & + grain + + thermal_conduction_getMassDensity = 0.0_pReal - do grain = 1, homogenization_Ngrains(mesh_element(3,el)) - thermal_conduction_getMassDensity = thermal_conduction_getMassDensity & - + lattice_massDensity(material_phase(grain,ip,el)) - enddo - - thermal_conduction_getMassDensity = & - thermal_conduction_getMassDensity/real(homogenization_Ngrains(mesh_element(3,el)),pReal) + + do grain = 1, homogenization_Ngrains(mesh_element(3,el)) + thermal_conduction_getMassDensity = thermal_conduction_getMassDensity & + + lattice_massDensity(material_phase(grain,ip,el)) + enddo + + thermal_conduction_getMassDensity = & + thermal_conduction_getMassDensity/real(homogenization_Ngrains(mesh_element(3,el)),pReal) end function thermal_conduction_getMassDensity @@ -302,27 +300,27 @@ end function thermal_conduction_getMassDensity !> @brief updates thermal state with solution from heat conduction PDE !-------------------------------------------------------------------------------------------------- subroutine thermal_conduction_putTemperatureAndItsRate(T,Tdot,ip,el) - use material, only: & - material_homogenizationAt, & - temperature, & - temperatureRate, & - thermalMapping + use material, only: & + material_homogenizationAt, & + temperature, & + temperatureRate, & + thermalMapping - implicit none - integer(pInt), intent(in) :: & - ip, & !< integration point number - el !< element number - real(pReal), intent(in) :: & - T, & - Tdot - integer(pInt) :: & - homog, & - offset - - homog = material_homogenizationAt(el) - offset = thermalMapping(homog)%p(ip,el) - temperature (homog)%p(offset) = T - temperatureRate(homog)%p(offset) = Tdot + implicit none + integer, intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), intent(in) :: & + T, & + Tdot + integer :: & + homog, & + offset + + homog = material_homogenizationAt(el) + offset = thermalMapping(homog)%p(ip,el) + temperature (homog)%p(offset) = T + temperatureRate(homog)%p(offset) = Tdot end subroutine thermal_conduction_putTemperatureAndItsRate @@ -331,31 +329,30 @@ end subroutine thermal_conduction_putTemperatureAndItsRate !> @brief return array of thermal results !-------------------------------------------------------------------------------------------------- function thermal_conduction_postResults(homog,instance,of) result(postResults) - use material, only: & - temperature - - implicit none - integer(pInt), intent(in) :: & - homog, & - instance, & - of - - real(pReal), dimension(sum(thermal_conduction_sizePostResult(:,instance))) :: & - postResults - - integer(pInt) :: & - o, c - - c = 0_pInt - - do o = 1_pInt,thermal_conduction_Noutput(instance) - select case(thermal_conduction_outputID(o,instance)) + use material, only: & + temperature - case (temperature_ID) - postResults(c+1_pInt) = temperature(homog)%p(of) - c = c + 1 - end select - enddo + implicit none + integer, intent(in) :: & + homog, & + instance, & + of + + real(pReal), dimension(sum(thermal_conduction_sizePostResult(:,instance))) :: & + postResults + + integer :: & + o, c + + c = 0 + do o = 1,thermal_conduction_Noutput(instance) + select case(thermal_conduction_outputID(o,instance)) + + case (temperature_ID) + postResults(c+1) = temperature(homog)%p(of) + c = c + 1 + end select + enddo end function thermal_conduction_postResults From 761dcb03585e2e2f3c6283cb916a44de66ef554c Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 25 Mar 2019 18:04:53 +0100 Subject: [PATCH 08/47] no need for explicit loop --- src/plastic_phenopowerlaw.f90 | 37 ++++++++++++++--------------------- 1 file changed, 15 insertions(+), 22 deletions(-) diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 index 8c6afe43d..4fde804b5 100644 --- a/src/plastic_phenopowerlaw.f90 +++ b/src/plastic_phenopowerlaw.f90 @@ -204,9 +204,9 @@ subroutine plastic_phenopowerlaw_init prm%nonSchmid_pos = prm%Schmid_slip prm%nonSchmid_neg = prm%Schmid_slip endif - prm%interaction_SlipSlip = lattice_interaction_SlipBySlip(prm%Nslip, & + prm%interaction_SlipSlip = transpose(lattice_interaction_SlipBySlip(prm%Nslip, & config%getFloats('interaction_slipslip'), & - config%getString('lattice_structure')) + config%getString('lattice_structure'))) prm%xi_slip_0 = config%getFloats('tau0_slip', requiredSize=size(prm%Nslip)) prm%xi_slip_sat = config%getFloats('tausat_slip', requiredSize=size(prm%Nslip)) @@ -241,9 +241,9 @@ subroutine plastic_phenopowerlaw_init twinActive: if (prm%totalNtwin > 0_pInt) then prm%Schmid_twin = lattice_SchmidMatrix_twin(prm%Ntwin,config%getString('lattice_structure'),& config%getFloat('c/a',defaultVal=0.0_pReal)) - prm%interaction_TwinTwin = lattice_interaction_TwinByTwin(prm%Ntwin,& + prm%interaction_TwinTwin = transpose(lattice_interaction_TwinByTwin(prm%Ntwin,& config%getFloats('interaction_twintwin'), & - config%getString('lattice_structure')) + config%getString('lattice_structure'))) prm%gamma_twin_char = lattice_characteristicShear_twin(prm%Ntwin,config%getString('lattice_structure'),& config%getFloat('c/a')) @@ -269,15 +269,15 @@ subroutine plastic_phenopowerlaw_init !-------------------------------------------------------------------------------------------------- ! slip-twin related parameters slipAndTwinActive: if (prm%totalNslip > 0_pInt .and. prm%totalNtwin > 0_pInt) then - prm%interaction_SlipTwin = lattice_interaction_SlipByTwin(prm%Nslip,prm%Ntwin,& + prm%interaction_SlipTwin = transpose(lattice_interaction_SlipByTwin(prm%Nslip,prm%Ntwin,& config%getFloats('interaction_sliptwin'), & - config%getString('lattice_structure')) - prm%interaction_TwinSlip = lattice_interaction_TwinBySlip(prm%Ntwin,prm%Nslip,& + config%getString('lattice_structure'))) + prm%interaction_TwinSlip = transpose(lattice_interaction_TwinBySlip(prm%Ntwin,prm%Nslip,& config%getFloats('interaction_twinslip'), & - config%getString('lattice_structure')) + config%getString('lattice_structure'))) else slipAndTwinActive - allocate(prm%interaction_SlipTwin(prm%TotalNtwin,prm%TotalNslip)) ! at least one dimension is 0 - allocate(prm%interaction_TwinSlip(prm%TotalNslip,prm%TotalNtwin)) ! at least one dimension is 0 + allocate(prm%interaction_SlipTwin(prm%TotalNslip,prm%TotalNtwin)) ! at least one dimension is 0 + allocate(prm%interaction_TwinSlip(prm%TotalNtwin,prm%TotalNslip)) ! at least one dimension is 0 prm%h0_TwinSlip = 0.0_pReal endif slipAndTwinActive @@ -447,8 +447,6 @@ subroutine plastic_phenopowerlaw_dotState(Mp,instance,of) instance, & of - integer(pInt) :: & - i real(pReal) :: & c_SlipSlip,c_TwinSlip,c_TwinTwin, & xi_slip_sat_offset,& @@ -483,17 +481,12 @@ subroutine plastic_phenopowerlaw_dotState(Mp,instance,of) !-------------------------------------------------------------------------------------------------- ! hardening - hardeningSlip: do i = 1_pInt, prm%totalNslip - dot%xi_slip(i,of) = dot_product(prm%interaction_SlipSlip(:,i),right_SlipSlip*dot%gamma_slip(:,of)) & - * c_SlipSlip * left_SlipSlip(i) & - + dot_product(prm%interaction_SlipTwin(:,i),dot%gamma_twin(:,of)) - enddo hardeningSlip - - hardeningTwin: do i = 1_pInt, prm%totalNtwin - dot%xi_twin(i,of) = c_TwinSlip * dot_product(prm%interaction_TwinSlip(:,i),dot%gamma_slip(:,of)) & - + c_TwinTwin * dot_product(prm%interaction_TwinTwin(:,i),dot%gamma_twin(:,of)) - enddo hardeningTwin + dot%xi_slip(:,of) = c_SlipSlip * left_SlipSlip * & + matmul(prm%interaction_SlipSlip,dot%gamma_slip(:,of)*right_SlipSlip) & + + matmul(prm%interaction_SlipTwin,dot%gamma_twin(:,of)) + dot%xi_twin(:,of) = c_TwinSlip * matmul(prm%interaction_TwinSlip,dot%gamma_slip(:,of)) & + + c_TwinTwin * matmul(prm%interaction_TwinTwin,dot%gamma_twin(:,of)) end associate end subroutine plastic_phenopowerlaw_dotState From 2feb79833c38c7a82b73e0436df00111ac5a3ef8 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 25 Mar 2019 21:54:08 +0100 Subject: [PATCH 09/47] better use functions than global variables need to design a test before full migration --- src/source_damage_anisoBrittle.f90 | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/source_damage_anisoBrittle.f90 b/src/source_damage_anisoBrittle.f90 index cc4991da8..717ea9fb4 100644 --- a/src/source_damage_anisoBrittle.f90 +++ b/src/source_damage_anisoBrittle.f90 @@ -38,6 +38,8 @@ module source_damage_anisoBrittle real(pReal), dimension(:), allocatable :: & critDisp, & critLoad + real(pReal), dimension(:,:,:,:), allocatable :: & + cleavage_systems integer(pInt) :: & totalNcleavage integer(pInt), dimension(:), allocatable :: & @@ -86,6 +88,7 @@ subroutine source_damage_anisoBrittle_init config_phase, & material_Nphase use lattice, only: & + lattice_SchmidMatrix_cleavage, & lattice_maxNcleavageFamily implicit none @@ -148,6 +151,9 @@ subroutine source_damage_anisoBrittle_init prm%critDisp = config%getFloats('anisobrittle_criticaldisplacement',requiredSize=size(prm%Ncleavage)) prm%critLoad = config%getFloats('anisobrittle_criticalload', requiredSize=size(prm%Ncleavage)) + + prm%cleavage_systems = lattice_SchmidMatrix_cleavage (prm%Ncleavage,config%getString('lattice_structure'),& + config%getFloat('c/a',defaultVal=0.0_pReal)) ! expand: family => system prm%critDisp = math_expand(prm%critDisp, prm%Ncleavage) @@ -244,12 +250,14 @@ subroutine source_damage_anisoBrittle_dotState(S, ipc, ip, el) do f = 1_pInt,lattice_maxNcleavageFamily index_myFamily = sum(lattice_NcleavageSystem(1:f-1_pInt,phase)) ! at which index starts my family do i = 1_pInt,source_damage_anisoBrittle_Ncleavage(f,instance) ! process each (active) cleavage system in family + traction_d = math_mul33xx33(S,lattice_Scleavage(1:3,1:3,1,index_myFamily+i,phase)) traction_t = math_mul33xx33(S,lattice_Scleavage(1:3,1:3,2,index_myFamily+i,phase)) traction_n = math_mul33xx33(S,lattice_Scleavage(1:3,1:3,3,index_myFamily+i,phase)) traction_crit = param(instance)%critLoad(index)* & damage(homog)%p(damageOffset)*damage(homog)%p(damageOffset) + sourceState(phase)%p(sourceOffset)%dotState(1,constituent) = & sourceState(phase)%p(sourceOffset)%dotState(1,constituent) + & param(instance)%sdot_0* & From 1869f2cdcd7c144e2800613628c51ce949405614 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 26 Mar 2019 06:27:13 +0100 Subject: [PATCH 10/47] string length handling in-line with other functions --- src/lattice.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lattice.f90 b/src/lattice.f90 index 6c37af34b..d3d2b3ce5 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -1007,7 +1007,7 @@ function lattice_characteristicShear_Twin(Ntwin,structure,CoverA) result(charact implicit none integer, dimension(:), intent(in) :: Ntwin !< number of active twin systems per family - character(len=3), intent(in) :: structure !< lattice structure + character(len=*), intent(in) :: structure !< lattice structure real(pReal), intent(in) :: cOverA !< c/a ratio real(pReal), dimension(sum(Ntwin)) :: characteristicShear From 49ff1454a945c5d0e434a52e6d229f2e2e948bd7 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 26 Mar 2019 06:47:17 +0100 Subject: [PATCH 11/47] no need for explicit loops --- src/plastic_dislotwin.f90 | 32 ++++++++++++------------------ src/plastic_kinematichardening.f90 | 20 +++++++++---------- 2 files changed, 22 insertions(+), 30 deletions(-) diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index 3d351e3ae..a0a996dd6 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -268,9 +268,9 @@ subroutine plastic_dislotwin_init slipActive: if (prm%sum_N_sl > 0) then prm%P_sl = lattice_SchmidMatrix_slip(prm%N_sl,config%getString('lattice_structure'),& config%getFloat('c/a',defaultVal=0.0_pReal)) - prm%h_sl_sl = lattice_interaction_SlipBySlip(prm%N_sl, & + prm%h_sl_sl = transpose(lattice_interaction_SlipBySlip(prm%N_sl, & config%getFloats('interaction_slipslip'), & - config%getString('lattice_structure')) + config%getString('lattice_structure'))) prm%forestProjection = lattice_forestProjection (prm%N_sl,config%getString('lattice_structure'),& config%getFloat('c/a',defaultVal=0.0_pReal)) @@ -332,9 +332,9 @@ subroutine plastic_dislotwin_init if (prm%sum_N_tw > 0) then prm%P_tw = lattice_SchmidMatrix_twin(prm%N_tw,config%getString('lattice_structure'),& config%getFloat('c/a',defaultVal=0.0_pReal)) - prm%h_tw_tw = lattice_interaction_TwinByTwin(prm%N_tw,& + prm%h_tw_tw = transpose(lattice_interaction_TwinByTwin(prm%N_tw,& config%getFloats('interaction_twintwin'), & - config%getString('lattice_structure')) + config%getString('lattice_structure'))) prm%b_tw = config%getFloats('twinburgers', requiredSize=size(prm%N_tw)) prm%t_tw = config%getFloats('twinsize', requiredSize=size(prm%N_tw)) @@ -380,9 +380,9 @@ subroutine plastic_dislotwin_init prm%xc_trans = config%getFloat('xc_trans', defaultVal=0.0_pReal) ! ToDo: How to handle that??? prm%L_tr = config%getFloat('l0_trans') - prm%h_tr_tr = lattice_interaction_TransByTrans(prm%N_tr,& + prm%h_tr_tr = transpose(lattice_interaction_TransByTrans(prm%N_tr,& config%getFloats('interaction_transtrans'), & - config%getString('lattice_structure')) + config%getString('lattice_structure'))) prm%C66_tr = lattice_C66_trans(prm%N_tr,prm%C66, & config%getString('trans_lattice_structure'), & @@ -416,16 +416,16 @@ subroutine plastic_dislotwin_init endif if (prm%sum_N_sl > 0 .and. prm%sum_N_tw > 0) then - prm%h_sl_tw = lattice_interaction_SlipByTwin(prm%N_sl,prm%N_tw,& + prm%h_sl_tw = transpose(lattice_interaction_SlipByTwin(prm%N_sl,prm%N_tw,& config%getFloats('interaction_sliptwin'), & - config%getString('lattice_structure')) + config%getString('lattice_structure'))) if (prm%fccTwinTransNucleation .and. prm%sum_N_tw > 12) write(6,*) 'mist' ! ToDo: implement better test. The model will fail also if N_tw is [6,6] endif if (prm%sum_N_sl > 0 .and. prm%sum_N_tr > 0) then - prm%h_sl_tr = lattice_interaction_SlipByTrans(prm%N_sl,prm%N_tr,& + prm%h_sl_tr = transpose(lattice_interaction_SlipByTrans(prm%N_sl,prm%N_tr,& config%getFloats('interaction_sliptrans'), & - config%getString('lattice_structure')) + config%getString('lattice_structure'))) if (prm%fccTwinTransNucleation .and. prm%sum_N_tr > 12) write(6,*) 'mist' ! ToDo: implement better test. The model will fail also if N_tr is [6,6] endif @@ -918,8 +918,7 @@ subroutine plastic_dislotwin_dependentState(T,instance,of) if (prm%sum_N_tw > 0 .and. prm%sum_N_sl > 0) & - inv_lambda_sl_tw = & - matmul(transpose(prm%h_sl_tw),f_over_t_tw)/(1.0_pReal-sumf_twin) ! ToDo: Change order/no transpose + inv_lambda_sl_tw = matmul(prm%h_sl_tw,f_over_t_tw)/(1.0_pReal-sumf_twin) @@ -929,8 +928,7 @@ subroutine plastic_dislotwin_dependentState(T,instance,of) if (prm%sum_N_tr > 0 .and. prm%sum_N_sl > 0) & - inv_lambda_sl_tr = & ! ToDo: does not work if N_tr is not 12 - matmul(transpose(prm%h_sl_tr),f_over_t_tr)/(1.0_pReal-sumf_trans) ! ToDo: remove transpose + inv_lambda_sl_tr = matmul(prm%h_sl_tr,f_over_t_tr)/(1.0_pReal-sumf_trans) !ToDo: needed? if (prm%sum_N_tr > 0) & @@ -948,15 +946,11 @@ subroutine plastic_dislotwin_dependentState(T,instance,of) endif - dst%Lambda_tw(:,of) = prm%i_tw*prm%D/(1.0_pReal+prm%D*inv_lambda_tw_tw) dst%Lambda_tr(:,of) = prm%i_tr*prm%D/(1.0_pReal+prm%D*inv_lambda_tr_tr) !* threshold stress for dislocation motion - forall (i = 1:prm%sum_N_sl) dst%tau_pass(i,of) = & - prm%mu*prm%b_sl(i)*& - sqrt(dot_product(stt%rho_mob(1:prm%sum_N_sl,of)+stt%rho_dip(1:prm%sum_N_sl,of),& - prm%h_sl_sl(:,i))) + dst%tau_pass(:,of) = prm%mu*prm%b_sl* sqrt(matmul(prm%h_sl_sl,stt%rho_mob(:,of)+stt%rho_dip(:,of))) !* threshold stress for growing twin/martensite if(prm%sum_N_tw == prm%sum_N_sl) & diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 52f901b0c..7d09de1ef 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -204,9 +204,9 @@ subroutine plastic_kinehardening_init prm%nonSchmid_pos = prm%Schmid prm%nonSchmid_neg = prm%Schmid endif - prm%interaction_SlipSlip = lattice_interaction_SlipBySlip(prm%Nslip, & + prm%interaction_SlipSlip = transpose(lattice_interaction_SlipBySlip(prm%Nslip, & config%getFloats('interaction_slipslip'), & - config%getString('lattice_structure')) + config%getString('lattice_structure'))) prm%crss0 = config%getFloats('crss0', requiredSize=size(prm%Nslip)) prm%tau1 = config%getFloats('tau1', requiredSize=size(prm%Nslip)) @@ -397,8 +397,6 @@ subroutine plastic_kinehardening_dotState(Mp,instance,of) instance, & of - integer(pInt) :: & - i real(pReal) :: & sumGamma real(pReal), dimension(param(instance)%totalNslip) :: & @@ -411,13 +409,13 @@ subroutine plastic_kinehardening_dotState(Mp,instance,of) dot%accshear(:,of) = abs(gdot_pos+gdot_neg) sumGamma = sum(stt%accshear(:,of)) - do i = 1_pInt, prm%totalNslip - dot%crss(i,of) = dot_product(prm%interaction_SlipSlip(:,i),dot%accshear(:,of)) & - * ( prm%theta1(i) & - + (prm%theta0(i) - prm%theta1(i) + prm%theta0(i)*prm%theta1(i)*sumGamma/prm%tau1(i)) & - * exp(-sumGamma*prm%theta0(i)/prm%tau1(i)) & - ) - enddo + + dot%crss(:,of) = matmul(prm%interaction_SlipSlip,dot%accshear(:,of)) & + * ( prm%theta1 & + + (prm%theta0 - prm%theta1 + prm%theta0*prm%theta1*sumGamma/prm%tau1) & + * exp(-sumGamma*prm%theta0/prm%tau1) & + ) + dot%crss_back(:,of) = stt%sense(:,of)*dot%accshear(:,of) * & ( prm%theta1_b + & (prm%theta0_b - prm%theta1_b & From 1f41549a2c3870e6859a17448e58bc2ed2bf7c7e Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 27 Mar 2019 12:37:48 +0100 Subject: [PATCH 12/47] avoid explicit loops --- src/plastic_disloUCLA.f90 | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/src/plastic_disloUCLA.f90 b/src/plastic_disloUCLA.f90 index 1cdebe87f..88aa27432 100644 --- a/src/plastic_disloUCLA.f90 +++ b/src/plastic_disloUCLA.f90 @@ -208,9 +208,9 @@ subroutine plastic_disloUCLA_init() prm%nonSchmid_neg = prm%Schmid endif - prm%h_sl_sl = lattice_interaction_SlipBySlip(prm%N_sl, & + prm%h_sl_sl = transpose(lattice_interaction_SlipBySlip(prm%N_sl, & config%getFloats('interaction_slipslip'), & - config%getString('lattice_structure')) + config%getString('lattice_structure'))) prm%forestProjectionEdge = lattice_forestProjection(prm%N_sl,config%getString('lattice_structure'),& config%getFloat('c/a',defaultVal=0.0_pReal)) @@ -484,13 +484,11 @@ subroutine plastic_disloUCLA_dependentState(instance,of) associate(prm => param(instance), stt => state(instance),dst => dependentState(instance)) - forall (i = 1:prm%sum_N_sl) + forall (i = 1:prm%sum_N_sl) & dislocationSpacing(i) = sqrt(dot_product(stt%rho_mob(:,of)+stt%rho_dip(:,of), & prm%forestProjectionEdge(:,i))) - dst%threshold_stress(i,of) = prm%mu*prm%b_sl(i) & - * sqrt(dot_product(stt%rho_mob(:,of)+stt%rho_dip(:,of), & - prm%h_sl_sl(:,i))) - end forall + dst%threshold_stress(:,of) = prm%mu*prm%b_sl & + * sqrt(matmul(prm%h_sl_sl,stt%rho_mob(:,of)+stt%rho_dip(:,of))) dst%Lambda_sl(:,of) = prm%D/(1.0_pReal+prm%D*dislocationSpacing/prm%i_sl) From 464375a54e04e6b1b4ebc99a7a3ae411ceb912ec Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 27 Mar 2019 22:06:40 +0100 Subject: [PATCH 13/47] pInt does not add any value --- src/plastic_isotropic.f90 | 68 ++++++++-------- src/plastic_kinematichardening.f90 | 119 ++++++++++++++-------------- src/plastic_phenopowerlaw.f90 | 123 ++++++++++++++--------------- 3 files changed, 154 insertions(+), 156 deletions(-) diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 index 3c53037d6..b9250869b 100644 --- a/src/plastic_isotropic.f90 +++ b/src/plastic_isotropic.f90 @@ -14,9 +14,9 @@ module plastic_isotropic implicit none private - integer(pInt), dimension(:,:), allocatable, target, public :: & + integer, dimension(:,:), allocatable, target, public :: & plastic_isotropic_sizePostResult !< size of each post result output - character(len=64), dimension(:,:), allocatable, target, public :: & + character(len=64), dimension(:,:), allocatable, target, public :: & plastic_isotropic_output !< name of each post result output enum, bind(c) @@ -42,8 +42,8 @@ module plastic_isotropic tausat_SinhFitD, & aTolFlowstress, & aTolShear - integer(pInt) :: & - of_debug = 0_pInt + integer :: & + of_debug = 0 integer(kind(undefined_ID)), allocatable, dimension(:) :: & outputID logical :: & @@ -109,7 +109,7 @@ subroutine plastic_isotropic_init use lattice implicit none - integer(pInt) :: & + integer :: & Ninstance, & p, i, & NipcMyPhase, & @@ -131,10 +131,10 @@ subroutine plastic_isotropic_init write(6,'(a)') ' https://doi.org/10.1016/j.scriptamat.2017.09.047' Ninstance = count(phase_plasticity == PLASTICITY_ISOTROPIC_ID) - if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0) & write(6,'(a16,1x,i5,/)') '# instances:',Ninstance - allocate(plastic_isotropic_sizePostResult(maxval(phase_Noutput),Ninstance),source=0_pInt) + allocate(plastic_isotropic_sizePostResult(maxval(phase_Noutput),Ninstance),source=0) allocate(plastic_isotropic_output(maxval(phase_Noutput),Ninstance)) plastic_isotropic_output = '' @@ -142,7 +142,7 @@ subroutine plastic_isotropic_init allocate(state(Ninstance)) allocate(dotState(Ninstance)) - do p = 1_pInt, size(phase_plasticity) + do p = 1, size(phase_plasticity) if (phase_plasticity(p) /= PLASTICITY_ISOTROPIC_ID) cycle associate(prm => param(phase_plasticityInstance(p)), & dot => dotState(phase_plasticityInstance(p)), & @@ -188,13 +188,13 @@ subroutine plastic_isotropic_init !-------------------------------------------------------------------------------------------------- ! exit if any parameter is out of range if (extmsg /= '') & - call IO_error(211_pInt,ext_msg=trim(extmsg)//'('//PLASTICITY_ISOTROPIC_label//')') + call IO_error(211,ext_msg=trim(extmsg)//'('//PLASTICITY_ISOTROPIC_label//')') !-------------------------------------------------------------------------------------------------- ! output pararameters outputs = config%getStrings('(output)',defaultVal=emptyStringArray) allocate(prm%outputID(0)) - do i=1_pInt, size(outputs) + do i=1, size(outputs) outputID = undefined_ID select case(outputs(i)) @@ -207,7 +207,7 @@ subroutine plastic_isotropic_init if (outputID /= undefined_ID) then plastic_isotropic_output(i,phase_plasticityInstance(p)) = outputs(i) - plastic_isotropic_sizePostResult(i,phase_plasticityInstance(p)) = 1_pInt + plastic_isotropic_sizePostResult(i,phase_plasticityInstance(p)) = 1 prm%outputID = [prm%outputID, outputID] endif @@ -219,8 +219,8 @@ subroutine plastic_isotropic_init sizeDotState = size(['flowstress ','accumulated_shear']) sizeState = sizeDotState - call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,0_pInt, & - 1_pInt,0_pInt,0_pInt) + call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,0, & + 1,0,0) plasticState(p)%sizePostResults = sum(plastic_isotropic_sizePostResult(:,phase_plasticityInstance(p))) !-------------------------------------------------------------------------------------------------- @@ -269,7 +269,7 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress - integer(pInt), intent(in) :: & + integer, intent(in) :: & instance, & of @@ -279,7 +279,7 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) gamma_dot, & !< 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 - integer(pInt) :: & + integer :: & k, l, m, n associate(prm => param(instance), stt => state(instance)) @@ -293,19 +293,19 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) Lp = Mp_dev/norm_Mp_dev * gamma_dot/prm%fTaylor #ifdef DEBUG - if (iand(debug_level(debug_constitutive), debug_levelExtensive) /= 0_pInt & - .and. (of == prm%of_debug .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0_pInt)) then + if (iand(debug_level(debug_constitutive), debug_levelExtensive) /= 0 & + .and. (of == prm%of_debug .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0)) then write(6,'(/,a,/,3(12x,3(f12.4,1x)/))') '<< CONST isotropic >> Tstar (dev) / MPa', & transpose(Mp_dev)*1.0e-6_pReal write(6,'(/,a,/,f12.5)') '<< CONST isotropic >> norm Tstar / MPa', norm_Mp_dev*1.0e-6_pReal write(6,'(/,a,/,f12.5)') '<< CONST isotropic >> gdot', gamma_dot end if #endif - forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + forall (k=1:3,l=1:3,m=1:3,n=1:3) & dLp_dMp(k,l,m,n) = (prm%n-1.0_pReal) * Mp_dev(k,l)*Mp_dev(m,n) / squarenorm_Mp_dev - forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt) & + forall (k=1:3,l=1:3) & dLp_dMp(k,l,k,l) = dLp_dMp(k,l,k,l) + 1.0_pReal - forall (k=1_pInt:3_pInt,m=1_pInt:3_pInt) & + 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 = gamma_dot / prm%fTaylor * dLp_dMp / norm_Mp_dev else @@ -335,7 +335,7 @@ subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar,Tstar,instance,of) real(pReal), dimension(3,3), intent(in) :: & Tstar !< Mandel stress ToDo: Mi? - integer(pInt), intent(in) :: & + integer, intent(in) :: & instance, & of @@ -345,7 +345,7 @@ subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar,Tstar,instance,of) gamma_dot, & !< strainrate norm_Tstar_sph, & !< euclidean norm of Tstar_sph squarenorm_Tstar_sph !< square of the euclidean norm of Tstar_sph - integer(pInt) :: & + integer :: & k, l, m, n associate(prm => param(instance), stt => state(instance)) @@ -358,9 +358,9 @@ subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar,Tstar,instance,of) gamma_dot = prm%gdot0 * (sqrt(1.5_pReal) * norm_Tstar_sph /(prm%fTaylor*stt%flowstress(of))) **prm%n Li = Tstar_sph/norm_Tstar_sph * gamma_dot/prm%fTaylor - forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + forall (k=1:3,l=1:3,m=1:3,n=1:3) & dLi_dTstar(k,l,m,n) = (prm%n-1.0_pReal) * Tstar_sph(k,l)*Tstar_sph(m,n) / squarenorm_Tstar_sph - forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt) & + forall (k=1:3,l=1:3) & dLi_dTstar(k,l,k,l) = dLi_dTstar(k,l,k,l) + 1.0_pReal dLi_dTstar = gamma_dot / prm%fTaylor * dLi_dTstar / norm_Tstar_sph @@ -387,7 +387,7 @@ subroutine plastic_isotropic_dotState(Mp,instance,of) implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress - integer(pInt), intent(in) :: & + integer, intent(in) :: & instance, & of @@ -442,7 +442,7 @@ function plastic_isotropic_postResults(Mp,instance,of) result(postResults) implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress - integer(pInt), intent(in) :: & + integer, intent(in) :: & instance, & of @@ -451,7 +451,7 @@ function plastic_isotropic_postResults(Mp,instance,of) result(postResults) real(pReal) :: & norm_Mp !< norm of the Mandel stress - integer(pInt) :: & + integer :: & o,c associate(prm => param(instance), stt => state(instance)) @@ -462,18 +462,18 @@ function plastic_isotropic_postResults(Mp,instance,of) result(postResults) norm_Mp = sqrt(math_mul33xx33(math_deviatoric33(Mp),math_deviatoric33(Mp))) endif - c = 0_pInt + c = 0 - outputsLoop: do o = 1_pInt,size(prm%outputID) + outputsLoop: do o = 1,size(prm%outputID) select case(prm%outputID(o)) case (flowstress_ID) - postResults(c+1_pInt) = stt%flowstress(of) - c = c + 1_pInt + postResults(c+1) = stt%flowstress(of) + c = c + 1 case (strainrate_ID) - postResults(c+1_pInt) = prm%gdot0 & + postResults(c+1) = prm%gdot0 & * (sqrt(1.5_pReal) * norm_Mp /(prm%fTaylor * stt%flowstress(of)))**prm%n - c = c + 1_pInt + c = c + 1 end select enddo outputsLoop @@ -496,7 +496,7 @@ subroutine plastic_isotropic_results(instance,group) integer :: o associate(prm => param(instance), stt => state(instance)) - outputsLoop: do o = 1_pInt,size(prm%outputID) + outputsLoop: do o = 1,size(prm%outputID) select case(prm%outputID(o)) end select enddo outputsLoop diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 7d09de1ef..0a4a6b3bc 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -7,14 +7,13 @@ !-------------------------------------------------------------------------------------------------- module plastic_kinehardening use prec, only: & - pReal, & - pInt + pReal implicit none private - integer(pInt), dimension(:,:), allocatable, target, public :: & + integer, dimension(:,:), allocatable, target, public :: & plastic_kinehardening_sizePostResult !< size of each post result output - character(len=64), dimension(:,:), allocatable, target, public :: & + character(len=64), dimension(:,:), allocatable, target, public :: & plastic_kinehardening_output !< name of each post result output enum, bind(c) @@ -36,7 +35,7 @@ module plastic_kinehardening n, & !< stress exponent for slip aTolResistance, & aTolShear - real(pReal), allocatable, dimension(:) :: & + real(pReal), allocatable, dimension(:) :: & crss0, & !< initial critical shear stress for slip theta0, & !< initial hardening rate of forward stress for each slip theta1, & !< asymptotic hardening rate of forward stress for each slip @@ -45,16 +44,16 @@ module plastic_kinehardening tau1, & tau1_b, & nonSchmidCoeff - real(pReal), allocatable, dimension(:,:) :: & + real(pReal), allocatable, dimension(:,:) :: & interaction_slipslip !< slip resistance from slip activity - real(pReal), allocatable, dimension(:,:,:) :: & + real(pReal), allocatable, dimension(:,:,:) :: & Schmid, & nonSchmid_pos, & nonSchmid_neg - integer(pInt) :: & + integer :: & totalNslip, & !< total number of active slip system - of_debug = 0_pInt - integer(pInt), allocatable, dimension(:) :: & + of_debug = 0 + integer, allocatable, dimension(:) :: & Nslip !< number of active slip systems for each family integer(kind(undefined_ID)), allocatable, dimension(:) :: & outputID !< ID of each post result output @@ -130,14 +129,14 @@ subroutine plastic_kinehardening_init use lattice implicit none - integer(pInt) :: & + integer :: & Ninstance, & p, i, o, & NipcMyPhase, & sizeState, sizeDeltaState, sizeDotState, & startIndex, endIndex - integer(pInt), dimension(0), parameter :: emptyIntArray = [integer(pInt)::] + integer, dimension(0), parameter :: emptyIntArray = [integer::] real(pReal), dimension(0), parameter :: emptyRealArray = [real(pReal)::] character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] @@ -155,7 +154,7 @@ subroutine plastic_kinehardening_init if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0) & write(6,'(a16,1x,i5,/)') '# instances:',Ninstance - allocate(plastic_kinehardening_sizePostResult(maxval(phase_Noutput),Ninstance),source=0_pInt) + allocate(plastic_kinehardening_sizePostResult(maxval(phase_Noutput),Ninstance),source=0) allocate(plastic_kinehardening_output(maxval(phase_Noutput),Ninstance)) plastic_kinehardening_output = '' @@ -164,7 +163,7 @@ subroutine plastic_kinehardening_init allocate(dotState(Ninstance)) allocate(deltaState(Ninstance)) - do p = 1_pInt, size(phase_plasticityInstance) + do p = 1, size(phase_plasticityInstance) if (phase_plasticity(p) /= PLASTICITY_KINEHARDENING_ID) cycle associate(prm => param(phase_plasticityInstance(p)), & dot => dotState(phase_plasticityInstance(p)), & @@ -191,15 +190,15 @@ subroutine plastic_kinehardening_init ! slip related parameters prm%Nslip = config%getInts('nslip',defaultVal=emptyIntArray) prm%totalNslip = sum(prm%Nslip) - slipActive: if (prm%totalNslip > 0_pInt) then + slipActive: if (prm%totalNslip > 0) then prm%Schmid = lattice_SchmidMatrix_slip(prm%Nslip,config%getString('lattice_structure'),& config%getFloat('c/a',defaultVal=0.0_pReal)) if(trim(config%getString('lattice_structure')) == 'bcc') then prm%nonSchmidCoeff = config%getFloats('nonschmid_coefficients',& defaultVal = emptyRealArray) - prm%nonSchmid_pos = lattice_nonSchmidMatrix(prm%Nslip,prm%nonSchmidCoeff,+1_pInt) - prm%nonSchmid_neg = lattice_nonSchmidMatrix(prm%Nslip,prm%nonSchmidCoeff,-1_pInt) + prm%nonSchmid_pos = lattice_nonSchmidMatrix(prm%Nslip,prm%nonSchmidCoeff,+1) + prm%nonSchmid_neg = lattice_nonSchmidMatrix(prm%Nslip,prm%nonSchmidCoeff,-1) else prm%nonSchmid_pos = prm%Schmid prm%nonSchmid_neg = prm%Schmid @@ -245,32 +244,32 @@ subroutine plastic_kinehardening_init !-------------------------------------------------------------------------------------------------- ! exit if any parameter is out of range if (extmsg /= '') & - call IO_error(211_pInt,ext_msg=trim(extmsg)//'('//PLASTICITY_KINEHARDENING_label//')') + call IO_error(211,ext_msg=trim(extmsg)//'('//PLASTICITY_KINEHARDENING_label//')') !-------------------------------------------------------------------------------------------------- ! output pararameters outputs = config%getStrings('(output)',defaultVal=emptyStringArray) allocate(prm%outputID(0)) - do i=1_pInt, size(outputs) + do i=1, size(outputs) outputID = undefined_ID select case(outputs(i)) case ('resistance') - outputID = merge(crss_ID,undefined_ID,prm%totalNslip>0_pInt) + outputID = merge(crss_ID,undefined_ID,prm%totalNslip>0) case ('accumulatedshear') - outputID = merge(accshear_ID,undefined_ID,prm%totalNslip>0_pInt) + outputID = merge(accshear_ID,undefined_ID,prm%totalNslip>0) case ('shearrate') - outputID = merge(shearrate_ID,undefined_ID,prm%totalNslip>0_pInt) + outputID = merge(shearrate_ID,undefined_ID,prm%totalNslip>0) case ('resolvedstress') - outputID = merge(resolvedstress_ID,undefined_ID,prm%totalNslip>0_pInt) + outputID = merge(resolvedstress_ID,undefined_ID,prm%totalNslip>0) case ('backstress') - outputID = merge(crss_back_ID,undefined_ID,prm%totalNslip>0_pInt) + outputID = merge(crss_back_ID,undefined_ID,prm%totalNslip>0) case ('sense') - outputID = merge(sense_ID,undefined_ID,prm%totalNslip>0_pInt) + outputID = merge(sense_ID,undefined_ID,prm%totalNslip>0) case ('chi0') - outputID = merge(chi0_ID,undefined_ID,prm%totalNslip>0_pInt) + outputID = merge(chi0_ID,undefined_ID,prm%totalNslip>0) case ('gamma0') - outputID = merge(gamma0_ID,undefined_ID,prm%totalNslip>0_pInt) + outputID = merge(gamma0_ID,undefined_ID,prm%totalNslip>0) end select @@ -290,25 +289,25 @@ subroutine plastic_kinehardening_init sizeState = sizeDotState + sizeDeltaState call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,sizeDeltaState, & - prm%totalNslip,0_pInt,0_pInt) + prm%totalNslip,0,0) plasticState(p)%sizePostResults = sum(plastic_kinehardening_sizePostResult(:,phase_plasticityInstance(p))) !-------------------------------------------------------------------------------------------------- ! locally defined state aliases and initialization of state0 and aTolState - startIndex = 1_pInt + startIndex = 1 endIndex = prm%totalNslip stt%crss => plasticState(p)%state (startIndex:endIndex,:) stt%crss = spread(prm%crss0, 2, NipcMyPhase) dot%crss => plasticState(p)%dotState(startIndex:endIndex,:) plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolResistance - startIndex = endIndex + 1_pInt + startIndex = endIndex + 1 endIndex = endIndex + prm%totalNslip stt%crss_back => plasticState(p)%state (startIndex:endIndex,:) dot%crss_back => plasticState(p)%dotState(startIndex:endIndex,:) plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolResistance - startIndex = endIndex + 1_pInt + startIndex = endIndex + 1 endIndex = endIndex + prm%totalNslip stt%accshear => plasticState(p)%state (startIndex:endIndex,:) dot%accshear => plasticState(p)%dotState(startIndex:endIndex,:) @@ -318,17 +317,17 @@ subroutine plastic_kinehardening_init plasticState(p)%accumulatedSlip => plasticState(p)%state(startIndex:endIndex,:) o = plasticState(p)%offsetDeltaState - startIndex = endIndex + 1_pInt + startIndex = endIndex + 1 endIndex = endIndex + prm%totalNslip stt%sense => plasticState(p)%state (startIndex :endIndex ,:) dlt%sense => plasticState(p)%deltaState(startIndex-o:endIndex-o,:) - startIndex = endIndex + 1_pInt + startIndex = endIndex + 1 endIndex = endIndex + prm%totalNslip stt%chi0 => plasticState(p)%state (startIndex :endIndex ,:) dlt%chi0 => plasticState(p)%deltaState(startIndex-o:endIndex-o,:) - startIndex = endIndex + 1_pInt + startIndex = endIndex + 1 endIndex = endIndex + prm%totalNslip stt%gamma0 => plasticState(p)%state (startIndex :endIndex ,:) dlt%gamma0 => plasticState(p)%deltaState(startIndex-o:endIndex-o,:) @@ -355,11 +354,11 @@ pure subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress - integer(pInt), intent(in) :: & + integer, intent(in) :: & instance, & of - integer(pInt) :: & + integer :: & i,k,l,m,n real(pReal), dimension(param(instance)%totalNslip) :: & gdot_pos,gdot_neg, & @@ -372,9 +371,9 @@ pure subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) call kinetics(Mp,instance,of,gdot_pos,gdot_neg,dgdot_dtau_pos,dgdot_dtau_neg) - do i = 1_pInt, prm%totalNslip + do i = 1, prm%totalNslip Lp = Lp + (gdot_pos(i)+gdot_neg(i))*prm%Schmid(1:3,1:3,i) - forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + forall (k=1:3,l=1:3,m=1:3,n=1:3) & dLp_dMp(k,l,m,n) = dLp_dMp(k,l,m,n) & + dgdot_dtau_pos(i) * prm%Schmid(k,l,i) * prm%nonSchmid_pos(m,n,i) & + dgdot_dtau_neg(i) * prm%Schmid(k,l,i) * prm%nonSchmid_neg(m,n,i) @@ -393,7 +392,7 @@ subroutine plastic_kinehardening_dotState(Mp,instance,of) implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress - integer(pInt), intent(in) :: & + integer, intent(in) :: & instance, & of @@ -446,7 +445,7 @@ subroutine plastic_kinehardening_deltaState(Mp,instance,of) implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress - integer(pInt), intent(in) :: & + integer, intent(in) :: & instance, & of @@ -462,9 +461,9 @@ subroutine plastic_kinehardening_deltaState(Mp,instance,of) dEq0(gdot_pos+gdot_neg,1e-10_pReal)) ! current sense of shear direction #ifdef DEBUG - if (iand(debug_level(debug_constitutive), debug_levelExtensive) /= 0_pInt & + if (iand(debug_level(debug_constitutive), debug_levelExtensive) /= 0 & .and. (of == prm%of_debug & - .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0_pInt)) then + .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0)) then write(6,'(a)') '======= kinehardening delta state =======' write(6,*) sense,state(instance)%sense(:,of) endif @@ -497,42 +496,42 @@ function plastic_kinehardening_postResults(Mp,instance,of) result(postResults) implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress - integer(pInt), intent(in) :: & + integer, intent(in) :: & instance, & of real(pReal), dimension(sum(plastic_kinehardening_sizePostResult(:,instance))) :: & postResults - integer(pInt) :: & + integer :: & o,c,i real(pReal), dimension(param(instance)%totalNslip) :: & gdot_pos,gdot_neg - c = 0_pInt + c = 0 associate(prm => param(instance), stt => state(instance)) - outputsLoop: do o = 1_pInt,size(prm%outputID) + outputsLoop: do o = 1,size(prm%outputID) select case(prm%outputID(o)) case (crss_ID) - postResults(c+1_pInt:c+prm%totalNslip) = stt%crss(:,of) + postResults(c+1:c+prm%totalNslip) = stt%crss(:,of) case(crss_back_ID) - postResults(c+1_pInt:c+prm%totalNslip) = stt%crss_back(:,of) + postResults(c+1:c+prm%totalNslip) = stt%crss_back(:,of) case (sense_ID) - postResults(c+1_pInt:c+prm%totalNslip) = stt%sense(:,of) + postResults(c+1:c+prm%totalNslip) = stt%sense(:,of) case (chi0_ID) - postResults(c+1_pInt:c+prm%totalNslip) = stt%chi0(:,of) + postResults(c+1:c+prm%totalNslip) = stt%chi0(:,of) case (gamma0_ID) - postResults(c+1_pInt:c+prm%totalNslip) = stt%gamma0(:,of) + postResults(c+1:c+prm%totalNslip) = stt%gamma0(:,of) case (accshear_ID) - postResults(c+1_pInt:c+prm%totalNslip) = stt%accshear(:,of) + postResults(c+1:c+prm%totalNslip) = stt%accshear(:,of) case (shearrate_ID) call kinetics(Mp,instance,of,gdot_pos,gdot_neg) - postResults(c+1_pInt:c+prm%totalNslip) = gdot_pos+gdot_neg + postResults(c+1:c+prm%totalNslip) = gdot_pos+gdot_neg case (resolvedstress_ID) - do i = 1_pInt, prm%totalNslip + do i = 1, prm%totalNslip postResults(c+i) = math_mul33xx33(Mp,prm%Schmid(1:3,1:3,i)) enddo @@ -560,7 +559,7 @@ subroutine plastic_kinehardening_results(instance,group) integer :: o associate(prm => param(instance), stt => state(instance)) - outputsLoop: do o = 1_pInt,size(prm%outputID) + outputsLoop: do o = 1,size(prm%outputID) select case(prm%outputID(o)) end select enddo outputsLoop @@ -589,7 +588,7 @@ pure subroutine kinetics(Mp,instance,of, & implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress - integer(pInt), intent(in) :: & + integer, intent(in) :: & instance, & of @@ -603,14 +602,14 @@ pure subroutine kinetics(Mp,instance,of, & real(pReal), dimension(param(instance)%totalNslip) :: & tau_pos, & tau_neg - integer(pInt) :: i - logical :: nonSchmidActive + integer :: i + logical :: nonSchmidActive associate(prm => param(instance), stt => state(instance)) - nonSchmidActive = size(prm%nonSchmidCoeff) > 0_pInt + nonSchmidActive = size(prm%nonSchmidCoeff) > 0 - do i = 1_pInt, prm%totalNslip + do i = 1, prm%totalNslip tau_pos(i) = math_mul33xx33(Mp,prm%nonSchmid_pos(1:3,1:3,i)) - stt%crss_back(i,of) tau_neg(i) = merge(math_mul33xx33(Mp,prm%nonSchmid_neg(1:3,1:3,i)) - stt%crss_back(i,of), & 0.0_pReal, nonSchmidActive) diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 index 4fde804b5..4124856d1 100644 --- a/src/plastic_phenopowerlaw.f90 +++ b/src/plastic_phenopowerlaw.f90 @@ -6,14 +6,13 @@ !-------------------------------------------------------------------------------------------------- module plastic_phenopowerlaw use prec, only: & - pReal, & - pInt + pReal implicit none private - integer(pInt), dimension(:,:), allocatable, target, public :: & + integer, dimension(:,:), allocatable, target, public :: & plastic_phenopowerlaw_sizePostResult !< size of each post result output - character(len=64), dimension(:,:), allocatable, target, public :: & + character(len=64), dimension(:,:), allocatable, target, public :: & plastic_phenopowerlaw_output !< name of each post result output enum, bind(c) @@ -47,27 +46,27 @@ module plastic_phenopowerlaw aTolResistance, & !< absolute tolerance for integration of xi aTolShear, & !< absolute tolerance for integration of gamma aTolTwinfrac !< absolute tolerance for integration of f - real(pReal), allocatable, dimension(:) :: & + real(pReal), allocatable, dimension(:) :: & xi_slip_0, & !< initial critical shear stress for slip xi_twin_0, & !< initial critical shear stress for twin xi_slip_sat, & !< maximum critical shear stress for slip nonSchmidCoeff, & H_int, & !< per family hardening activity (optional) gamma_twin_char !< characteristic shear for twins - real(pReal), allocatable, dimension(:,:) :: & + real(pReal), allocatable, dimension(:,:) :: & interaction_SlipSlip, & !< slip resistance from slip activity interaction_SlipTwin, & !< slip resistance from twin activity interaction_TwinSlip, & !< twin resistance from slip activity interaction_TwinTwin !< twin resistance from twin activity - real(pReal), allocatable, dimension(:,:,:) :: & + real(pReal), allocatable, dimension(:,:,:) :: & Schmid_slip, & Schmid_twin, & nonSchmid_pos, & nonSchmid_neg - integer(pInt) :: & + integer :: & totalNslip, & !< total number of active slip system totalNtwin !< total number of active twin systems - integer(pInt), allocatable, dimension(:) :: & + integer, allocatable, dimension(:) :: & Nslip, & !< number of active slip systems for each family Ntwin !< number of active twin systems for each family integer(kind(undefined_ID)), allocatable, dimension(:) :: & @@ -131,14 +130,14 @@ subroutine plastic_phenopowerlaw_init use lattice implicit none - integer(pInt) :: & + integer :: & Ninstance, & p, i, & NipcMyPhase, outputSize, & sizeState, sizeDotState, & startIndex, endIndex - integer(pInt), dimension(0), parameter :: emptyIntArray = [integer(pInt)::] + integer, dimension(0), parameter :: emptyIntArray = [integer::] real(pReal), dimension(0), parameter :: emptyRealArray = [real(pReal)::] character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] @@ -164,7 +163,7 @@ subroutine plastic_phenopowerlaw_init allocate(state(Ninstance)) allocate(dotState(Ninstance)) - do p = 1_pInt, size(phase_plasticity) + do p = 1, size(phase_plasticity) if (phase_plasticity(p) /= PLASTICITY_PHENOPOWERLAW_ID) cycle associate(prm => param(phase_plasticityInstance(p)), & dot => dotState(phase_plasticityInstance(p)), & @@ -191,15 +190,15 @@ subroutine plastic_phenopowerlaw_init ! slip related parameters prm%Nslip = config%getInts('nslip',defaultVal=emptyIntArray) prm%totalNslip = sum(prm%Nslip) - slipActive: if (prm%totalNslip > 0_pInt) then + slipActive: if (prm%totalNslip > 0) then prm%Schmid_slip = lattice_SchmidMatrix_slip(prm%Nslip,config%getString('lattice_structure'),& config%getFloat('c/a',defaultVal=0.0_pReal)) if(trim(config%getString('lattice_structure')) == 'bcc') then prm%nonSchmidCoeff = config%getFloats('nonschmid_coefficients',& defaultVal = emptyRealArray) - prm%nonSchmid_pos = lattice_nonSchmidMatrix(prm%Nslip,prm%nonSchmidCoeff,+1_pInt) - prm%nonSchmid_neg = lattice_nonSchmidMatrix(prm%Nslip,prm%nonSchmidCoeff,-1_pInt) + prm%nonSchmid_pos = lattice_nonSchmidMatrix(prm%Nslip,prm%nonSchmidCoeff,+1) + prm%nonSchmid_neg = lattice_nonSchmidMatrix(prm%Nslip,prm%nonSchmidCoeff,-1) else prm%nonSchmid_pos = prm%Schmid_slip prm%nonSchmid_neg = prm%Schmid_slip @@ -211,7 +210,7 @@ subroutine plastic_phenopowerlaw_init prm%xi_slip_0 = config%getFloats('tau0_slip', requiredSize=size(prm%Nslip)) prm%xi_slip_sat = config%getFloats('tausat_slip', requiredSize=size(prm%Nslip)) prm%H_int = config%getFloats('h_int', requiredSize=size(prm%Nslip), & - defaultVal=[(0.0_pReal,i=1_pInt,size(prm%Nslip))]) + defaultVal=[(0.0_pReal,i=1,size(prm%Nslip))]) prm%gdot0_slip = config%getFloat('gdot0_slip') prm%n_slip = config%getFloat('n_slip') @@ -238,7 +237,7 @@ subroutine plastic_phenopowerlaw_init ! twin related parameters prm%Ntwin = config%getInts('ntwin', defaultVal=emptyIntArray) prm%totalNtwin = sum(prm%Ntwin) - twinActive: if (prm%totalNtwin > 0_pInt) then + twinActive: if (prm%totalNtwin > 0) then prm%Schmid_twin = lattice_SchmidMatrix_twin(prm%Ntwin,config%getString('lattice_structure'),& config%getFloat('c/a',defaultVal=0.0_pReal)) prm%interaction_TwinTwin = transpose(lattice_interaction_TwinByTwin(prm%Ntwin,& @@ -268,7 +267,7 @@ subroutine plastic_phenopowerlaw_init !-------------------------------------------------------------------------------------------------- ! slip-twin related parameters - slipAndTwinActive: if (prm%totalNslip > 0_pInt .and. prm%totalNtwin > 0_pInt) then + slipAndTwinActive: if (prm%totalNslip > 0 .and. prm%totalNtwin > 0) then prm%interaction_SlipTwin = transpose(lattice_interaction_SlipByTwin(prm%Nslip,prm%Ntwin,& config%getFloats('interaction_sliptwin'), & config%getString('lattice_structure'))) @@ -284,40 +283,40 @@ subroutine plastic_phenopowerlaw_init !-------------------------------------------------------------------------------------------------- ! exit if any parameter is out of range if (extmsg /= '') & - call IO_error(211_pInt,ext_msg=trim(extmsg)//'('//PLASTICITY_PHENOPOWERLAW_label//')') + call IO_error(211,ext_msg=trim(extmsg)//'('//PLASTICITY_PHENOPOWERLAW_label//')') !-------------------------------------------------------------------------------------------------- ! output pararameters outputs = config%getStrings('(output)',defaultVal=emptyStringArray) allocate(prm%outputID(0)) - do i=1_pInt, size(outputs) + do i=1, size(outputs) outputID = undefined_ID select case(outputs(i)) case ('resistance_slip') - outputID = merge(resistance_slip_ID,undefined_ID,prm%totalNslip>0_pInt) + outputID = merge(resistance_slip_ID,undefined_ID,prm%totalNslip>0) outputSize = prm%totalNslip case ('accumulatedshear_slip') - outputID = merge(accumulatedshear_slip_ID,undefined_ID,prm%totalNslip>0_pInt) + outputID = merge(accumulatedshear_slip_ID,undefined_ID,prm%totalNslip>0) outputSize = prm%totalNslip case ('shearrate_slip') - outputID = merge(shearrate_slip_ID,undefined_ID,prm%totalNslip>0_pInt) + outputID = merge(shearrate_slip_ID,undefined_ID,prm%totalNslip>0) outputSize = prm%totalNslip case ('resolvedstress_slip') - outputID = merge(resolvedstress_slip_ID,undefined_ID,prm%totalNslip>0_pInt) + outputID = merge(resolvedstress_slip_ID,undefined_ID,prm%totalNslip>0) outputSize = prm%totalNslip case ('resistance_twin') - outputID = merge(resistance_twin_ID,undefined_ID,prm%totalNtwin>0_pInt) + outputID = merge(resistance_twin_ID,undefined_ID,prm%totalNtwin>0) outputSize = prm%totalNtwin case ('accumulatedshear_twin') - outputID = merge(accumulatedshear_twin_ID,undefined_ID,prm%totalNtwin>0_pInt) + outputID = merge(accumulatedshear_twin_ID,undefined_ID,prm%totalNtwin>0) outputSize = prm%totalNtwin case ('shearrate_twin') - outputID = merge(shearrate_twin_ID,undefined_ID,prm%totalNtwin>0_pInt) + outputID = merge(shearrate_twin_ID,undefined_ID,prm%totalNtwin>0) outputSize = prm%totalNtwin case ('resolvedstress_twin') - outputID = merge(resolvedstress_twin_ID,undefined_ID,prm%totalNtwin>0_pInt) + outputID = merge(resolvedstress_twin_ID,undefined_ID,prm%totalNtwin>0) outputSize = prm%totalNtwin end select @@ -337,27 +336,27 @@ subroutine plastic_phenopowerlaw_init + size(['tau_twin ','gamma_twin']) * prm%totalNtwin sizeState = sizeDotState - call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,0_pInt, & - prm%totalNslip,prm%totalNtwin,0_pInt) + call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,0, & + prm%totalNslip,prm%totalNtwin,0) plasticState(p)%sizePostResults = sum(plastic_phenopowerlaw_sizePostResult(:,phase_plasticityInstance(p))) !-------------------------------------------------------------------------------------------------- ! locally defined state aliases and initialization of state0 and aTolState - startIndex = 1_pInt + startIndex = 1 endIndex = prm%totalNslip stt%xi_slip => plasticState(p)%state (startIndex:endIndex,:) stt%xi_slip = spread(prm%xi_slip_0, 2, NipcMyPhase) dot%xi_slip => plasticState(p)%dotState(startIndex:endIndex,:) plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolResistance - startIndex = endIndex + 1_pInt + startIndex = endIndex + 1 endIndex = endIndex + prm%totalNtwin stt%xi_twin => plasticState(p)%state (startIndex:endIndex,:) stt%xi_twin = spread(prm%xi_twin_0, 2, NipcMyPhase) dot%xi_twin => plasticState(p)%dotState(startIndex:endIndex,:) plasticState(p)%aTolState(startIndex:endIndex) = prm%aTolResistance - startIndex = endIndex + 1_pInt + startIndex = endIndex + 1 endIndex = endIndex + prm%totalNslip stt%gamma_slip => plasticState(p)%state (startIndex:endIndex,:) dot%gamma_slip => plasticState(p)%dotState(startIndex:endIndex,:) @@ -366,7 +365,7 @@ subroutine plastic_phenopowerlaw_init plasticState(p)%slipRate => plasticState(p)%dotState(startIndex:endIndex,:) plasticState(p)%accumulatedSlip => plasticState(p)%state(startIndex:endIndex,:) - startIndex = endIndex + 1_pInt + startIndex = endIndex + 1 endIndex = endIndex + prm%totalNtwin stt%gamma_twin => plasticState(p)%state (startIndex:endIndex,:) dot%gamma_twin => plasticState(p)%dotState(startIndex:endIndex,:) @@ -396,11 +395,11 @@ pure subroutine plastic_phenopowerlaw_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress - integer(pInt), intent(in) :: & + integer, intent(in) :: & instance, & of - integer(pInt) :: & + integer :: & i,k,l,m,n real(pReal), dimension(param(instance)%totalNslip) :: & gdot_slip_pos,gdot_slip_neg, & @@ -414,18 +413,18 @@ pure subroutine plastic_phenopowerlaw_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) associate(prm => param(instance)) call kinetics_slip(Mp,instance,of,gdot_slip_pos,gdot_slip_neg,dgdot_dtauslip_pos,dgdot_dtauslip_neg) - slipSystems: do i = 1_pInt, prm%totalNslip + slipSystems: do i = 1, prm%totalNslip Lp = Lp + (gdot_slip_pos(i)+gdot_slip_neg(i))*prm%Schmid_slip(1:3,1:3,i) - forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + forall (k=1:3,l=1:3,m=1:3,n=1:3) & dLp_dMp(k,l,m,n) = dLp_dMp(k,l,m,n) & + dgdot_dtauslip_pos(i) * prm%Schmid_slip(k,l,i) * prm%nonSchmid_pos(m,n,i) & + dgdot_dtauslip_neg(i) * prm%Schmid_slip(k,l,i) * prm%nonSchmid_neg(m,n,i) enddo slipSystems call kinetics_twin(Mp,instance,of,gdot_twin,dgdot_dtautwin) - twinSystems: do i = 1_pInt, prm%totalNtwin + twinSystems: do i = 1, prm%totalNtwin Lp = Lp + gdot_twin(i)*prm%Schmid_twin(1:3,1:3,i) - forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + forall (k=1:3,l=1:3,m=1:3,n=1:3) & dLp_dMp(k,l,m,n) = dLp_dMp(k,l,m,n) & + dgdot_dtautwin(i)*prm%Schmid_twin(k,l,i)*prm%Schmid_twin(m,n,i) enddo twinSystems @@ -443,7 +442,7 @@ subroutine plastic_phenopowerlaw_dotState(Mp,instance,of) implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress - integer(pInt), intent(in) :: & + integer, intent(in) :: & instance, & of @@ -502,52 +501,52 @@ function plastic_phenopowerlaw_postResults(Mp,instance,of) result(postResults) implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress - integer(pInt), intent(in) :: & + integer, intent(in) :: & instance, & of real(pReal), dimension(sum(plastic_phenopowerlaw_sizePostResult(:,instance))) :: & postResults - integer(pInt) :: & + integer :: & o,c,i real(pReal), dimension(param(instance)%totalNslip) :: & gdot_slip_pos,gdot_slip_neg - c = 0_pInt + c = 0 associate(prm => param(instance), stt => state(instance)) - outputsLoop: do o = 1_pInt,size(prm%outputID) + outputsLoop: do o = 1,size(prm%outputID) select case(prm%outputID(o)) case (resistance_slip_ID) - postResults(c+1_pInt:c+prm%totalNslip) = stt%xi_slip(1:prm%totalNslip,of) + postResults(c+1:c+prm%totalNslip) = stt%xi_slip(1:prm%totalNslip,of) c = c + prm%totalNslip case (accumulatedshear_slip_ID) - postResults(c+1_pInt:c+prm%totalNslip) = stt%gamma_slip(1:prm%totalNslip,of) + postResults(c+1:c+prm%totalNslip) = stt%gamma_slip(1:prm%totalNslip,of) c = c + prm%totalNslip case (shearrate_slip_ID) call kinetics_slip(Mp,instance,of,gdot_slip_pos,gdot_slip_neg) - postResults(c+1_pInt:c+prm%totalNslip) = gdot_slip_pos+gdot_slip_neg + postResults(c+1:c+prm%totalNslip) = gdot_slip_pos+gdot_slip_neg c = c + prm%totalNslip case (resolvedstress_slip_ID) - do i = 1_pInt, prm%totalNslip + do i = 1, prm%totalNslip postResults(c+i) = math_mul33xx33(Mp,prm%Schmid_slip(1:3,1:3,i)) enddo c = c + prm%totalNslip case (resistance_twin_ID) - postResults(c+1_pInt:c+prm%totalNtwin) = stt%xi_twin(1:prm%totalNtwin,of) + postResults(c+1:c+prm%totalNtwin) = stt%xi_twin(1:prm%totalNtwin,of) c = c + prm%totalNtwin case (accumulatedshear_twin_ID) - postResults(c+1_pInt:c+prm%totalNtwin) = stt%gamma_twin(1:prm%totalNtwin,of) + postResults(c+1:c+prm%totalNtwin) = stt%gamma_twin(1:prm%totalNtwin,of) c = c + prm%totalNtwin case (shearrate_twin_ID) - call kinetics_twin(Mp,instance,of,postResults(c+1_pInt:c+prm%totalNtwin)) + call kinetics_twin(Mp,instance,of,postResults(c+1:c+prm%totalNtwin)) c = c + prm%totalNtwin case (resolvedstress_twin_ID) - do i = 1_pInt, prm%totalNtwin + do i = 1, prm%totalNtwin postResults(c+i) = math_mul33xx33(Mp,prm%Schmid_twin(1:3,1:3,i)) enddo c = c + prm%totalNtwin @@ -573,7 +572,7 @@ subroutine plastic_phenopowerlaw_results(instance,group) integer :: o associate(prm => param(instance), stt => state(instance)) - outputsLoop: do o = 1_pInt,size(prm%outputID) + outputsLoop: do o = 1,size(prm%outputID) select case(prm%outputID(o)) case (resistance_slip_ID) call results_writeVectorDataset(group,stt%xi_slip,'xi_slip','Pa') @@ -605,7 +604,7 @@ pure subroutine kinetics_slip(Mp,instance,of, & implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress - integer(pInt), intent(in) :: & + integer, intent(in) :: & instance, & of @@ -619,14 +618,14 @@ pure subroutine kinetics_slip(Mp,instance,of, & real(pReal), dimension(param(instance)%totalNslip) :: & tau_slip_pos, & tau_slip_neg - integer(pInt) :: i - logical :: nonSchmidActive + integer :: i + logical :: nonSchmidActive associate(prm => param(instance), stt => state(instance)) - nonSchmidActive = size(prm%nonSchmidCoeff) > 0_pInt + nonSchmidActive = size(prm%nonSchmidCoeff) > 0 - do i = 1_pInt, prm%totalNslip + do i = 1, prm%totalNslip tau_slip_pos(i) = math_mul33xx33(Mp,prm%nonSchmid_pos(1:3,1:3,i)) tau_slip_neg(i) = merge(math_mul33xx33(Mp,prm%nonSchmid_neg(1:3,1:3,i)), & 0.0_pReal, nonSchmidActive) @@ -682,7 +681,7 @@ pure subroutine kinetics_twin(Mp,instance,of,& implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress - integer(pInt), intent(in) :: & + integer, intent(in) :: & instance, & of @@ -693,11 +692,11 @@ pure subroutine kinetics_twin(Mp,instance,of,& real(pReal), dimension(param(instance)%totalNtwin) :: & tau_twin - integer(pInt) :: i + integer :: i associate(prm => param(instance), stt => state(instance)) - do i = 1_pInt, prm%totalNtwin + do i = 1, prm%totalNtwin tau_twin(i) = math_mul33xx33(Mp,prm%Schmid_twin(1:3,1:3,i)) enddo From 3700baccccf6b08396858111c1359a7f0b27a572 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 27 Mar 2019 22:42:02 +0100 Subject: [PATCH 14/47] consistent indentation --- src/plastic_isotropic.f90 | 789 +++++++++++++++++++------------------- 1 file changed, 394 insertions(+), 395 deletions(-) diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 index b9250869b..115422774 100644 --- a/src/plastic_isotropic.f90 +++ b/src/plastic_isotropic.f90 @@ -8,53 +8,53 @@ !! untextured polycrystal !-------------------------------------------------------------------------------------------------- module plastic_isotropic - use prec, only: & - pReal, & - pInt - - implicit none - private - integer, dimension(:,:), allocatable, target, public :: & - plastic_isotropic_sizePostResult !< size of each post result output - character(len=64), dimension(:,:), allocatable, target, public :: & - plastic_isotropic_output !< name of each post result output - - enum, bind(c) - enumerator :: & - undefined_ID, & - flowstress_ID, & - strainrate_ID - end enum - - type, private :: tParameters - real(pReal) :: & - fTaylor, & !< Taylor factor - tau0, & !< initial critical stress - gdot0, & !< reference strain rate - n, & !< stress exponent - h0, & - h0_slopeLnRate, & - tausat, & !< maximum critical stress - a, & - tausat_SinhFitA, & - tausat_SinhFitB, & - tausat_SinhFitC, & - tausat_SinhFitD, & - aTolFlowstress, & - aTolShear - integer :: & - of_debug = 0 - integer(kind(undefined_ID)), allocatable, dimension(:) :: & - outputID - logical :: & - dilatation - end type tParameters - - type, private :: tIsotropicState - real(pReal), pointer, dimension(:) :: & - flowstress, & - accumulatedShear - end type tIsotropicState + use prec, only: & + pReal, & + pInt + + implicit none + private + integer, dimension(:,:), allocatable, target, public :: & + plastic_isotropic_sizePostResult !< size of each post result output + character(len=64), dimension(:,:), allocatable, target, public :: & + plastic_isotropic_output !< name of each post result output + + enum, bind(c) + enumerator :: & + undefined_ID, & + flowstress_ID, & + strainrate_ID + end enum + + type, private :: tParameters + real(pReal) :: & + fTaylor, & !< Taylor factor + tau0, & !< initial critical stress + gdot0, & !< reference strain rate + n, & !< stress exponent + h0, & + h0_slopeLnRate, & + tausat, & !< maximum critical stress + a, & + tausat_SinhFitA, & + tausat_SinhFitB, & + tausat_SinhFitC, & + tausat_SinhFitD, & + aTolFlowstress, & + aTolShear + integer :: & + of_debug = 0 + integer(kind(undefined_ID)), allocatable, dimension(:) :: & + outputID + logical :: & + dilatation + end type tParameters + + type, private :: tIsotropicState + real(pReal), pointer, dimension(:) :: & + flowstress, & + accumulatedShear + end type tIsotropicState !-------------------------------------------------------------------------------------------------- ! containers for parameters and state @@ -78,170 +78,169 @@ contains !> @details reads in material parameters, allocates arrays, and does sanity checks !-------------------------------------------------------------------------------------------------- subroutine plastic_isotropic_init - use prec, only: & - pStringLen - use debug, only: & + use prec, only: & + pStringLen + use debug, only: & #ifdef DEBUG - debug_e, & - debug_i, & - debug_g, & - debug_levelExtensive, & + debug_e, & + debug_i, & + debug_g, & + debug_levelExtensive, & #endif - debug_level, & - debug_constitutive, & - debug_levelBasic - use IO, only: & - IO_error - use material, only: & + debug_level, & + debug_constitutive, & + debug_levelBasic + use IO, only: & + IO_error + use material, only: & #ifdef DEBUG - phasememberAt, & + phasememberAt, & #endif - phase_plasticity, & - phase_plasticityInstance, & - phase_Noutput, & - material_allocatePlasticState, & - PLASTICITY_ISOTROPIC_label, & - PLASTICITY_ISOTROPIC_ID, & - material_phase, & - plasticState - use config, only: & - config_phase - use lattice - - implicit none - integer :: & - Ninstance, & - p, i, & - NipcMyPhase, & - sizeState, sizeDotState - - character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] - - integer(kind(undefined_ID)) :: & - outputID - - character(len=pStringLen) :: & - extmsg = '' - character(len=65536), dimension(:), allocatable :: & - outputs - - write(6,'(/,a)') ' <<<+- plastic_'//PLASTICITY_ISOTROPIC_label//' init -+>>>' - - write(6,'(/,a)') ' Maiti and Eisenlohr, Scripta Materialia 145:37–40, 2018' - write(6,'(a)') ' https://doi.org/10.1016/j.scriptamat.2017.09.047' - - Ninstance = count(phase_plasticity == PLASTICITY_ISOTROPIC_ID) - if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0) & - write(6,'(a16,1x,i5,/)') '# instances:',Ninstance - - allocate(plastic_isotropic_sizePostResult(maxval(phase_Noutput),Ninstance),source=0) - allocate(plastic_isotropic_output(maxval(phase_Noutput),Ninstance)) - plastic_isotropic_output = '' - - allocate(param(Ninstance)) - allocate(state(Ninstance)) - allocate(dotState(Ninstance)) - - do p = 1, size(phase_plasticity) - if (phase_plasticity(p) /= PLASTICITY_ISOTROPIC_ID) cycle - associate(prm => param(phase_plasticityInstance(p)), & - dot => dotState(phase_plasticityInstance(p)), & - stt => state(phase_plasticityInstance(p)), & - config => config_phase(p)) - + phase_plasticity, & + phase_plasticityInstance, & + phase_Noutput, & + material_allocatePlasticState, & + PLASTICITY_ISOTROPIC_label, & + PLASTICITY_ISOTROPIC_ID, & + material_phase, & + plasticState + use config, only: & + config_phase + use lattice + + implicit none + integer :: & + Ninstance, & + p, i, & + NipcMyPhase, & + sizeState, sizeDotState + + character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] + + integer(kind(undefined_ID)) :: & + outputID + + character(len=pStringLen) :: & + extmsg = '' + character(len=65536), dimension(:), allocatable :: & + outputs + + write(6,'(/,a)') ' <<<+- plastic_'//PLASTICITY_ISOTROPIC_label//' init -+>>>' + + write(6,'(/,a)') ' Maiti and Eisenlohr, Scripta Materialia 145:37–40, 2018' + write(6,'(a)') ' https://doi.org/10.1016/j.scriptamat.2017.09.047' + + Ninstance = count(phase_plasticity == PLASTICITY_ISOTROPIC_ID) + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0) & + write(6,'(a16,1x,i5,/)') '# instances:',Ninstance + + allocate(plastic_isotropic_sizePostResult(maxval(phase_Noutput),Ninstance),source=0) + allocate(plastic_isotropic_output(maxval(phase_Noutput),Ninstance)) + plastic_isotropic_output = '' + + allocate(param(Ninstance)) + allocate(state(Ninstance)) + allocate(dotState(Ninstance)) + + do p = 1, size(phase_plasticity) + if (phase_plasticity(p) /= PLASTICITY_ISOTROPIC_ID) cycle + associate(prm => param(phase_plasticityInstance(p)), & + dot => dotState(phase_plasticityInstance(p)), & + stt => state(phase_plasticityInstance(p)), & + config => config_phase(p)) + #ifdef DEBUG - if (p==material_phase(debug_g,debug_i,debug_e)) then - prm%of_debug = phasememberAt(debug_g,debug_i,debug_e) - endif + if (p==material_phase(debug_g,debug_i,debug_e)) & + prm%of_debug = phasememberAt(debug_g,debug_i,debug_e) #endif - - prm%tau0 = config%getFloat('tau0') - prm%tausat = config%getFloat('tausat') - prm%gdot0 = config%getFloat('gdot0') - prm%n = config%getFloat('n') - prm%h0 = config%getFloat('h0') - prm%fTaylor = config%getFloat('m') - prm%h0_slopeLnRate = config%getFloat('h0_slopelnrate', defaultVal=0.0_pReal) - prm%tausat_SinhFitA = config%getFloat('tausat_sinhfita',defaultVal=0.0_pReal) - prm%tausat_SinhFitB = config%getFloat('tausat_sinhfitb',defaultVal=0.0_pReal) - prm%tausat_SinhFitC = config%getFloat('tausat_sinhfitc',defaultVal=0.0_pReal) - prm%tausat_SinhFitD = config%getFloat('tausat_sinhfitd',defaultVal=0.0_pReal) - prm%a = config%getFloat('a') - prm%aTolFlowStress = config%getFloat('atol_flowstress',defaultVal=1.0_pReal) - prm%aTolShear = config%getFloat('atol_shear', defaultVal=1.0e-6_pReal) - - prm%dilatation = config%keyExists('/dilatation/') - + + prm%tau0 = config%getFloat('tau0') + prm%tausat = config%getFloat('tausat') + prm%gdot0 = config%getFloat('gdot0') + prm%n = config%getFloat('n') + prm%h0 = config%getFloat('h0') + prm%fTaylor = config%getFloat('m') + prm%h0_slopeLnRate = config%getFloat('h0_slopelnrate', defaultVal=0.0_pReal) + prm%tausat_SinhFitA = config%getFloat('tausat_sinhfita',defaultVal=0.0_pReal) + prm%tausat_SinhFitB = config%getFloat('tausat_sinhfitb',defaultVal=0.0_pReal) + prm%tausat_SinhFitC = config%getFloat('tausat_sinhfitc',defaultVal=0.0_pReal) + prm%tausat_SinhFitD = config%getFloat('tausat_sinhfitd',defaultVal=0.0_pReal) + prm%a = config%getFloat('a') + prm%aTolFlowStress = config%getFloat('atol_flowstress',defaultVal=1.0_pReal) + prm%aTolShear = config%getFloat('atol_shear', defaultVal=1.0e-6_pReal) + + prm%dilatation = config%keyExists('/dilatation/') + !-------------------------------------------------------------------------------------------------- ! sanity checks - extmsg = '' - if (prm%aTolShear <= 0.0_pReal) extmsg = trim(extmsg)//' aTolShear' - if (prm%tau0 < 0.0_pReal) extmsg = trim(extmsg)//' tau0' - if (prm%gdot0 <= 0.0_pReal) extmsg = trim(extmsg)//' gdot0' - if (prm%n <= 0.0_pReal) extmsg = trim(extmsg)//' n' - if (prm%tausat <= prm%tau0) extmsg = trim(extmsg)//' tausat' - if (prm%a <= 0.0_pReal) extmsg = trim(extmsg)//' a' - if (prm%fTaylor <= 0.0_pReal) extmsg = trim(extmsg)//' m' - if (prm%aTolFlowstress <= 0.0_pReal) extmsg = trim(extmsg)//' atol_flowstress' - if (prm%aTolShear <= 0.0_pReal) extmsg = trim(extmsg)//' atol_shear' - + extmsg = '' + if (prm%aTolShear <= 0.0_pReal) extmsg = trim(extmsg)//' aTolShear' + if (prm%tau0 < 0.0_pReal) extmsg = trim(extmsg)//' tau0' + if (prm%gdot0 <= 0.0_pReal) extmsg = trim(extmsg)//' gdot0' + if (prm%n <= 0.0_pReal) extmsg = trim(extmsg)//' n' + if (prm%tausat <= prm%tau0) extmsg = trim(extmsg)//' tausat' + if (prm%a <= 0.0_pReal) extmsg = trim(extmsg)//' a' + if (prm%fTaylor <= 0.0_pReal) extmsg = trim(extmsg)//' m' + if (prm%aTolFlowstress <= 0.0_pReal) extmsg = trim(extmsg)//' atol_flowstress' + if (prm%aTolShear <= 0.0_pReal) extmsg = trim(extmsg)//' atol_shear' + !-------------------------------------------------------------------------------------------------- ! exit if any parameter is out of range - if (extmsg /= '') & - call IO_error(211,ext_msg=trim(extmsg)//'('//PLASTICITY_ISOTROPIC_label//')') - + if (extmsg /= '') & + call IO_error(211,ext_msg=trim(extmsg)//'('//PLASTICITY_ISOTROPIC_label//')') + !-------------------------------------------------------------------------------------------------- ! output pararameters - outputs = config%getStrings('(output)',defaultVal=emptyStringArray) - allocate(prm%outputID(0)) - do i=1, size(outputs) - outputID = undefined_ID - select case(outputs(i)) - - case ('flowstress') - outputID = flowstress_ID - case ('strainrate') - outputID = strainrate_ID - - end select - - if (outputID /= undefined_ID) then - plastic_isotropic_output(i,phase_plasticityInstance(p)) = outputs(i) - plastic_isotropic_sizePostResult(i,phase_plasticityInstance(p)) = 1 - prm%outputID = [prm%outputID, outputID] - endif - - enddo - + outputs = config%getStrings('(output)',defaultVal=emptyStringArray) + allocate(prm%outputID(0)) + do i=1, size(outputs) + outputID = undefined_ID + select case(outputs(i)) + + case ('flowstress') + outputID = flowstress_ID + case ('strainrate') + outputID = strainrate_ID + + end select + + if (outputID /= undefined_ID) then + plastic_isotropic_output(i,phase_plasticityInstance(p)) = outputs(i) + plastic_isotropic_sizePostResult(i,phase_plasticityInstance(p)) = 1 + prm%outputID = [prm%outputID, outputID] + endif + + enddo + !-------------------------------------------------------------------------------------------------- ! allocate state arrays - NipcMyPhase = count(material_phase == p) - sizeDotState = size(['flowstress ','accumulated_shear']) - sizeState = sizeDotState - - call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,0, & - 1,0,0) - plasticState(p)%sizePostResults = sum(plastic_isotropic_sizePostResult(:,phase_plasticityInstance(p))) - + NipcMyPhase = count(material_phase == p) + sizeDotState = size(['flowstress ','accumulated_shear']) + sizeState = sizeDotState + + call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,0, & + 1,0,0) + plasticState(p)%sizePostResults = sum(plastic_isotropic_sizePostResult(:,phase_plasticityInstance(p))) + !-------------------------------------------------------------------------------------------------- ! locally defined state aliases and initialization of state0 and aTolState - stt%flowstress => plasticState(p)%state (1,:) - stt%flowstress = prm%tau0 - dot%flowstress => plasticState(p)%dotState(1,:) - plasticState(p)%aTolState(1) = prm%aTolFlowstress - - stt%accumulatedShear => plasticState(p)%state (2,:) - dot%accumulatedShear => plasticState(p)%dotState(2,:) - plasticState(p)%aTolState(2) = prm%aTolShear - ! global alias - plasticState(p)%slipRate => plasticState(p)%dotState(2:2,:) - plasticState(p)%accumulatedSlip => plasticState(p)%state (2:2,:) - - plasticState(p)%state0 = plasticState(p)%state ! ToDo: this could be done centrally - - end associate - - enddo + stt%flowstress => plasticState(p)%state (1,:) + stt%flowstress = prm%tau0 + dot%flowstress => plasticState(p)%dotState(1,:) + plasticState(p)%aTolState(1) = prm%aTolFlowstress + + stt%accumulatedShear => plasticState(p)%state (2,:) + dot%accumulatedShear => plasticState(p)%dotState(2,:) + plasticState(p)%aTolState(2) = prm%aTolShear + ! global alias + plasticState(p)%slipRate => plasticState(p)%dotState(2:2,:) + plasticState(p)%accumulatedSlip => plasticState(p)%state (2:2,:) + + plasticState(p)%state0 = plasticState(p)%state ! ToDo: this could be done centrally + + end associate + + enddo end subroutine plastic_isotropic_init @@ -251,69 +250,69 @@ end subroutine plastic_isotropic_init !-------------------------------------------------------------------------------------------------- subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) #ifdef DEBUG - use debug, only: & - debug_level, & - debug_constitutive,& - debug_levelExtensive, & - debug_levelSelective + use debug, only: & + debug_level, & + debug_constitutive,& + debug_levelExtensive, & + debug_levelSelective #endif - use math, only: & - math_deviatoric33, & - math_mul33xx33 - - implicit none - real(pReal), dimension(3,3), intent(out) :: & - Lp !< plastic velocity gradient - real(pReal), dimension(3,3,3,3), intent(out) :: & - dLp_dMp !< derivative of Lp with respect to the Mandel stress - - real(pReal), dimension(3,3), intent(in) :: & - Mp !< Mandel stress - integer, intent(in) :: & - instance, & - of - - real(pReal), dimension(3,3) :: & - Mp_dev !< deviatoric part of the Mandel stress - real(pReal) :: & - gamma_dot, & !< 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 - integer :: & - k, l, m, n - - associate(prm => param(instance), stt => state(instance)) - - Mp_dev = math_deviatoric33(Mp) - squarenorm_Mp_dev = math_mul33xx33(Mp_dev,Mp_dev) - norm_Mp_dev = sqrt(squarenorm_Mp_dev) - - if (norm_Mp_dev > 0.0_pReal) then - gamma_dot = prm%gdot0 * (sqrt(1.5_pReal) * norm_Mp_dev/(prm%fTaylor*stt%flowstress(of))) **prm%n - - Lp = Mp_dev/norm_Mp_dev * gamma_dot/prm%fTaylor + use math, only: & + math_deviatoric33, & + math_mul33xx33 + + implicit none + real(pReal), dimension(3,3), intent(out) :: & + Lp !< plastic velocity gradient + real(pReal), dimension(3,3,3,3), intent(out) :: & + dLp_dMp !< derivative of Lp with respect to the Mandel stress + + real(pReal), dimension(3,3), intent(in) :: & + Mp !< Mandel stress + integer, intent(in) :: & + instance, & + of + + real(pReal), dimension(3,3) :: & + Mp_dev !< deviatoric part of the Mandel stress + real(pReal) :: & + gamma_dot, & !< 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 + integer :: & + k, l, m, n + + associate(prm => param(instance), stt => state(instance)) + + Mp_dev = math_deviatoric33(Mp) + squarenorm_Mp_dev = math_mul33xx33(Mp_dev,Mp_dev) + norm_Mp_dev = sqrt(squarenorm_Mp_dev) + + if (norm_Mp_dev > 0.0_pReal) then + gamma_dot = prm%gdot0 * (sqrt(1.5_pReal) * norm_Mp_dev/(prm%fTaylor*stt%flowstress(of))) **prm%n + + Lp = Mp_dev/norm_Mp_dev * gamma_dot/prm%fTaylor #ifdef DEBUG - if (iand(debug_level(debug_constitutive), debug_levelExtensive) /= 0 & - .and. (of == prm%of_debug .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0)) then - write(6,'(/,a,/,3(12x,3(f12.4,1x)/))') '<< CONST isotropic >> Tstar (dev) / MPa', & - transpose(Mp_dev)*1.0e-6_pReal - write(6,'(/,a,/,f12.5)') '<< CONST isotropic >> norm Tstar / MPa', norm_Mp_dev*1.0e-6_pReal - write(6,'(/,a,/,f12.5)') '<< CONST isotropic >> gdot', gamma_dot - end if + if (iand(debug_level(debug_constitutive), debug_levelExtensive) /= 0 & + .and. (of == prm%of_debug .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0)) then + write(6,'(/,a,/,3(12x,3(f12.4,1x)/))') '<< CONST isotropic >> Tstar (dev) / MPa', & + transpose(Mp_dev)*1.0e-6_pReal + write(6,'(/,a,/,f12.5)') '<< CONST isotropic >> norm Tstar / MPa', norm_Mp_dev*1.0e-6_pReal + write(6,'(/,a,/,f12.5)') '<< CONST isotropic >> gdot', gamma_dot + end if #endif - forall (k=1:3,l=1:3,m=1:3,n=1:3) & - dLp_dMp(k,l,m,n) = (prm%n-1.0_pReal) * Mp_dev(k,l)*Mp_dev(m,n) / squarenorm_Mp_dev - forall (k=1:3,l=1:3) & - dLp_dMp(k,l,k,l) = dLp_dMp(k,l,k,l) + 1.0_pReal - forall (k=1:3,m=1:3) & - dLp_dMp(k,k,m,m) = dLp_dMp(k,k,m,m) - 1.0_pReal/3.0_pReal - dLp_dMp = gamma_dot / prm%fTaylor * dLp_dMp / norm_Mp_dev - else - Lp = 0.0_pReal - dLp_dMp = 0.0_pReal - end if - - end associate + forall (k=1:3,l=1:3,m=1:3,n=1:3) & + dLp_dMp(k,l,m,n) = (prm%n-1.0_pReal) * Mp_dev(k,l)*Mp_dev(m,n) / squarenorm_Mp_dev + forall (k=1:3,l=1:3) & + dLp_dMp(k,l,k,l) = dLp_dMp(k,l,k,l) + 1.0_pReal + forall (k=1:3,m=1:3) & + dLp_dMp(k,k,m,m) = dLp_dMp(k,k,m,m) - 1.0_pReal/3.0_pReal + dLp_dMp = gamma_dot / prm%fTaylor * dLp_dMp / norm_Mp_dev + else + Lp = 0.0_pReal + dLp_dMp = 0.0_pReal + end if + + end associate end subroutine plastic_isotropic_LpAndItsTangent @@ -323,53 +322,53 @@ end subroutine plastic_isotropic_LpAndItsTangent ! ToDo: Rename Tstar to Mi? !-------------------------------------------------------------------------------------------------- subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar,Tstar,instance,of) - use math, only: & - math_spherical33, & - math_mul33xx33 - - implicit none - real(pReal), dimension(3,3), intent(out) :: & - Li !< inleastic velocity gradient - real(pReal), dimension(3,3,3,3), intent(out) :: & - dLi_dTstar !< derivative of Li with respect to the Mandel stress - - real(pReal), dimension(3,3), intent(in) :: & - Tstar !< Mandel stress ToDo: Mi? - integer, intent(in) :: & - instance, & - of - - real(pReal), dimension(3,3) :: & - Tstar_sph !< sphiatoric part of the Mandel stress - real(pReal) :: & - gamma_dot, & !< strainrate - norm_Tstar_sph, & !< euclidean norm of Tstar_sph - squarenorm_Tstar_sph !< square of the euclidean norm of Tstar_sph - integer :: & - k, l, m, n - - associate(prm => param(instance), stt => state(instance)) - - Tstar_sph = math_spherical33(Tstar) - squarenorm_Tstar_sph = math_mul33xx33(Tstar_sph,Tstar_sph) - norm_Tstar_sph = sqrt(squarenorm_Tstar_sph) - - if (prm%dilatation .and. norm_Tstar_sph > 0.0_pReal) then ! no stress or J2 plastitiy --> Li and its derivative are zero - gamma_dot = prm%gdot0 * (sqrt(1.5_pReal) * norm_Tstar_sph /(prm%fTaylor*stt%flowstress(of))) **prm%n - - Li = Tstar_sph/norm_Tstar_sph * gamma_dot/prm%fTaylor - forall (k=1:3,l=1:3,m=1:3,n=1:3) & - dLi_dTstar(k,l,m,n) = (prm%n-1.0_pReal) * Tstar_sph(k,l)*Tstar_sph(m,n) / squarenorm_Tstar_sph - forall (k=1:3,l=1:3) & - dLi_dTstar(k,l,k,l) = dLi_dTstar(k,l,k,l) + 1.0_pReal - - dLi_dTstar = gamma_dot / prm%fTaylor * dLi_dTstar / norm_Tstar_sph - else - Li = 0.0_pReal - dLi_dTstar = 0.0_pReal - endif - - end associate + use math, only: & + math_spherical33, & + math_mul33xx33 + + implicit none + real(pReal), dimension(3,3), intent(out) :: & + Li !< inleastic velocity gradient + real(pReal), dimension(3,3,3,3), intent(out) :: & + dLi_dTstar !< derivative of Li with respect to the Mandel stress + + real(pReal), dimension(3,3), intent(in) :: & + Tstar !< Mandel stress ToDo: Mi? + integer, intent(in) :: & + instance, & + of + + real(pReal), dimension(3,3) :: & + Tstar_sph !< sphiatoric part of the Mandel stress + real(pReal) :: & + gamma_dot, & !< strainrate + norm_Tstar_sph, & !< euclidean norm of Tstar_sph + squarenorm_Tstar_sph !< square of the euclidean norm of Tstar_sph + integer :: & + k, l, m, n + + associate(prm => param(instance), stt => state(instance)) + + Tstar_sph = math_spherical33(Tstar) + squarenorm_Tstar_sph = math_mul33xx33(Tstar_sph,Tstar_sph) + norm_Tstar_sph = sqrt(squarenorm_Tstar_sph) + + if (prm%dilatation .and. norm_Tstar_sph > 0.0_pReal) then ! no stress or J2 plastitiy --> Li and its derivative are zero + gamma_dot = prm%gdot0 * (sqrt(1.5_pReal) * norm_Tstar_sph /(prm%fTaylor*stt%flowstress(of))) **prm%n + + Li = Tstar_sph/norm_Tstar_sph * gamma_dot/prm%fTaylor + forall (k=1:3,l=1:3,m=1:3,n=1:3) & + dLi_dTstar(k,l,m,n) = (prm%n-1.0_pReal) * Tstar_sph(k,l)*Tstar_sph(m,n) / squarenorm_Tstar_sph + forall (k=1:3,l=1:3) & + dLi_dTstar(k,l,k,l) = dLi_dTstar(k,l,k,l) + 1.0_pReal + + dLi_dTstar = gamma_dot / prm%fTaylor * dLi_dTstar / norm_Tstar_sph + else + Li = 0.0_pReal + dLi_dTstar = 0.0_pReal + endif + + end associate end subroutine plastic_isotropic_LiAndItsTangent @@ -378,55 +377,55 @@ subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar,Tstar,instance,of) !> @brief calculates the rate of change of microstructure !-------------------------------------------------------------------------------------------------- subroutine plastic_isotropic_dotState(Mp,instance,of) - use prec, only: & - dEq0 - use math, only: & - math_mul33xx33, & - math_deviatoric33 - - implicit none - real(pReal), dimension(3,3), intent(in) :: & - Mp !< Mandel stress - integer, intent(in) :: & - instance, & - of - - real(pReal) :: & - gamma_dot, & !< strainrate - hardening, & !< hardening coefficient - saturation, & !< saturation flowstress - norm_Mp !< norm of the (deviatoric) Mandel stress - - associate(prm => param(instance), stt => state(instance), dot => dotState(instance)) - - if (prm%dilatation) then - norm_Mp = sqrt(math_mul33xx33(Mp,Mp)) - else - norm_Mp = sqrt(math_mul33xx33(math_deviatoric33(Mp),math_deviatoric33(Mp))) - endif - - gamma_dot = prm%gdot0 * (sqrt(1.5_pReal) * norm_Mp /(prm%fTaylor*stt%flowstress(of))) **prm%n - - if (abs(gamma_dot) > 1e-12_pReal) then - if (dEq0(prm%tausat_SinhFitA)) then - saturation = prm%tausat - else - saturation = prm%tausat & - + asinh( (gamma_dot / prm%tausat_SinhFitA)**(1.0_pReal / prm%tausat_SinhFitD) & - )**(1.0_pReal / prm%tausat_SinhFitC) & - / prm%tausat_SinhFitB * (gamma_dot / prm%gdot0)**(1.0_pReal / prm%n) - endif - hardening = ( prm%h0 + prm%h0_slopeLnRate * log(gamma_dot) ) & - * abs( 1.0_pReal - stt%flowstress(of)/saturation )**prm%a & - * sign(1.0_pReal, 1.0_pReal - stt%flowstress(of)/saturation) - else - hardening = 0.0_pReal - endif - - dot%flowstress (of) = hardening * gamma_dot - dot%accumulatedShear(of) = gamma_dot - - end associate + use prec, only: & + dEq0 + use math, only: & + math_mul33xx33, & + math_deviatoric33 + + implicit none + real(pReal), dimension(3,3), intent(in) :: & + Mp !< Mandel stress + integer, intent(in) :: & + instance, & + of + + real(pReal) :: & + gamma_dot, & !< strainrate + hardening, & !< hardening coefficient + saturation, & !< saturation flowstress + norm_Mp !< norm of the (deviatoric) Mandel stress + + associate(prm => param(instance), stt => state(instance), dot => dotState(instance)) + + if (prm%dilatation) then + norm_Mp = sqrt(math_mul33xx33(Mp,Mp)) + else + norm_Mp = sqrt(math_mul33xx33(math_deviatoric33(Mp),math_deviatoric33(Mp))) + endif + + gamma_dot = prm%gdot0 * (sqrt(1.5_pReal) * norm_Mp /(prm%fTaylor*stt%flowstress(of))) **prm%n + + if (abs(gamma_dot) > 1e-12_pReal) then + if (dEq0(prm%tausat_SinhFitA)) then + saturation = prm%tausat + else + saturation = prm%tausat & + + asinh( (gamma_dot / prm%tausat_SinhFitA)**(1.0_pReal / prm%tausat_SinhFitD) & + )**(1.0_pReal / prm%tausat_SinhFitC) & + / prm%tausat_SinhFitB * (gamma_dot / prm%gdot0)**(1.0_pReal / prm%n) + endif + hardening = ( prm%h0 + prm%h0_slopeLnRate * log(gamma_dot) ) & + * abs( 1.0_pReal - stt%flowstress(of)/saturation )**prm%a & + * sign(1.0_pReal, 1.0_pReal - stt%flowstress(of)/saturation) + else + hardening = 0.0_pReal + endif + + dot%flowstress (of) = hardening * gamma_dot + dot%accumulatedShear(of) = gamma_dot + + end associate end subroutine plastic_isotropic_dotState @@ -435,50 +434,50 @@ end subroutine plastic_isotropic_dotState !> @brief return array of constitutive results !-------------------------------------------------------------------------------------------------- function plastic_isotropic_postResults(Mp,instance,of) result(postResults) - use math, only: & - math_mul33xx33, & - math_deviatoric33 - - implicit none - real(pReal), dimension(3,3), intent(in) :: & - Mp !< Mandel stress - integer, intent(in) :: & - instance, & - of - - real(pReal), dimension(sum(plastic_isotropic_sizePostResult(:,instance))) :: & - postResults - - real(pReal) :: & - norm_Mp !< norm of the Mandel stress - integer :: & - o,c - - associate(prm => param(instance), stt => state(instance)) - - if (prm%dilatation) then - norm_Mp = sqrt(math_mul33xx33(Mp,Mp)) - else - norm_Mp = sqrt(math_mul33xx33(math_deviatoric33(Mp),math_deviatoric33(Mp))) - endif - - c = 0 - - outputsLoop: do o = 1,size(prm%outputID) - select case(prm%outputID(o)) - - case (flowstress_ID) - postResults(c+1) = stt%flowstress(of) - c = c + 1 - case (strainrate_ID) - postResults(c+1) = prm%gdot0 & - * (sqrt(1.5_pReal) * norm_Mp /(prm%fTaylor * stt%flowstress(of)))**prm%n - c = c + 1 - - end select - enddo outputsLoop - - end associate + use math, only: & + math_mul33xx33, & + math_deviatoric33 + + implicit none + real(pReal), dimension(3,3), intent(in) :: & + Mp !< Mandel stress + integer, intent(in) :: & + instance, & + of + + real(pReal), dimension(sum(plastic_isotropic_sizePostResult(:,instance))) :: & + postResults + + real(pReal) :: & + norm_Mp !< norm of the Mandel stress + integer :: & + o,c + + associate(prm => param(instance), stt => state(instance)) + + if (prm%dilatation) then + norm_Mp = sqrt(math_mul33xx33(Mp,Mp)) + else + norm_Mp = sqrt(math_mul33xx33(math_deviatoric33(Mp),math_deviatoric33(Mp))) + endif + + c = 0 + + outputsLoop: do o = 1,size(prm%outputID) + select case(prm%outputID(o)) + + case (flowstress_ID) + postResults(c+1) = stt%flowstress(of) + c = c + 1 + case (strainrate_ID) + postResults(c+1) = prm%gdot0 & + * (sqrt(1.5_pReal) * norm_Mp /(prm%fTaylor * stt%flowstress(of)))**prm%n + c = c + 1 + + end select + enddo outputsLoop + + end associate end function plastic_isotropic_postResults From daab9263d395384a82312002d47cd05eb0b8d852 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 27 Mar 2019 23:09:45 +0100 Subject: [PATCH 15/47] using names from DAMASK paper --- src/plastic_isotropic.f90 | 97 +++++++++++++++++++-------------------- 1 file changed, 48 insertions(+), 49 deletions(-) diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 index 115422774..5493fa60b 100644 --- a/src/plastic_isotropic.f90 +++ b/src/plastic_isotropic.f90 @@ -22,25 +22,25 @@ module plastic_isotropic enum, bind(c) enumerator :: & undefined_ID, & - flowstress_ID, & + xi_ID, & strainrate_ID end enum type, private :: tParameters real(pReal) :: & - fTaylor, & !< Taylor factor - tau0, & !< initial critical stress + M, & !< Taylor factor + xi_0, & !< initial critical stress gdot0, & !< reference strain rate n, & !< stress exponent h0, & h0_slopeLnRate, & - tausat, & !< maximum critical stress + xi_inf, & !< maximum critical stress a, & - tausat_SinhFitA, & - tausat_SinhFitB, & - tausat_SinhFitC, & - tausat_SinhFitD, & - aTolFlowstress, & + c_1, & + c_4, & + c_3, & + c_2, & + aTol_xi, & aTolShear integer :: & of_debug = 0 @@ -52,7 +52,7 @@ module plastic_isotropic type, private :: tIsotropicState real(pReal), pointer, dimension(:) :: & - flowstress, & + xi, & accumulatedShear end type tIsotropicState @@ -154,19 +154,19 @@ subroutine plastic_isotropic_init prm%of_debug = phasememberAt(debug_g,debug_i,debug_e) #endif - prm%tau0 = config%getFloat('tau0') - prm%tausat = config%getFloat('tausat') + prm%xi_0 = config%getFloat('tau0') + prm%xi_inf = config%getFloat('tausat') prm%gdot0 = config%getFloat('gdot0') prm%n = config%getFloat('n') prm%h0 = config%getFloat('h0') - prm%fTaylor = config%getFloat('m') + prm%M = config%getFloat('m') prm%h0_slopeLnRate = config%getFloat('h0_slopelnrate', defaultVal=0.0_pReal) - prm%tausat_SinhFitA = config%getFloat('tausat_sinhfita',defaultVal=0.0_pReal) - prm%tausat_SinhFitB = config%getFloat('tausat_sinhfitb',defaultVal=0.0_pReal) - prm%tausat_SinhFitC = config%getFloat('tausat_sinhfitc',defaultVal=0.0_pReal) - prm%tausat_SinhFitD = config%getFloat('tausat_sinhfitd',defaultVal=0.0_pReal) + prm%c_1 = config%getFloat('tausat_sinhfita',defaultVal=0.0_pReal) + prm%c_4 = config%getFloat('tausat_sinhfitb',defaultVal=0.0_pReal) + prm%c_3 = config%getFloat('tausat_sinhfitc',defaultVal=0.0_pReal) + prm%c_2 = config%getFloat('tausat_sinhfitd',defaultVal=0.0_pReal) prm%a = config%getFloat('a') - prm%aTolFlowStress = config%getFloat('atol_flowstress',defaultVal=1.0_pReal) + prm%aTol_xi = config%getFloat('atol_flowstress',defaultVal=1.0_pReal) prm%aTolShear = config%getFloat('atol_shear', defaultVal=1.0e-6_pReal) prm%dilatation = config%keyExists('/dilatation/') @@ -175,13 +175,12 @@ subroutine plastic_isotropic_init ! sanity checks extmsg = '' if (prm%aTolShear <= 0.0_pReal) extmsg = trim(extmsg)//' aTolShear' - if (prm%tau0 < 0.0_pReal) extmsg = trim(extmsg)//' tau0' + if (prm%xi_0 < 0.0_pReal) extmsg = trim(extmsg)//' xi_0' if (prm%gdot0 <= 0.0_pReal) extmsg = trim(extmsg)//' gdot0' if (prm%n <= 0.0_pReal) extmsg = trim(extmsg)//' n' - if (prm%tausat <= prm%tau0) extmsg = trim(extmsg)//' tausat' if (prm%a <= 0.0_pReal) extmsg = trim(extmsg)//' a' - if (prm%fTaylor <= 0.0_pReal) extmsg = trim(extmsg)//' m' - if (prm%aTolFlowstress <= 0.0_pReal) extmsg = trim(extmsg)//' atol_flowstress' + if (prm%M <= 0.0_pReal) extmsg = trim(extmsg)//' m' + if (prm%aTol_xi <= 0.0_pReal) extmsg = trim(extmsg)//' atol_xi' if (prm%aTolShear <= 0.0_pReal) extmsg = trim(extmsg)//' atol_shear' !-------------------------------------------------------------------------------------------------- @@ -197,8 +196,8 @@ subroutine plastic_isotropic_init outputID = undefined_ID select case(outputs(i)) - case ('flowstress') - outputID = flowstress_ID + case ('xi') + outputID = xi_ID case ('strainrate') outputID = strainrate_ID @@ -215,7 +214,7 @@ subroutine plastic_isotropic_init !-------------------------------------------------------------------------------------------------- ! allocate state arrays NipcMyPhase = count(material_phase == p) - sizeDotState = size(['flowstress ','accumulated_shear']) + sizeDotState = size(['xi ','accumulated_shear']) sizeState = sizeDotState call material_allocatePlasticState(p,NipcMyPhase,sizeState,sizeDotState,0, & @@ -224,10 +223,10 @@ subroutine plastic_isotropic_init !-------------------------------------------------------------------------------------------------- ! locally defined state aliases and initialization of state0 and aTolState - stt%flowstress => plasticState(p)%state (1,:) - stt%flowstress = prm%tau0 - dot%flowstress => plasticState(p)%dotState(1,:) - plasticState(p)%aTolState(1) = prm%aTolFlowstress + stt%xi => plasticState(p)%state (1,:) + stt%xi = prm%xi_0 + dot%xi => plasticState(p)%dotState(1,:) + plasticState(p)%aTolState(1) = prm%aTol_xi stt%accumulatedShear => plasticState(p)%state (2,:) dot%accumulatedShear => plasticState(p)%dotState(2,:) @@ -288,9 +287,9 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) norm_Mp_dev = sqrt(squarenorm_Mp_dev) if (norm_Mp_dev > 0.0_pReal) then - gamma_dot = prm%gdot0 * (sqrt(1.5_pReal) * norm_Mp_dev/(prm%fTaylor*stt%flowstress(of))) **prm%n + gamma_dot = prm%gdot0 * (sqrt(1.5_pReal) * norm_Mp_dev/(prm%M*stt%xi(of))) **prm%n - Lp = Mp_dev/norm_Mp_dev * gamma_dot/prm%fTaylor + Lp = Mp_dev/norm_Mp_dev * gamma_dot/prm%M #ifdef DEBUG if (iand(debug_level(debug_constitutive), debug_levelExtensive) /= 0 & .and. (of == prm%of_debug .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0)) then @@ -306,7 +305,7 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) 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 = gamma_dot / prm%fTaylor * dLp_dMp / norm_Mp_dev + dLp_dMp = gamma_dot / prm%M * dLp_dMp / norm_Mp_dev else Lp = 0.0_pReal dLp_dMp = 0.0_pReal @@ -354,15 +353,15 @@ subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar,Tstar,instance,of) norm_Tstar_sph = sqrt(squarenorm_Tstar_sph) if (prm%dilatation .and. norm_Tstar_sph > 0.0_pReal) then ! no stress or J2 plastitiy --> Li and its derivative are zero - gamma_dot = prm%gdot0 * (sqrt(1.5_pReal) * norm_Tstar_sph /(prm%fTaylor*stt%flowstress(of))) **prm%n + gamma_dot = prm%gdot0 * (sqrt(1.5_pReal) * norm_Tstar_sph /(prm%M*stt%xi(of))) **prm%n - Li = Tstar_sph/norm_Tstar_sph * gamma_dot/prm%fTaylor + Li = Tstar_sph/norm_Tstar_sph * gamma_dot/prm%M forall (k=1:3,l=1:3,m=1:3,n=1:3) & dLi_dTstar(k,l,m,n) = (prm%n-1.0_pReal) * Tstar_sph(k,l)*Tstar_sph(m,n) / squarenorm_Tstar_sph forall (k=1:3,l=1:3) & dLi_dTstar(k,l,k,l) = dLi_dTstar(k,l,k,l) + 1.0_pReal - dLi_dTstar = gamma_dot / prm%fTaylor * dLi_dTstar / norm_Tstar_sph + dLi_dTstar = gamma_dot / prm%M * dLi_dTstar / norm_Tstar_sph else Li = 0.0_pReal dLi_dTstar = 0.0_pReal @@ -393,7 +392,7 @@ subroutine plastic_isotropic_dotState(Mp,instance,of) real(pReal) :: & gamma_dot, & !< strainrate hardening, & !< hardening coefficient - saturation, & !< saturation flowstress + xi_inf_star, & !< saturation xi norm_Mp !< norm of the (deviatoric) Mandel stress associate(prm => param(instance), stt => state(instance), dot => dotState(instance)) @@ -404,25 +403,25 @@ subroutine plastic_isotropic_dotState(Mp,instance,of) norm_Mp = sqrt(math_mul33xx33(math_deviatoric33(Mp),math_deviatoric33(Mp))) endif - gamma_dot = prm%gdot0 * (sqrt(1.5_pReal) * norm_Mp /(prm%fTaylor*stt%flowstress(of))) **prm%n + gamma_dot = prm%gdot0 * (sqrt(1.5_pReal) * norm_Mp /(prm%M*stt%xi(of))) **prm%n if (abs(gamma_dot) > 1e-12_pReal) then - if (dEq0(prm%tausat_SinhFitA)) then - saturation = prm%tausat + if (dEq0(prm%c_1)) then + xi_inf_star = prm%xi_inf else - saturation = prm%tausat & - + asinh( (gamma_dot / prm%tausat_SinhFitA)**(1.0_pReal / prm%tausat_SinhFitD) & - )**(1.0_pReal / prm%tausat_SinhFitC) & - / prm%tausat_SinhFitB * (gamma_dot / prm%gdot0)**(1.0_pReal / prm%n) + xi_inf_star = prm%xi_inf & + + asinh( (gamma_dot / prm%c_1)**(1.0_pReal / prm%c_2) & + )**(1.0_pReal / prm%c_3) & + / prm%c_4 * (gamma_dot / prm%gdot0)**(1.0_pReal / prm%n) endif hardening = ( prm%h0 + prm%h0_slopeLnRate * log(gamma_dot) ) & - * abs( 1.0_pReal - stt%flowstress(of)/saturation )**prm%a & - * sign(1.0_pReal, 1.0_pReal - stt%flowstress(of)/saturation) + * abs( 1.0_pReal - stt%xi(of)/xi_inf_star )**prm%a & + * sign(1.0_pReal, 1.0_pReal - stt%xi(of)/xi_inf_star) else hardening = 0.0_pReal endif - dot%flowstress (of) = hardening * gamma_dot + dot%xi (of) = hardening * gamma_dot dot%accumulatedShear(of) = gamma_dot end associate @@ -466,12 +465,12 @@ function plastic_isotropic_postResults(Mp,instance,of) result(postResults) outputsLoop: do o = 1,size(prm%outputID) select case(prm%outputID(o)) - case (flowstress_ID) - postResults(c+1) = stt%flowstress(of) + case (xi_ID) + postResults(c+1) = stt%xi(of) c = c + 1 case (strainrate_ID) postResults(c+1) = prm%gdot0 & - * (sqrt(1.5_pReal) * norm_Mp /(prm%fTaylor * stt%flowstress(of)))**prm%n + * (sqrt(1.5_pReal) * norm_Mp /(prm%M * stt%xi(of)))**prm%n c = c + 1 end select From 6996eb36c01d924f4f974caffd013ec123792870 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 28 Mar 2019 06:39:07 +0100 Subject: [PATCH 16/47] more renames --- src/plastic_isotropic.f90 | 76 +++++++++++++++++++-------------------- 1 file changed, 37 insertions(+), 39 deletions(-) diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 index 5493fa60b..71747929c 100644 --- a/src/plastic_isotropic.f90 +++ b/src/plastic_isotropic.f90 @@ -23,17 +23,17 @@ module plastic_isotropic enumerator :: & undefined_ID, & xi_ID, & - strainrate_ID + dot_gamma_ID end enum type, private :: tParameters real(pReal) :: & M, & !< Taylor factor xi_0, & !< initial critical stress - gdot0, & !< reference strain rate + dot_gamma_0, & !< reference strain rate n, & !< stress exponent h0, & - h0_slopeLnRate, & + h_ln, & xi_inf, & !< maximum critical stress a, & c_1, & @@ -41,7 +41,7 @@ module plastic_isotropic c_3, & c_2, & aTol_xi, & - aTolShear + aTol_gamma integer :: & of_debug = 0 integer(kind(undefined_ID)), allocatable, dimension(:) :: & @@ -53,7 +53,7 @@ module plastic_isotropic type, private :: tIsotropicState real(pReal), pointer, dimension(:) :: & xi, & - accumulatedShear + gamma end type tIsotropicState !-------------------------------------------------------------------------------------------------- @@ -156,32 +156,32 @@ subroutine plastic_isotropic_init prm%xi_0 = config%getFloat('tau0') prm%xi_inf = config%getFloat('tausat') - prm%gdot0 = config%getFloat('gdot0') + prm%dot_gamma_0 = config%getFloat('gdot0') prm%n = config%getFloat('n') prm%h0 = config%getFloat('h0') prm%M = config%getFloat('m') - prm%h0_slopeLnRate = config%getFloat('h0_slopelnrate', defaultVal=0.0_pReal) + prm%h_ln = config%getFloat('h0_slopelnrate', defaultVal=0.0_pReal) prm%c_1 = config%getFloat('tausat_sinhfita',defaultVal=0.0_pReal) prm%c_4 = config%getFloat('tausat_sinhfitb',defaultVal=0.0_pReal) prm%c_3 = config%getFloat('tausat_sinhfitc',defaultVal=0.0_pReal) prm%c_2 = config%getFloat('tausat_sinhfitd',defaultVal=0.0_pReal) prm%a = config%getFloat('a') prm%aTol_xi = config%getFloat('atol_flowstress',defaultVal=1.0_pReal) - prm%aTolShear = config%getFloat('atol_shear', defaultVal=1.0e-6_pReal) + prm%aTol_gamma = config%getFloat('atol_shear', defaultVal=1.0e-6_pReal) prm%dilatation = config%keyExists('/dilatation/') !-------------------------------------------------------------------------------------------------- ! sanity checks extmsg = '' - if (prm%aTolShear <= 0.0_pReal) extmsg = trim(extmsg)//' aTolShear' - if (prm%xi_0 < 0.0_pReal) extmsg = trim(extmsg)//' xi_0' - if (prm%gdot0 <= 0.0_pReal) extmsg = trim(extmsg)//' gdot0' + if (prm%aTol_gamma <= 0.0_pReal) extmsg = trim(extmsg)//' aTol_gamma' + if (prm%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 (prm%aTol_xi <= 0.0_pReal) extmsg = trim(extmsg)//' atol_xi' - if (prm%aTolShear <= 0.0_pReal) extmsg = trim(extmsg)//' atol_shear' + if (prm%aTol_gamma <= 0.0_pReal) extmsg = trim(extmsg)//' atol_shear' !-------------------------------------------------------------------------------------------------- ! exit if any parameter is out of range @@ -199,7 +199,7 @@ subroutine plastic_isotropic_init case ('xi') outputID = xi_ID case ('strainrate') - outputID = strainrate_ID + outputID = dot_gamma_ID end select @@ -228,9 +228,9 @@ subroutine plastic_isotropic_init dot%xi => plasticState(p)%dotState(1,:) plasticState(p)%aTolState(1) = prm%aTol_xi - stt%accumulatedShear => plasticState(p)%state (2,:) - dot%accumulatedShear => plasticState(p)%dotState(2,:) - plasticState(p)%aTolState(2) = prm%aTolShear + stt%gamma => plasticState(p)%state (2,:) + dot%gamma => plasticState(p)%dotState(2,:) + plasticState(p)%aTolState(2) = prm%aTol_gamma ! global alias plasticState(p)%slipRate => plasticState(p)%dotState(2:2,:) plasticState(p)%accumulatedSlip => plasticState(p)%state (2:2,:) @@ -274,7 +274,7 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) real(pReal), dimension(3,3) :: & Mp_dev !< deviatoric part of the Mandel stress real(pReal) :: & - gamma_dot, & !< strainrate + 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 integer :: & @@ -287,16 +287,16 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) norm_Mp_dev = sqrt(squarenorm_Mp_dev) if (norm_Mp_dev > 0.0_pReal) then - gamma_dot = prm%gdot0 * (sqrt(1.5_pReal) * norm_Mp_dev/(prm%M*stt%xi(of))) **prm%n + dot_gamma = prm%dot_gamma_0 * (sqrt(1.5_pReal) * norm_Mp_dev/(prm%M*stt%xi(of))) **prm%n - Lp = Mp_dev/norm_Mp_dev * gamma_dot/prm%M + Lp = Mp_dev/norm_Mp_dev * dot_gamma/prm%M #ifdef DEBUG if (iand(debug_level(debug_constitutive), debug_levelExtensive) /= 0 & .and. (of == prm%of_debug .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0)) then write(6,'(/,a,/,3(12x,3(f12.4,1x)/))') '<< CONST isotropic >> Tstar (dev) / MPa', & transpose(Mp_dev)*1.0e-6_pReal write(6,'(/,a,/,f12.5)') '<< CONST isotropic >> norm Tstar / MPa', norm_Mp_dev*1.0e-6_pReal - write(6,'(/,a,/,f12.5)') '<< CONST isotropic >> gdot', gamma_dot + write(6,'(/,a,/,f12.5)') '<< CONST isotropic >> gdot', dot_gamma end if #endif forall (k=1:3,l=1:3,m=1:3,n=1:3) & @@ -305,7 +305,7 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) 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 = gamma_dot / prm%M * dLp_dMp / norm_Mp_dev + dLp_dMp = dot_gamma / prm%M * dLp_dMp / norm_Mp_dev else Lp = 0.0_pReal dLp_dMp = 0.0_pReal @@ -340,7 +340,7 @@ subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar,Tstar,instance,of) real(pReal), dimension(3,3) :: & Tstar_sph !< sphiatoric part of the Mandel stress real(pReal) :: & - gamma_dot, & !< strainrate + dot_gamma, & !< strainrate norm_Tstar_sph, & !< euclidean norm of Tstar_sph squarenorm_Tstar_sph !< square of the euclidean norm of Tstar_sph integer :: & @@ -353,15 +353,15 @@ subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar,Tstar,instance,of) norm_Tstar_sph = sqrt(squarenorm_Tstar_sph) if (prm%dilatation .and. norm_Tstar_sph > 0.0_pReal) then ! no stress or J2 plastitiy --> Li and its derivative are zero - gamma_dot = prm%gdot0 * (sqrt(1.5_pReal) * norm_Tstar_sph /(prm%M*stt%xi(of))) **prm%n + dot_gamma = prm%dot_gamma_0 * (sqrt(1.5_pReal) * norm_Tstar_sph /(prm%M*stt%xi(of))) **prm%n - Li = Tstar_sph/norm_Tstar_sph * gamma_dot/prm%M + Li = Tstar_sph/norm_Tstar_sph * dot_gamma/prm%M forall (k=1:3,l=1:3,m=1:3,n=1:3) & dLi_dTstar(k,l,m,n) = (prm%n-1.0_pReal) * Tstar_sph(k,l)*Tstar_sph(m,n) / squarenorm_Tstar_sph forall (k=1:3,l=1:3) & dLi_dTstar(k,l,k,l) = dLi_dTstar(k,l,k,l) + 1.0_pReal - dLi_dTstar = gamma_dot / prm%M * dLi_dTstar / norm_Tstar_sph + dLi_dTstar = dot_gamma / prm%M * dLi_dTstar / norm_Tstar_sph else Li = 0.0_pReal dLi_dTstar = 0.0_pReal @@ -390,8 +390,7 @@ subroutine plastic_isotropic_dotState(Mp,instance,of) of real(pReal) :: & - gamma_dot, & !< strainrate - hardening, & !< hardening coefficient + dot_gamma, & !< strainrate xi_inf_star, & !< saturation xi norm_Mp !< norm of the (deviatoric) Mandel stress @@ -403,26 +402,25 @@ subroutine plastic_isotropic_dotState(Mp,instance,of) norm_Mp = sqrt(math_mul33xx33(math_deviatoric33(Mp),math_deviatoric33(Mp))) endif - gamma_dot = prm%gdot0 * (sqrt(1.5_pReal) * norm_Mp /(prm%M*stt%xi(of))) **prm%n + dot_gamma = prm%dot_gamma_0 * (sqrt(1.5_pReal) * norm_Mp /(prm%M*stt%xi(of))) **prm%n - if (abs(gamma_dot) > 1e-12_pReal) then + if (abs(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( (gamma_dot / prm%c_1)**(1.0_pReal / prm%c_2) & + + asinh( (dot_gamma / prm%c_1)**(1.0_pReal / prm%c_2) & )**(1.0_pReal / prm%c_3) & - / prm%c_4 * (gamma_dot / prm%gdot0)**(1.0_pReal / prm%n) + / prm%c_4 * (dot_gamma / prm%dot_gamma_0)**(1.0_pReal / prm%n) endif - hardening = ( prm%h0 + prm%h0_slopeLnRate * log(gamma_dot) ) & - * abs( 1.0_pReal - stt%xi(of)/xi_inf_star )**prm%a & - * sign(1.0_pReal, 1.0_pReal - stt%xi(of)/xi_inf_star) + dot%xi(of) = ( prm%h0 + prm%h_ln * log(dot_gamma) ) & + * abs( 1.0_pReal - stt%xi(of)/xi_inf_star )**prm%a & + * sign(1.0_pReal, 1.0_pReal - stt%xi(of)/xi_inf_star) else - hardening = 0.0_pReal + dot%xi(of) = 0.0_pReal endif - dot%xi (of) = hardening * gamma_dot - dot%accumulatedShear(of) = gamma_dot + dot%gamma(of) = dot_gamma ! ToDo: not really used end associate @@ -468,8 +466,8 @@ function plastic_isotropic_postResults(Mp,instance,of) result(postResults) case (xi_ID) postResults(c+1) = stt%xi(of) c = c + 1 - case (strainrate_ID) - postResults(c+1) = prm%gdot0 & + case (dot_gamma_ID) + postResults(c+1) = prm%dot_gamma_0 & * (sqrt(1.5_pReal) * norm_Mp /(prm%M * stt%xi(of)))**prm%n c = c + 1 From 4470ecfe4a170d1886c2d261c7e9a2a584085362 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 28 Mar 2019 06:52:17 +0100 Subject: [PATCH 17/47] better have a separate module --- src/CMakeLists.txt | 8 ++++++-- src/commercialFEM_fileList.f90 | 1 + src/list.f90 | 4 +++- 3 files changed, 10 insertions(+), 3 deletions(-) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index b9b5fafff..ddcf5972b 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -44,8 +44,12 @@ add_library(DEBUG OBJECT "debug.f90") add_dependencies(DEBUG IO) list(APPEND OBJECTFILES $) -add_library(DAMASK_CONFIG OBJECT "config.f90") -add_dependencies(DAMASK_CONFIG DEBUG) +add_library(DAMASK_LIST OBJECT "list.f90") # LIST is a keyword in CMake +add_dependencies(DAMASK_LIST IO) +list(APPEND OBJECTFILES $) + +add_library(DAMASK_CONFIG OBJECT "config.f90") # CONFIG is a keyword in CMake +add_dependencies(DAMASK_CONFIG DAMASK_LIST DEBUG) list(APPEND OBJECTFILES $) add_library(HDF5_UTILITIES OBJECT "HDF5_utilities.f90") diff --git a/src/commercialFEM_fileList.f90 b/src/commercialFEM_fileList.f90 index 39e9269f4..77a8f0df4 100644 --- a/src/commercialFEM_fileList.f90 +++ b/src/commercialFEM_fileList.f90 @@ -6,6 +6,7 @@ #include "IO.f90" #include "numerics.f90" #include "debug.f90" +#include "list.f90" #include "config.f90" #ifdef DAMASKHDF5 #include "HDF5_utilities.f90" diff --git a/src/list.f90 b/src/list.f90 index 93c19b903..6725d5902 100644 --- a/src/list.f90 +++ b/src/list.f90 @@ -224,7 +224,8 @@ real(pReal) function getFloat(this,key,defaultVal) real(pReal), intent(in), optional :: defaultVal type(tPartitionedStringList), pointer :: item logical :: found - + + getFloat = huge(1.0) ! suppress warning about unitialized value found = present(defaultVal) if (found) getFloat = defaultVal @@ -261,6 +262,7 @@ integer function getInt(this,key,defaultVal) type(tPartitionedStringList), pointer :: item logical :: found + getInt = huge(1) ! suppress warning about unitialized value found = present(defaultVal) if (found) getInt = defaultVal From 9f2559baf5190df3b4d7935c75876def00f2d089 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 28 Mar 2019 07:04:48 +0100 Subject: [PATCH 18/47] allow defaultVal string of variable length --- src/list.f90 | 33 +++++++++++++++++++-------------- src/plastic_isotropic.f90 | 3 +-- 2 files changed, 20 insertions(+), 16 deletions(-) diff --git a/src/list.f90 b/src/list.f90 index 6725d5902..1c4c4a8a0 100644 --- a/src/list.f90 +++ b/src/list.f90 @@ -295,7 +295,7 @@ character(len=65536) function getString(this,key,defaultVal,raw) implicit none class(tPartitionedStringList), target, intent(in) :: this character(len=*), intent(in) :: key - character(len=65536), intent(in), optional :: defaultVal + character(len=*), intent(in), optional :: defaultVal logical, intent(in), optional :: raw type(tPartitionedStringList), pointer :: item logical :: found, & @@ -308,8 +308,8 @@ character(len=65536) function getString(this,key,defaultVal,raw) found = present(defaultVal) if (found) then + if (len_trim(defaultVal) > len(getString)) call IO_error(0,ext_msg='getString') getString = trim(defaultVal) - if (len_trim(getString) /= len_trim(defaultVal)) call IO_error(0,ext_msg='getString') endif item => this @@ -444,17 +444,17 @@ function getStrings(this,key,defaultVal,raw) IO_StringValue implicit none - character(len=65536),dimension(:), allocatable :: getStrings - class(tPartitionedStringList), target, intent(in) :: this - character(len=*), intent(in) :: key - character(len=65536),dimension(:), intent(in), optional :: defaultVal - logical, intent(in), optional :: raw - type(tPartitionedStringList), pointer :: item - character(len=65536) :: str - integer :: i - logical :: found, & - whole, & - cumulative + character(len=65536),dimension(:), allocatable :: getStrings + class(tPartitionedStringList),target, intent(in) :: this + character(len=*), intent(in) :: key + character(len=*), dimension(:), intent(in), optional :: defaultVal + logical, intent(in), optional :: raw + type(tPartitionedStringList), pointer :: item + character(len=65536) :: str + integer :: i + logical :: found, & + whole, & + cumulative cumulative = (key(1:1) == '(' .and. key(len_trim(key):len_trim(key)) == ')') if (present(raw)) then @@ -499,7 +499,12 @@ function getStrings(this,key,defaultVal,raw) enddo if (.not. found) then - if (present(defaultVal)) then; getStrings = defaultVal; else; call IO_error(140,ext_msg=key); endif + if (present(defaultVal)) then + if (len(defaultVal) > len(getStrings)) call IO_error(0,ext_msg='getStrings') + getStrings = defaultVal + else + call IO_error(140,ext_msg=key) + endif endif end function getStrings diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 index 71747929c..49c9285f0 100644 --- a/src/plastic_isotropic.f90 +++ b/src/plastic_isotropic.f90 @@ -9,8 +9,7 @@ !-------------------------------------------------------------------------------------------------- module plastic_isotropic use prec, only: & - pReal, & - pInt + pReal implicit none private From dd519455709bde19871379ba5c6a42d19ad21c2e Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 28 Mar 2019 07:25:20 +0100 Subject: [PATCH 19/47] checking for input errors --- python/damask/orientation.py | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/python/damask/orientation.py b/python/damask/orientation.py index ad9877835..7cb05af40 100644 --- a/python/damask/orientation.py +++ b/python/damask/orientation.py @@ -992,9 +992,14 @@ class Lattice: models={'KS':self.KS, 'GT':self.GT, "GT'":self.GTdash, 'NW':self.NW, 'Pitsch': self.Pitsch, 'Bain':self.Bain} + try: + relationship = models[model] + except: + raise KeyError('Orientation relationship "{}" is unknown'.format(model)) - relationship = models[model] - + if self.lattice not in relationship['mapping']: + raise ValueError('Relationship "{}" not supported for lattice "{}"'.format(model,self.lattice)) + r = {'lattice':Lattice((set(relationship['mapping'])-{self.lattice}).pop()), # target lattice 'rotations':[] } From 32c03d0b9b8ebb3f24b1c0912b41df28f0c873b1 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 28 Mar 2019 09:20:24 +0100 Subject: [PATCH 20/47] keyword has not changed (yet) --- src/plastic_isotropic.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 index 49c9285f0..be1204d75 100644 --- a/src/plastic_isotropic.f90 +++ b/src/plastic_isotropic.f90 @@ -195,7 +195,7 @@ subroutine plastic_isotropic_init outputID = undefined_ID select case(outputs(i)) - case ('xi') + case ('flowstress') outputID = xi_ID case ('strainrate') outputID = dot_gamma_ID From 5ffe78ff1f821d759e63dad1c76e6d7ea70c2e66 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 28 Mar 2019 09:47:03 +0100 Subject: [PATCH 21/47] bugfix: strain rate was missing dot_gamma is per definition positive, abs only confuses the reader --- src/plastic_isotropic.f90 | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 index be1204d75..a98f8613e 100644 --- a/src/plastic_isotropic.f90 +++ b/src/plastic_isotropic.f90 @@ -403,7 +403,7 @@ subroutine plastic_isotropic_dotState(Mp,instance,of) dot_gamma = prm%dot_gamma_0 * (sqrt(1.5_pReal) * norm_Mp /(prm%M*stt%xi(of))) **prm%n - if (abs(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 @@ -412,9 +412,10 @@ subroutine plastic_isotropic_dotState(Mp,instance,of) )**(1.0_pReal / prm%c_3) & / prm%c_4 * (dot_gamma / prm%dot_gamma_0)**(1.0_pReal / prm%n) endif - dot%xi(of) = ( prm%h0 + prm%h_ln * log(dot_gamma) ) & - * abs( 1.0_pReal - stt%xi(of)/xi_inf_star )**prm%a & - * sign(1.0_pReal, 1.0_pReal - stt%xi(of)/xi_inf_star) + dot%xi(of) = dot_gamma & + * ( prm%h0 + prm%h_ln * log(dot_gamma) ) & + * abs( 1.0_pReal - stt%xi(of)/xi_inf_star )**prm%a & + * sign(1.0_pReal, 1.0_pReal - stt%xi(of)/xi_inf_star) else dot%xi(of) = 0.0_pReal endif From 8aee3d7f54d05baea28d462c30f94b7f3243c6b0 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 29 Mar 2019 08:34:44 +0100 Subject: [PATCH 22/47] use list from separate module --- src/config.f90 | 827 ++++++++++--------------------------------------- 1 file changed, 172 insertions(+), 655 deletions(-) diff --git a/src/config.f90 b/src/config.f90 index 2fb947a00..23268d1de 100644 --- a/src/config.f90 +++ b/src/config.f90 @@ -6,71 +6,40 @@ !! parts 'homogenization', 'crystallite', 'phase', 'texture', and 'microstucture' !-------------------------------------------------------------------------------------------------- module config - use prec, only: & - pReal + use prec, only: & + pReal + use list, only: & + tPartitionedStringList - implicit none - private - type, private :: tPartitionedString - character(len=:), allocatable :: val - integer, dimension(:), allocatable :: pos - end type tPartitionedString - - type, private :: tPartitionedStringList - type(tPartitionedString) :: string - type(tPartitionedStringList), pointer :: next => null() - contains - procedure :: add => add - procedure :: show => show - procedure :: free => free + implicit none -! currently, a finalize is needed for all shapes of tPartitionedStringList. -! with Fortran 2015, we can define one recursive elemental function -! https://software.intel.com/en-us/forums/intel-visual-fortran-compiler-for-windows/topic/543326 - final :: finalize, & - finalizeArray - - procedure :: keyExists => keyExists - procedure :: countKeys => countKeys - - procedure :: getFloat => getFloat - procedure :: getInt => getInt - procedure :: getString => getString - - procedure :: getFloats => getFloats - procedure :: getInts => getInts - procedure :: getStrings => getStrings - - - end type tPartitionedStringList - - type(tPartitionedStringList), public, protected, allocatable, dimension(:) :: & - config_phase, & - config_microstructure, & - config_homogenization, & - config_texture, & - config_crystallite + type(tPartitionedStringList), public, protected, allocatable, dimension(:) :: & + config_phase, & + config_microstructure, & + config_homogenization, & + config_texture, & + config_crystallite - type(tPartitionedStringList), public, protected :: & - config_numerics, & - config_debug + type(tPartitionedStringList), public, protected :: & + config_numerics, & + config_debug - character(len=64), dimension(:), allocatable, public, protected :: & - phase_name, & !< name of each phase - homogenization_name, & !< name of each homogenization - crystallite_name, & !< name of each crystallite setting - microstructure_name, & !< name of each microstructure - texture_name !< name of each texture + character(len=64), dimension(:), allocatable, public, protected :: & + phase_name, & !< name of each phase + homogenization_name, & !< name of each homogenization + crystallite_name, & !< name of each crystallite setting + microstructure_name, & !< name of each microstructure + texture_name !< name of each texture ! ToDo: Remove, use size(config_phase) etc - integer, public, protected :: & - material_Nphase, & !< number of phases - material_Nhomogenization !< number of homogenizations + integer, public, protected :: & + material_Nphase, & !< number of phases + material_Nhomogenization !< number of homogenizations - public :: & - config_init, & - config_deallocate + public :: & + config_init, & + config_deallocate contains @@ -78,96 +47,96 @@ contains !> @brief reads material.config and stores its content per part !-------------------------------------------------------------------------------------------------- subroutine config_init - use prec, only: & - pStringLen - use DAMASK_interface, only: & - getSolverJobName - use IO, only: & - IO_read_ASCII, & - IO_error, & - IO_lc, & - IO_getTag - use debug, only: & - debug_level, & - debug_material, & - debug_levelBasic + use prec, only: & + pStringLen + use DAMASK_interface, only: & + getSolverJobName + use IO, only: & + IO_read_ASCII, & + IO_error, & + IO_lc, & + IO_getTag + use debug, only: & + debug_level, & + debug_material, & + debug_levelBasic - implicit none - integer :: myDebug,i + implicit none + integer :: myDebug,i - character(len=pStringLen) :: & - line, & - part - character(len=pStringLen), dimension(:), allocatable :: fileContent - logical :: fileExists + character(len=pStringLen) :: & + line, & + part + character(len=pStringLen), dimension(:), allocatable :: fileContent + logical :: fileExists - write(6,'(/,a)') ' <<<+- config init -+>>>' + write(6,'(/,a)') ' <<<+- config init -+>>>' - myDebug = debug_level(debug_material) + myDebug = debug_level(debug_material) - inquire(file=trim(getSolverJobName())//'.materialConfig',exist=fileExists) - if(fileExists) then - write(6,'(/,a)') ' reading '//trim(getSolverJobName())//'.materialConfig'; flush(6) - fileContent = read_materialConfig(trim(getSolverJobName())//'.materialConfig') - else - inquire(file='material.config',exist=fileExists) - if(.not. fileExists) call IO_error(100,ext_msg='material.config') - write(6,'(/,a)') ' reading material.config'; flush(6) - fileContent = read_materialConfig('material.config') - endif - - do i = 1, size(fileContent) - line = trim(fileContent(i)) - part = IO_lc(IO_getTag(line,'<','>')) - select case (trim(part)) - - case (trim('phase')) - call parse_materialConfig(phase_name,config_phase,line,fileContent(i+1:)) - if (iand(myDebug,debug_levelBasic) /= 0) write(6,'(a)') ' Phase parsed'; flush(6) - - case (trim('microstructure')) - call parse_materialConfig(microstructure_name,config_microstructure,line,fileContent(i+1:)) - if (iand(myDebug,debug_levelBasic) /= 0) write(6,'(a)') ' Microstructure parsed'; flush(6) - - case (trim('crystallite')) - call parse_materialConfig(crystallite_name,config_crystallite,line,fileContent(i+1:)) - if (iand(myDebug,debug_levelBasic) /= 0) write(6,'(a)') ' Crystallite parsed'; flush(6) - - case (trim('homogenization')) - call parse_materialConfig(homogenization_name,config_homogenization,line,fileContent(i+1:)) - if (iand(myDebug,debug_levelBasic) /= 0) write(6,'(a)') ' Homogenization parsed'; flush(6) - - case (trim('texture')) - call parse_materialConfig(texture_name,config_texture,line,fileContent(i+1:)) - if (iand(myDebug,debug_levelBasic) /= 0) write(6,'(a)') ' Texture parsed'; flush(6) - - end select - - enddo - - material_Nhomogenization = size(config_homogenization) - material_Nphase = size(config_phase) - - if (material_Nhomogenization < 1) call IO_error(160,ext_msg='') - if (size(config_microstructure) < 1) call IO_error(160,ext_msg='') - if (size(config_crystallite) < 1) call IO_error(160,ext_msg='') - if (material_Nphase < 1) call IO_error(160,ext_msg='') - if (size(config_texture) < 1) call IO_error(160,ext_msg='') - - - inquire(file='numerics.config', exist=fileExists) - if (fileExists) then - write(6,'(/,a)') ' reading numerics.config'; flush(6) - fileContent = IO_read_ASCII('numerics.config') - call parse_debugAndNumericsConfig(config_numerics,fileContent) + inquire(file=trim(getSolverJobName())//'.materialConfig',exist=fileExists) + if(fileExists) then + write(6,'(/,a)') ' reading '//trim(getSolverJobName())//'.materialConfig'; flush(6) + fileContent = read_materialConfig(trim(getSolverJobName())//'.materialConfig') + else + inquire(file='material.config',exist=fileExists) + if(.not. fileExists) call IO_error(100,ext_msg='material.config') + write(6,'(/,a)') ' reading material.config'; flush(6) + fileContent = read_materialConfig('material.config') endif + + do i = 1, size(fileContent) + line = trim(fileContent(i)) + part = IO_lc(IO_getTag(line,'<','>')) + select case (trim(part)) + + case (trim('phase')) + call parse_materialConfig(phase_name,config_phase,line,fileContent(i+1:)) + if (iand(myDebug,debug_levelBasic) /= 0) write(6,'(a)') ' Phase parsed'; flush(6) + + case (trim('microstructure')) + call parse_materialConfig(microstructure_name,config_microstructure,line,fileContent(i+1:)) + if (iand(myDebug,debug_levelBasic) /= 0) write(6,'(a)') ' Microstructure parsed'; flush(6) + + case (trim('crystallite')) + call parse_materialConfig(crystallite_name,config_crystallite,line,fileContent(i+1:)) + if (iand(myDebug,debug_levelBasic) /= 0) write(6,'(a)') ' Crystallite parsed'; flush(6) + + case (trim('homogenization')) + call parse_materialConfig(homogenization_name,config_homogenization,line,fileContent(i+1:)) + if (iand(myDebug,debug_levelBasic) /= 0) write(6,'(a)') ' Homogenization parsed'; flush(6) + + case (trim('texture')) + call parse_materialConfig(texture_name,config_texture,line,fileContent(i+1:)) + if (iand(myDebug,debug_levelBasic) /= 0) write(6,'(a)') ' Texture parsed'; flush(6) + + end select + + enddo + + material_Nhomogenization = size(config_homogenization) + material_Nphase = size(config_phase) + + if (material_Nhomogenization < 1) call IO_error(160,ext_msg='') + if (size(config_microstructure) < 1) call IO_error(160,ext_msg='') + if (size(config_crystallite) < 1) call IO_error(160,ext_msg='') + if (material_Nphase < 1) call IO_error(160,ext_msg='') + if (size(config_texture) < 1) call IO_error(160,ext_msg='') + + + inquire(file='numerics.config', exist=fileExists) + if (fileExists) then + write(6,'(/,a)') ' reading numerics.config'; flush(6) + fileContent = IO_read_ASCII('numerics.config') + call parse_debugAndNumericsConfig(config_numerics,fileContent) + endif - inquire(file='debug.config', exist=fileExists) - if (fileExists) then - write(6,'(/,a)') ' reading debug.config'; flush(6) - fileContent = IO_read_ASCII('debug.config') - call parse_debugAndNumericsConfig(config_debug,fileContent) - endif + inquire(file='debug.config', exist=fileExists) + if (fileExists) then + write(6,'(/,a)') ' reading debug.config'; flush(6) + fileContent = IO_read_ASCII('debug.config') + call parse_debugAndNumericsConfig(config_debug,fileContent) + endif contains @@ -262,47 +231,47 @@ end function read_materialConfig !-------------------------------------------------------------------------------------------------- subroutine parse_materialConfig(sectionNames,part,line, & fileContent) - implicit none - character(len=64), allocatable, dimension(:), intent(out) :: sectionNames - type(tPartitionedStringList), allocatable, dimension(:), intent(inout) :: part - character(len=pStringLen), intent(inout) :: line - character(len=pStringLen), dimension(:), intent(in) :: fileContent + implicit none + character(len=64), allocatable, dimension(:), intent(out) :: sectionNames + type(tPartitionedStringList), allocatable, dimension(:), intent(inout) :: part + character(len=pStringLen), intent(inout) :: line + character(len=pStringLen), dimension(:), intent(in) :: fileContent - integer, allocatable, dimension(:) :: partPosition ! position of [] tags + last line in section - integer :: i, j - logical :: echo + integer, allocatable, dimension(:) :: partPosition ! position of [] tags + last line in section + integer :: i, j + logical :: echo - echo = .false. + echo = .false. - if (allocated(part)) call IO_error(161,ext_msg=trim(line)) - allocate(partPosition(0)) + if (allocated(part)) call IO_error(161,ext_msg=trim(line)) + allocate(partPosition(0)) - do i = 1, size(fileContent) - line = trim(fileContent(i)) - if (IO_getTag(line,'<','>') /= '') exit - nextSection: if (IO_getTag(line,'[',']') /= '') then - partPosition = [partPosition, i] - cycle - endif nextSection - if (size(partPosition) < 1) & - echo = (trim(IO_getTag(line,'/','/')) == 'echo') .or. echo - enddo + do i = 1, size(fileContent) + line = trim(fileContent(i)) + if (IO_getTag(line,'<','>') /= '') exit + nextSection: if (IO_getTag(line,'[',']') /= '') then + partPosition = [partPosition, i] + cycle + endif nextSection + if (size(partPosition) < 1) & + echo = (trim(IO_getTag(line,'/','/')) == 'echo') .or. echo + enddo - allocate(sectionNames(size(partPosition))) - allocate(part(size(partPosition))) + allocate(sectionNames(size(partPosition))) + allocate(part(size(partPosition))) - partPosition = [partPosition, i] ! needed when actually storing content + partPosition = [partPosition, i] ! needed when actually storing content - do i = 1, size(partPosition) -1 - sectionNames(i) = trim(adjustl(IO_getTag(fileContent(partPosition(i)),'[',']'))) - do j = partPosition(i) + 1, partPosition(i+1) -1 - call part(i)%add(trim(adjustl(fileContent(j)))) - enddo - if (echo) then - write(6,*) 'section',i, '"'//trim(sectionNames(i))//'"' - call part(i)%show() - endif - enddo + do i = 1, size(partPosition) -1 + sectionNames(i) = trim(adjustl(IO_getTag(fileContent(partPosition(i)),'[',']'))) + do j = partPosition(i) + 1, partPosition(i+1) -1 + call part(i)%add(trim(adjustl(fileContent(j)))) + enddo + if (echo) then + write(6,*) 'section',i, '"'//trim(sectionNames(i))//'"' + call part(i)%show() + endif + enddo end subroutine parse_materialConfig @@ -312,14 +281,14 @@ end subroutine parse_materialConfig !-------------------------------------------------------------------------------------------------- subroutine parse_debugAndNumericsConfig(config_list, & fileContent) - implicit none - type(tPartitionedStringList), intent(out) :: config_list - character(len=pStringLen), dimension(:), intent(in) :: fileContent - integer :: i + implicit none + type(tPartitionedStringList), intent(out) :: config_list + character(len=pStringLen), dimension(:), intent(in) :: fileContent + integer :: i - do i = 1, size(fileContent) - call config_list%add(trim(adjustl(fileContent(i)))) - enddo + do i = 1, size(fileContent) + call config_list%add(trim(adjustl(fileContent(i)))) + enddo end subroutine parse_debugAndNumericsConfig @@ -330,492 +299,40 @@ end subroutine config_init !> @brief deallocates the linked lists that store the content of the configuration files !-------------------------------------------------------------------------------------------------- subroutine config_deallocate(what) - use IO, only: & - IO_error + use IO, only: & + IO_error - implicit none - character(len=*), intent(in) :: what + implicit none + character(len=*), intent(in) :: what - select case(trim(what)) + select case(trim(what)) - case('material.config/phase') - deallocate(config_phase) + case('material.config/phase') + deallocate(config_phase) - case('material.config/microstructure') - deallocate(config_microstructure) + case('material.config/microstructure') + deallocate(config_microstructure) - case('material.config/crystallite') - deallocate(config_crystallite) + case('material.config/crystallite') + deallocate(config_crystallite) - case('material.config/homogenization') - deallocate(config_homogenization) + case('material.config/homogenization') + deallocate(config_homogenization) - case('material.config/texture') - deallocate(config_texture) + case('material.config/texture') + deallocate(config_texture) - case('debug.config') - call config_debug%free + case('debug.config') + call config_debug%free - case('numerics.config') - call config_numerics%free + case('numerics.config') + call config_numerics%free - case default - call IO_error(0,ext_msg='config_deallocate') + case default + call IO_error(0,ext_msg='config_deallocate') - end select + end select end subroutine config_deallocate - -!################################################################################################## -! The folowing functions are part of the tPartitionedStringList object -!################################################################################################## - - - -!-------------------------------------------------------------------------------------------------- -!> @brief add element -!> @details Adds a string together with the start/end position of chunks in this string. The new -!! element is added at the end of the list. Empty strings are not added. All strings are converted -!! to lower case. The data is not stored in the new element but in the current. -!-------------------------------------------------------------------------------------------------- -subroutine add(this,string) - use IO, only: & - IO_isBlank, & - IO_lc, & - IO_stringPos - - implicit none - class(tPartitionedStringList), target, intent(in) :: this - character(len=*), intent(in) :: string - type(tPartitionedStringList), pointer :: new, temp - - if (IO_isBlank(string)) return - - allocate(new) - temp => this - do while (associated(temp%next)) - temp => temp%next - enddo - temp%string%val = IO_lc (trim(string)) - temp%string%pos = IO_stringPos(trim(string)) - temp%next => new - -end subroutine add - - -!-------------------------------------------------------------------------------------------------- -!> @brief prints all elements -!> @details Strings are printed in order of insertion (FIFO) -!-------------------------------------------------------------------------------------------------- -subroutine show(this) - - implicit none - class(tPartitionedStringList), target, intent(in) :: this - type(tPartitionedStringList), pointer :: item - - item => this - do while (associated(item%next)) - write(6,'(a)') ' '//trim(item%string%val) - item => item%next - enddo - -end subroutine show - - -!-------------------------------------------------------------------------------------------------- -!> @brief empties list and frees associated memory -!> @details explicit interface to reset list. Triggers final statement (and following chain reaction) -!-------------------------------------------------------------------------------------------------- -subroutine free(this) - - implicit none - class(tPartitionedStringList), intent(inout) :: this - - if(associated(this%next)) deallocate(this%next) - -end subroutine free - - -!-------------------------------------------------------------------------------------------------- -!> @brief empties list and frees associated memory -!> @details called when variable goes out of scope. Triggers chain reaction for list -!-------------------------------------------------------------------------------------------------- -recursive subroutine finalize(this) - - implicit none - type(tPartitionedStringList), intent(inout) :: this - - if(associated(this%next)) deallocate(this%next) - -end subroutine finalize - - -!-------------------------------------------------------------------------------------------------- -!> @brief cleans entire array of linke lists -!> @details called when variable goes out of scope and deallocates the list at each array entry -!-------------------------------------------------------------------------------------------------- -subroutine finalizeArray(this) - - implicit none - integer :: i - type(tPartitionedStringList), intent(inout), dimension(:) :: this - type(tPartitionedStringList), pointer :: temp ! bug in Gfortran? - - do i=1, size(this) - if (associated(this(i)%next)) then - temp => this(i)%next - !deallocate(this(i)) !internal compiler error: in gfc_build_final_call, at fortran/trans.c:975 - deallocate(temp) - endif - enddo - -end subroutine finalizeArray - - -!-------------------------------------------------------------------------------------------------- -!> @brief reports wether a given key (string value at first position) exists in the list -!-------------------------------------------------------------------------------------------------- -logical function keyExists(this,key) - use IO, only: & - IO_stringValue - - implicit none - class(tPartitionedStringList), target, intent(in) :: this - character(len=*), intent(in) :: key - type(tPartitionedStringList), pointer :: item - - keyExists = .false. - - item => this - do while (associated(item%next) .and. .not. keyExists) - keyExists = trim(IO_stringValue(item%string%val,item%string%pos,1)) == trim(key) - item => item%next - enddo - -end function keyExists - - -!-------------------------------------------------------------------------------------------------- -!> @brief count number of key appearances -!> @details traverses list and counts each occurrence of specified key -!-------------------------------------------------------------------------------------------------- -integer function countKeys(this,key) - use IO, only: & - IO_stringValue - - implicit none - - class(tPartitionedStringList), target, intent(in) :: this - character(len=*), intent(in) :: key - type(tPartitionedStringList), pointer :: item - - countKeys = 0 - - item => this - do while (associated(item%next)) - if (trim(IO_stringValue(item%string%val,item%string%pos,1)) == trim(key)) & - countKeys = countKeys + 1 - item => item%next - enddo - -end function countKeys - - -!-------------------------------------------------------------------------------------------------- -!> @brief gets float value of for a given key from a linked list -!> @details gets the last value if the key occurs more than once. If key is not found exits with -!! error unless default is given -!-------------------------------------------------------------------------------------------------- -real(pReal) function getFloat(this,key,defaultVal) - use IO, only : & - IO_error, & - IO_stringValue, & - IO_FloatValue - - implicit none - class(tPartitionedStringList), target, intent(in) :: this - character(len=*), intent(in) :: key - real(pReal), intent(in), optional :: defaultVal - type(tPartitionedStringList), pointer :: item - logical :: found - - found = present(defaultVal) - if (found) getFloat = defaultVal - - item => this - do while (associated(item%next)) - if (trim(IO_stringValue(item%string%val,item%string%pos,1)) == trim(key)) then - found = .true. - if (item%string%pos(1) < 2) call IO_error(143,ext_msg=key) - getFloat = IO_FloatValue(item%string%val,item%string%pos,2) - endif - item => item%next - enddo - - if (.not. found) call IO_error(140,ext_msg=key) - -end function getFloat - - -!-------------------------------------------------------------------------------------------------- -!> @brief gets integer value of for a given key from a linked list -!> @details gets the last value if the key occurs more than once. If key is not found exits with -!! error unless default is given -!-------------------------------------------------------------------------------------------------- -integer function getInt(this,key,defaultVal) - use IO, only: & - IO_error, & - IO_stringValue, & - IO_IntValue - - implicit none - class(tPartitionedStringList), target, intent(in) :: this - character(len=*), intent(in) :: key - integer, intent(in), optional :: defaultVal - type(tPartitionedStringList), pointer :: item - logical :: found - - found = present(defaultVal) - if (found) getInt = defaultVal - - item => this - do while (associated(item%next)) - if (trim(IO_stringValue(item%string%val,item%string%pos,1)) == trim(key)) then - found = .true. - if (item%string%pos(1) < 2) call IO_error(143,ext_msg=key) - getInt = IO_IntValue(item%string%val,item%string%pos,2) - endif - item => item%next - enddo - - if (.not. found) call IO_error(140,ext_msg=key) - -end function getInt - - -!-------------------------------------------------------------------------------------------------- -!> @brief gets string value of for a given key from a linked list -!> @details gets the last value if the key occurs more than once. If key is not found exits with -!! error unless default is given. If raw is true, the the complete string is returned, otherwise -!! the individual chunks are returned -!-------------------------------------------------------------------------------------------------- -character(len=65536) function getString(this,key,defaultVal,raw) - use IO, only: & - IO_error, & - IO_stringValue - - implicit none - class(tPartitionedStringList), target, intent(in) :: this - character(len=*), intent(in) :: key - character(len=*), intent(in), optional :: defaultVal - logical, intent(in), optional :: raw - type(tPartitionedStringList), pointer :: item - logical :: found, & - whole - if (present(raw)) then - whole = raw - else - whole = .false. - endif - - found = present(defaultVal) - if (found) then - getString = trim(defaultVal) - !if (len_trim(getString) /= len_trim(defaultVal)) call IO_error(0,ext_msg='getString') - endif - - item => this - do while (associated(item%next)) - if (trim(IO_stringValue(item%string%val,item%string%pos,1)) == trim(key)) then - found = .true. - if (item%string%pos(1) < 2) call IO_error(143,ext_msg=key) - - if (whole) then - getString = trim(item%string%val(item%string%pos(4):)) ! raw string starting a second chunk - else - getString = IO_StringValue(item%string%val,item%string%pos,2) - endif - endif - item => item%next - enddo - - if (.not. found) call IO_error(140,ext_msg=key) - -end function getString - - -!-------------------------------------------------------------------------------------------------- -!> @brief gets array of float values of for a given key from a linked list -!> @details for cumulative keys, "()", values from all occurrences are return. Otherwise only all -!! values from the last occurrence. If key is not found exits with error unless default is given. -!-------------------------------------------------------------------------------------------------- -function getFloats(this,key,defaultVal,requiredSize) - use IO, only: & - IO_error, & - IO_stringValue, & - IO_FloatValue - - implicit none - real(pReal), dimension(:), allocatable :: getFloats - class(tPartitionedStringList), target, intent(in) :: this - character(len=*), intent(in) :: key - real(pReal), dimension(:), intent(in), optional :: defaultVal - integer, intent(in), optional :: requiredSize - type(tPartitionedStringList), pointer :: item - integer :: i - logical :: found, & - cumulative - - cumulative = (key(1:1) == '(' .and. key(len_trim(key):len_trim(key)) == ')') - found = .false. - - allocate(getFloats(0)) - - item => this - do while (associated(item%next)) - if (trim(IO_stringValue(item%string%val,item%string%pos,1)) == trim(key)) then - found = .true. - if (.not. cumulative) getFloats = [real(pReal)::] - if (item%string%pos(1) < 2) call IO_error(143,ext_msg=key) - do i = 2, item%string%pos(1) - getFloats = [getFloats,IO_FloatValue(item%string%val,item%string%pos,i)] - enddo - endif - item => item%next - enddo - - if (.not. found) then - if (present(defaultVal)) then; getFloats = defaultVal; else; call IO_error(140,ext_msg=key); endif - endif - if (present(requiredSize)) then - if(requiredSize /= size(getFloats)) call IO_error(146,ext_msg=key) - endif - -end function getFloats - - -!-------------------------------------------------------------------------------------------------- -!> @brief gets array of integer values of for a given key from a linked list -!> @details for cumulative keys, "()", values from all occurrences are return. Otherwise only all -!! values from the last occurrence. If key is not found exits with error unless default is given. -!-------------------------------------------------------------------------------------------------- -function getInts(this,key,defaultVal,requiredSize) - use IO, only: & - IO_error, & - IO_stringValue, & - IO_IntValue - - implicit none - integer, dimension(:), allocatable :: getInts - class(tPartitionedStringList), target, intent(in) :: this - character(len=*), intent(in) :: key - integer, dimension(:), intent(in), optional :: defaultVal - integer, intent(in), optional :: requiredSize - type(tPartitionedStringList), pointer :: item - integer :: i - logical :: found, & - cumulative - - cumulative = (key(1:1) == '(' .and. key(len_trim(key):len_trim(key)) == ')') - found = .false. - - allocate(getInts(0)) - - item => this - do while (associated(item%next)) - if (trim(IO_stringValue(item%string%val,item%string%pos,1)) == trim(key)) then - found = .true. - if (.not. cumulative) getInts = [integer::] - if (item%string%pos(1) < 2) call IO_error(143,ext_msg=key) - do i = 2, item%string%pos(1) - getInts = [getInts,IO_IntValue(item%string%val,item%string%pos,i)] - enddo - endif - item => item%next - enddo - - if (.not. found) then - if (present(defaultVal)) then; getInts = defaultVal; else; call IO_error(140,ext_msg=key); endif - endif - if (present(requiredSize)) then - if(requiredSize /= size(getInts)) call IO_error(146,ext_msg=key) - endif - -end function getInts - - -!-------------------------------------------------------------------------------------------------- -!> @brief gets array of string values of for a given key from a linked list -!> @details for cumulative keys, "()", values from all occurrences are return. Otherwise only all -!! values from the last occurrence. If key is not found exits with error unless default is given. -!! If raw is true, the the complete string is returned, otherwise the individual chunks are returned -!-------------------------------------------------------------------------------------------------- -function getStrings(this,key,defaultVal,raw) - use IO, only: & - IO_error, & - IO_StringValue - - implicit none - character(len=65536),dimension(:), allocatable :: getStrings - class(tPartitionedStringList), target, intent(in) :: this - character(len=*), intent(in) :: key - character(len=65536),dimension(:), intent(in), optional :: defaultVal - logical, intent(in), optional :: raw - type(tPartitionedStringList), pointer :: item - character(len=65536) :: str - integer :: i - logical :: found, & - whole, & - cumulative - - cumulative = (key(1:1) == '(' .and. key(len_trim(key):len_trim(key)) == ')') - if (present(raw)) then - whole = raw - else - whole = .false. - endif - found = .false. - - item => this - do while (associated(item%next)) - if (trim(IO_stringValue(item%string%val,item%string%pos,1)) == trim(key)) then - found = .true. - if (allocated(getStrings) .and. .not. cumulative) deallocate(getStrings) - if (item%string%pos(1) < 2) call IO_error(143,ext_msg=key) - - notAllocated: if (.not. allocated(getStrings)) then - if (whole) then - str = item%string%val(item%string%pos(4):) - getStrings = [str] - else - str = IO_StringValue(item%string%val,item%string%pos,2) - allocate(getStrings(1),source=str) - do i=3,item%string%pos(1) - str = IO_StringValue(item%string%val,item%string%pos,i) - getStrings = [getStrings,str] - enddo - endif - else notAllocated - if (whole) then - str = item%string%val(item%string%pos(4):) - getStrings = [getStrings,str] - else - do i=2,item%string%pos(1) - str = IO_StringValue(item%string%val,item%string%pos,i) - getStrings = [getStrings,str] - enddo - endif - endif notAllocated - endif - item => item%next - enddo - - if (.not. found) then - if (present(defaultVal)) then; getStrings = defaultVal; else; call IO_error(140,ext_msg=key); endif - endif - -end function getStrings - - end module config From 019d241c6741e61a2d3a2603a564296718dc825b Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 29 Mar 2019 08:45:25 +0100 Subject: [PATCH 23/47] keyword "spectralsolver" is currently used in the tests should become grid_mech soon --- src/DAMASK_grid.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/DAMASK_grid.f90 b/src/DAMASK_grid.f90 index 4d4b9c449..a1241f97f 100644 --- a/src/DAMASK_grid.f90 +++ b/src/DAMASK_grid.f90 @@ -167,7 +167,7 @@ program DAMASK_spectral !-------------------------------------------------------------------------------------------------- ! assign mechanics solver depending on selected type - select case (trim(config_numerics%getString('spectral_solver',defaultVal='basic'))) + select case (trim(config_numerics%getString('spectralsolver',defaultVal='basic'))) case ('basic') mech_init => grid_mech_spectral_basic_init mech_forward => grid_mech_spectral_basic_forward From be421f0cf5ef07a76633df936402059bd908a749 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 29 Mar 2019 08:48:32 +0100 Subject: [PATCH 24/47] use FFTW default flag and constants from include file --- src/spectral_utilities.f90 | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/spectral_utilities.f90 b/src/spectral_utilities.f90 index 5711fbbb3..26c1cf9fc 100644 --- a/src/spectral_utilities.f90 +++ b/src/spectral_utilities.f90 @@ -256,7 +256,7 @@ subroutine utilities_init num%FFTW_timelimit = config_numerics%getFloat ('fftw_timelimit', defaultVal=-1.0) num%divergence_correction = config_numerics%getInt ('divergence_correction', defaultVal=2) num%spectral_derivative = config_numerics%getString('spectral_derivative', defaultVal='continuous') - num%FFTW_plan_mode = config_numerics%getString('fftw_plan_mode', defaultVal='FFTW_PATIENT') + num%FFTW_plan_mode = config_numerics%getString('fftw_plan_mode', defaultVal='FFTW_MEASURE') if (num%divergence_correction < 0 .or. num%divergence_correction > 2) & call IO_error(301,ext_msg='divergence_correction') @@ -292,17 +292,17 @@ subroutine utilities_init select case(IO_lc(num%FFTW_plan_mode)) ! setting parameters for the plan creation of FFTW. Basically a translation from fftw3.f - case('estimate','fftw_estimate') ! ordered from slow execution (but fast plan creation) to fast execution - FFTW_planner_flag = 64 - case('measure','fftw_measure') - FFTW_planner_flag = 0 - case('patient','fftw_patient') - FFTW_planner_flag= 32 - case('exhaustive','fftw_exhaustive') - FFTW_planner_flag = 8 + case('fftw_estimate') ! ordered from slow execution (but fast plan creation) to fast execution + FFTW_planner_flag = FFTW_ESTIMATE + case('fftw_measure') + FFTW_planner_flag = FFTW_MEASURE + case('fftw_patient') + FFTW_planner_flag = FFTW_PATIENT + case('fftw_exhaustive') + FFTW_planner_flag = FFTW_EXHAUSTIVE case default call IO_warning(warning_ID=47,ext_msg=trim(IO_lc(num%FFTW_plan_mode))) - FFTW_planner_flag = 32 + FFTW_planner_flag = FFTW_MEASURE end select !-------------------------------------------------------------------------------------------------- From 3f5aa88e88023e6c37ffcff07116e147053aae65 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 29 Mar 2019 10:55:00 +0100 Subject: [PATCH 25/47] False is capitalized in Python --- installation/mods_Abaqus/abaqus_v6.env | 2 +- installation/mods_Abaqus/abaqus_v6_debug.env | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/installation/mods_Abaqus/abaqus_v6.env b/installation/mods_Abaqus/abaqus_v6.env index 55902278e..0811d0f65 100644 --- a/installation/mods_Abaqus/abaqus_v6.env +++ b/installation/mods_Abaqus/abaqus_v6.env @@ -12,7 +12,7 @@ # import os, re, glob, driverUtils -if false: +if False: # use hdf5 compiler wrapper in $PATH fortCmd = os.popen('h5fc -shlib -show').read().replace('\n','') # complicated way needed to pass in DAMASKVERSION string link_sl += fortCmd.split()[1:] diff --git a/installation/mods_Abaqus/abaqus_v6_debug.env b/installation/mods_Abaqus/abaqus_v6_debug.env index 2d28056ff..943f40bfa 100644 --- a/installation/mods_Abaqus/abaqus_v6_debug.env +++ b/installation/mods_Abaqus/abaqus_v6_debug.env @@ -12,7 +12,7 @@ # import os, re, glob, driverUtils -if false: +if False: # use hdf5 compiler wrapper in $PATH fortCmd = os.popen('h5fc -shlib -show').read().replace('\n','') # complicated way needed to pass in DAMASKVERSION string link_sl += fortCmd.split()[1:] From a5827c5ef359fe349b76ac35b7feb1a3ac83df4a Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 29 Mar 2019 14:26:32 +0100 Subject: [PATCH 26/47] using suitable defaults for damage --- src/grid_damage_spectral.f90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/grid_damage_spectral.f90 b/src/grid_damage_spectral.f90 index 297f32fab..1ce6e0c45 100644 --- a/src/grid_damage_spectral.f90 +++ b/src/grid_damage_spectral.f90 @@ -79,7 +79,8 @@ subroutine grid_damage_spectral_init !-------------------------------------------------------------------------------------------------- ! set default and user defined options for PETSc - call PETScOptionsInsertString(PETSC_NULL_OPTIONS,'-damage_snes_type ngmres',ierr) + call PETScOptionsInsertString(PETSC_NULL_OPTIONS,'-damage_snes_type newtonls -damage_snes_mf & + &-damage_snes_ksp_ew -damage_ksp_type fgmres',ierr) CHKERRQ(ierr) call PETScOptionsInsertString(PETSC_NULL_OPTIONS,trim(petsc_options),ierr) CHKERRQ(ierr) From 32dbe38fb724975b9e7c2f66fff2fbb16975a6db Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 29 Mar 2019 14:35:09 +0100 Subject: [PATCH 27/47] tests for Abaqus should be more stable --- PRIVATE | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/PRIVATE b/PRIVATE index 397d9265e..9b55224ef 160000 --- a/PRIVATE +++ b/PRIVATE @@ -1 +1 @@ -Subproject commit 397d9265ef677966610831bbf4d1358d879a4ac2 +Subproject commit 9b55224ef10f48b8090d13368648775eb54190d0 From bcaadac79a82856ae81217b4d1966fdbcd33c6d5 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 2 Apr 2019 15:39:55 +0200 Subject: [PATCH 28/47] simplification in agreeemnt with the paper --- src/plastic_isotropic.f90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 index a98f8613e..05a31ab75 100644 --- a/src/plastic_isotropic.f90 +++ b/src/plastic_isotropic.f90 @@ -288,7 +288,7 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) if (norm_Mp_dev > 0.0_pReal) then dot_gamma = prm%dot_gamma_0 * (sqrt(1.5_pReal) * norm_Mp_dev/(prm%M*stt%xi(of))) **prm%n - Lp = Mp_dev/norm_Mp_dev * dot_gamma/prm%M + Lp = dot_gamma/prm%M * Mp_dev/norm_Mp_dev #ifdef DEBUG if (iand(debug_level(debug_constitutive), debug_levelExtensive) /= 0 & .and. (of == prm%of_debug .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0)) then @@ -321,6 +321,7 @@ end subroutine plastic_isotropic_LpAndItsTangent !-------------------------------------------------------------------------------------------------- subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar,Tstar,instance,of) use math, only: & + math_I3, & math_spherical33, & math_mul33xx33 @@ -354,7 +355,7 @@ subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar,Tstar,instance,of) if (prm%dilatation .and. norm_Tstar_sph > 0.0_pReal) then ! no stress or J2 plastitiy --> Li and its derivative are zero dot_gamma = prm%dot_gamma_0 * (sqrt(1.5_pReal) * norm_Tstar_sph /(prm%M*stt%xi(of))) **prm%n - Li = Tstar_sph/norm_Tstar_sph * dot_gamma/prm%M + Li = math_I3/sqrt(3.0_pReal) * dot_gamma/prm%M forall (k=1:3,l=1:3,m=1:3,n=1:3) & dLi_dTstar(k,l,m,n) = (prm%n-1.0_pReal) * Tstar_sph(k,l)*Tstar_sph(m,n) / squarenorm_Tstar_sph forall (k=1:3,l=1:3) & From db42a954546e60cc19ba83e0fe09317c5b50689d Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 2 Apr 2019 20:54:31 +0200 Subject: [PATCH 29/47] cannot test Abaqus on Ubuntu 18.04 --- .gitlab-ci.yml | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index d66462cf4..45fb4e4f4 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -8,7 +8,6 @@ stages: - grid - compileMarc - marc - - compileAbaqus - example - performance - createPackage @@ -440,15 +439,6 @@ J2_plasticBehavior: - master - release -################################################################################################### -Abaqus_compile: - stage: compileAbaqus - script: - - module load $IntelAbaqus $Abaqus - - Abaqus_compileIfort/test.py - except: - - master - - release ################################################################################################### grid_all_example: From 0cf2c7b9e649f539a5f524665d0088dbf9b41dac Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 3 Apr 2019 08:10:26 +0200 Subject: [PATCH 30/47] don't use (random) texture anymore --- PRIVATE | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/PRIVATE b/PRIVATE index 9b55224ef..04bc997b6 160000 --- a/PRIVATE +++ b/PRIVATE @@ -1 +1 @@ -Subproject commit 9b55224ef10f48b8090d13368648775eb54190d0 +Subproject commit 04bc997b6660acab972abccaf2ceb7f45b97e9a0 From 4604e65a42c292453315559e0a13a14e3af4c57c Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 3 Apr 2019 08:22:04 +0200 Subject: [PATCH 31/47] use matmul instead of hand-written functions - performance is the same - leaner code - matmul works (was buggy a few years ago) --- src/CPFEM.f90 | 3 +- src/DAMASK_grid.f90 | 2 +- src/constitutive.f90 | 41 +++++-------- src/crystallite.f90 | 81 +++++++++++-------------- src/grid_damage_spectral.f90 | 4 +- src/grid_mech_FEM.f90 | 3 +- src/grid_mech_spectral_basic.f90 | 3 +- src/grid_mech_spectral_polarisation.f90 | 14 ++--- src/grid_thermal_spectral.f90 | 4 +- src/homogenization_RGC.f90 | 9 +-- src/lattice.f90 | 15 ++--- src/math.f90 | 44 +++++++------- src/mesh_grid.f90 | 4 +- src/plastic_dislotwin.f90 | 7 +-- src/plastic_nonlocal.f90 | 48 +++++++-------- src/source_damage_isoBrittle.f90 | 7 +-- src/spectral_utilities.f90 | 7 +-- 17 files changed, 123 insertions(+), 173 deletions(-) diff --git a/src/CPFEM.f90 b/src/CPFEM.f90 index 42c41c50c..d34a79bf7 100644 --- a/src/CPFEM.f90 +++ b/src/CPFEM.f90 @@ -259,7 +259,6 @@ subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt restartWrite use math, only: & math_identity2nd, & - math_mul33x33, & math_det33, & math_delta, & math_sym3333to66, & @@ -557,7 +556,7 @@ subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt endif ! translate from P to CS - Kirchhoff = math_mul33x33(materialpoint_P(1:3,1:3,ip,elCP), transpose(materialpoint_F(1:3,1:3,ip,elCP))) + Kirchhoff = matmul(materialpoint_P(1:3,1:3,ip,elCP), transpose(materialpoint_F(1:3,1:3,ip,elCP))) J_inverse = 1.0_pReal / math_det33(materialpoint_F(1:3,1:3,ip,elCP)) CPFEM_cs(1:6,ip,elCP) = math_sym33to6(J_inverse * Kirchhoff,weighted=.false.) diff --git a/src/DAMASK_grid.f90 b/src/DAMASK_grid.f90 index a1241f97f..663921084 100644 --- a/src/DAMASK_grid.f90 +++ b/src/DAMASK_grid.f90 @@ -337,7 +337,7 @@ program DAMASK_spectral endif enddo; write(6,'(/)',advance='no') enddo - if (any(abs(math_mul33x33(newLoadCase%rotation, & + if (any(abs(matmul(newLoadCase%rotation, & transpose(newLoadCase%rotation))-math_I3) > & reshape(spread(tol_math_check,1,9),[ 3,3]))& .or. abs(math_det33(newLoadCase%rotation)) > & diff --git a/src/constitutive.f90 b/src/constitutive.f90 index 96b29d846..4df97b240 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -381,8 +381,6 @@ subroutine constitutive_LpAndItsTangents(Lp, dLp_dS, dLp_dFi, & S, Fi, ipc, ip, el) use prec, only: & pReal - use math, only: & - math_mul33x33 use material, only: & phasememberAt, & phase_plasticity, & @@ -439,7 +437,7 @@ subroutine constitutive_LpAndItsTangents(Lp, dLp_dS, dLp_dFi, & ho = material_homogenizationAt(el) tme = thermalMapping(ho)%p(ip,el) - Mp = math_mul33x33(math_mul33x33(transpose(Fi),Fi),S) + Mp = matmul(matmul(transpose(Fi),Fi),S) plasticityType: select case (phase_plasticity(material_phase(ipc,ip,el))) @@ -483,9 +481,9 @@ subroutine constitutive_LpAndItsTangents(Lp, dLp_dS, dLp_dFi, & #else do concurrent(i = 1_pInt:3_pInt, j = 1_pInt:3_pInt) #endif - dLp_dFi(i,j,1:3,1:3) = math_mul33x33(math_mul33x33(Fi,S),transpose(dLp_dMp(i,j,1:3,1:3))) + & - math_mul33x33(math_mul33x33(Fi,dLp_dMp(i,j,1:3,1:3)),S) - dLp_dS(i,j,1:3,1:3) = math_mul33x33(math_mul33x33(transpose(Fi),Fi),dLp_dMp(i,j,1:3,1:3)) ! ToDo: @PS: why not: dLp_dMp:(FiT Fi) + dLp_dFi(i,j,1:3,1:3) = matmul(matmul(Fi,S),transpose(dLp_dMp(i,j,1:3,1:3))) + & + matmul(matmul(Fi,dLp_dMp(i,j,1:3,1:3)),S) + dLp_dS(i,j,1:3,1:3) = matmul(matmul(transpose(Fi),Fi),dLp_dMp(i,j,1:3,1:3)) ! ToDo: @PS: why not: dLp_dMp:(FiT Fi) #if defined(__INTEL_COMPILER) || defined(__PGI) end forall #else @@ -506,8 +504,7 @@ subroutine constitutive_LiAndItsTangents(Li, dLi_dS, dLi_dFi, & use math, only: & math_I3, & math_inv33, & - math_det33, & - math_mul33x33 + math_det33 use material, only: & phasememberAt, & phase_plasticity, & @@ -591,11 +588,11 @@ subroutine constitutive_LiAndItsTangents(Li, dLi_dS, dLi_dFi, & FiInv = math_inv33(Fi) detFi = math_det33(Fi) - Li = math_mul33x33(math_mul33x33(Fi,Li),FiInv)*detFi !< push forward to intermediate configuration - temp_33 = math_mul33x33(FiInv,Li) + Li = matmul(matmul(Fi,Li),FiInv)*detFi !< push forward to intermediate configuration + temp_33 = matmul(FiInv,Li) do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt - dLi_dS(1:3,1:3,i,j) = math_mul33x33(math_mul33x33(Fi,dLi_dS(1:3,1:3,i,j)),FiInv)*detFi + dLi_dS(1:3,1:3,i,j) = matmul(matmul(Fi,dLi_dS(1:3,1:3,i,j)),FiInv)*detFi dLi_dFi(1:3,1:3,i,j) = dLi_dFi(1:3,1:3,i,j) + Li*FiInv(j,i) dLi_dFi(1:3,i,1:3,j) = dLi_dFi(1:3,i,1:3,j) + math_I3*temp_33(j,i) + Li*FiInv(j,i) end do; end do @@ -689,7 +686,6 @@ subroutine constitutive_hooke_SandItsTangents(S, dS_dFe, dS_dFi, & use prec, only: & pReal use math, only : & - math_mul33x33, & math_mul3333xx33, & math_66toSym3333, & math_I3 @@ -733,14 +729,14 @@ subroutine constitutive_hooke_SandItsTangents(S, dS_dFe, dS_dFi, & end select degradationType enddo DegradationLoop - E = 0.5_pReal*(math_mul33x33(transpose(Fe),Fe)-math_I3) !< Green-Lagrange strain in unloaded configuration - S = math_mul3333xx33(C,math_mul33x33(math_mul33x33(transpose(Fi),E),Fi)) !< 2PK stress in lattice configuration in work conjugate with GL strain pulled back to lattice configuration + E = 0.5_pReal*(matmul(transpose(Fe),Fe)-math_I3) !< Green-Lagrange strain in unloaded configuration + S = math_mul3333xx33(C,matmul(matmul(transpose(Fi),E),Fi)) !< 2PK stress in lattice configuration in work conjugate with GL strain pulled back to lattice configuration dS_dFe = 0.0_pReal forall (i=1_pInt:3_pInt, j=1_pInt:3_pInt) dS_dFe(i,j,1:3,1:3) = & - math_mul33x33(Fe,math_mul33x33(math_mul33x33(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*math_mul33x33(math_mul33x33(E,Fi),C(i,j,1:3,1:3)) !< dS_ij/dFi_kl = C_ijln * E_km * Fe_mn + 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 end forall end subroutine constitutive_hooke_SandItsTangents @@ -756,9 +752,6 @@ subroutine constitutive_collectDotState(S, FeArray, Fi, FpArray, subdt, ipc, ip, debug_level, & debug_constitutive, & debug_levelBasic - use math, only: & - math_mul33x33, & - math_mul33x33 use mesh, only: & theMesh use material, only: & @@ -829,7 +822,7 @@ subroutine constitutive_collectDotState(S, FeArray, Fi, FpArray, subdt, ipc, ip, ho = material_homogenizationAt(el) tme = thermalMapping(ho)%p(ip,el) - Mp = math_mul33x33(math_mul33x33(transpose(Fi),Fi),S) + Mp = matmul(matmul(transpose(Fi),Fi),S) plasticityType: select case (phase_plasticity(material_phase(ipc,ip,el))) @@ -897,8 +890,6 @@ subroutine constitutive_collectDeltaState(S, Fe, Fi, ipc, ip, el) debug_level, & debug_constitutive, & debug_levelBasic - use math, only: & - math_mul33x33 use material, only: & phasememberAt, & phase_plasticityInstance, & @@ -931,7 +922,7 @@ subroutine constitutive_collectDeltaState(S, Fe, Fi, ipc, ip, el) i, & instance, of - Mp = math_mul33x33(math_mul33x33(transpose(Fi),Fi),S) + Mp = matmul(matmul(transpose(Fi),Fi),S) plasticityType: select case (phase_plasticity(material_phase(ipc,ip,el))) @@ -966,8 +957,6 @@ end subroutine constitutive_collectDeltaState function constitutive_postResults(S, Fi, ipc, ip, el) use prec, only: & pReal - use math, only: & - math_mul33x33 use material, only: & phasememberAt, & phase_plasticityInstance, & @@ -1035,7 +1024,7 @@ function constitutive_postResults(S, Fi, ipc, ip, el) constitutive_postResults = 0.0_pReal - Mp = math_mul33x33(math_mul33x33(transpose(Fi),Fi),S) + Mp = matmul(matmul(transpose(Fi),Fi),S) ho = material_homogenizationAt(el) tme = thermalMapping(ho)%p(ip,el) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 55cc553ea..305043606 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -144,8 +144,7 @@ subroutine crystallite_init use math, only: & math_I3, & math_EulerToR, & - math_inv33, & - math_mul33x33 + math_inv33 use mesh, only: & theMesh, & mesh_element @@ -353,7 +352,7 @@ subroutine crystallite_init crystallite_Fi0(1:3,1:3,c,i,e) = constitutive_initialFi(c,i,e) crystallite_F0(1:3,1:3,c,i,e) = math_I3 crystallite_localPlasticity(c,i,e) = phase_localPlasticity(material_phase(c,i,e)) - crystallite_Fe(1:3,1:3,c,i,e) = math_inv33(math_mul33x33(crystallite_Fi0(1:3,1:3,c,i,e), & + crystallite_Fe(1:3,1:3,c,i,e) = math_inv33(matmul(crystallite_Fi0(1:3,1:3,c,i,e), & crystallite_Fp0(1:3,1:3,c,i,e))) ! assuming that euler angles are given in internal strain free configuration crystallite_Fp(1:3,1:3,c,i,e) = crystallite_Fp0(1:3,1:3,c,i,e) crystallite_Fi(1:3,1:3,c,i,e) = crystallite_Fi0(1:3,1:3,c,i,e) @@ -430,8 +429,7 @@ function crystallite_stress(dummyArgumentToPreventInternalCompilerErrorWithGCC) IO_warning, & IO_error use math, only: & - math_inv33, & - math_mul33x33 + math_inv33 use mesh, only: & theMesh, & mesh_element @@ -602,7 +600,7 @@ function crystallite_stress(dummyArgumentToPreventInternalCompilerErrorWithGCC) crystallite_subF(1:3,1:3,c,i,e) = crystallite_subF0(1:3,1:3,c,i,e) & + crystallite_subStep(c,i,e) * (crystallite_partionedF (1:3,1:3,c,i,e) & - crystallite_partionedF0(1:3,1:3,c,i,e)) - crystallite_Fe(1:3,1:3,c,i,e) = math_mul33x33(math_mul33x33(crystallite_subF (1:3,1:3,c,i,e), & + crystallite_Fe(1:3,1:3,c,i,e) = matmul(matmul(crystallite_subF (1:3,1:3,c,i,e), & crystallite_invFp(1:3,1:3,c,i,e)), & crystallite_invFi(1:3,1:3,c,i,e)) crystallite_subdt(c,i,e) = crystallite_subStep(c,i,e) * crystallite_dt(c,i,e) @@ -691,7 +689,6 @@ subroutine crystallite_stressTangent() use math, only: & math_inv33, & math_identity2nd, & - math_mul33x33, & math_3333to99, & math_99to3333, & math_I3, & @@ -753,11 +750,11 @@ subroutine crystallite_stressTangent() lhs_3333 = 0.0_pReal; rhs_3333 = 0.0_pReal do o=1_pInt,3_pInt; do p=1_pInt,3_pInt lhs_3333(1:3,1:3,o,p) = lhs_3333(1:3,1:3,o,p) & - + crystallite_subdt(c,i,e)*math_mul33x33(invSubFi0,dLidFi(1:3,1:3,o,p)) + + crystallite_subdt(c,i,e)*matmul(invSubFi0,dLidFi(1:3,1:3,o,p)) lhs_3333(1:3,o,1:3,p) = lhs_3333(1:3,o,1:3,p) & + crystallite_invFi(1:3,1:3,c,i,e)*crystallite_invFi(p,o,c,i,e) rhs_3333(1:3,1:3,o,p) = rhs_3333(1:3,1:3,o,p) & - - crystallite_subdt(c,i,e)*math_mul33x33(invSubFi0,dLidS(1:3,1:3,o,p)) + - crystallite_subdt(c,i,e)*matmul(invSubFi0,dLidS(1:3,1:3,o,p)) enddo;enddo call math_invert2(temp_99,error,math_3333to99(lhs_3333)) if (error) then @@ -777,19 +774,19 @@ subroutine crystallite_stressTangent() !-------------------------------------------------------------------------------------------------- ! calculate dSdF - temp_33_1 = transpose(math_mul33x33(crystallite_invFp(1:3,1:3,c,i,e), & + temp_33_1 = transpose(matmul(crystallite_invFp(1:3,1:3,c,i,e), & crystallite_invFi(1:3,1:3,c,i,e))) - temp_33_2 = math_mul33x33( crystallite_subF (1:3,1:3,c,i,e), & + temp_33_2 = matmul( crystallite_subF (1:3,1:3,c,i,e), & math_inv33(crystallite_subFp0(1:3,1:3,c,i,e))) - temp_33_3 = math_mul33x33(math_mul33x33(crystallite_subF (1:3,1:3,c,i,e), & + temp_33_3 = matmul(matmul(crystallite_subF (1:3,1:3,c,i,e), & crystallite_invFp (1:3,1:3,c,i,e)), & math_inv33(crystallite_subFi0(1:3,1:3,c,i,e))) forall(p=1_pInt:3_pInt, o=1_pInt:3_pInt) - rhs_3333(p,o,1:3,1:3) = math_mul33x33(dSdFe(p,o,1:3,1:3),temp_33_1) - temp_3333(1:3,1:3,p,o) = math_mul33x33(math_mul33x33(temp_33_2,dLpdS(1:3,1:3,p,o)), & + rhs_3333(p,o,1:3,1:3) = matmul(dSdFe(p,o,1:3,1:3),temp_33_1) + temp_3333(1:3,1:3,p,o) = matmul(matmul(temp_33_2,dLpdS(1:3,1:3,p,o)), & crystallite_invFi(1:3,1:3,c,i,e)) & - + math_mul33x33(temp_33_3,dLidS(1:3,1:3,p,o)) + + matmul(temp_33_3,dLidS(1:3,1:3,p,o)) end forall lhs_3333 = crystallite_subdt(c,i,e)*math_mul3333xx3333(dSdFe,temp_3333) & + math_mul3333xx3333(dSdFi,dFidS) @@ -809,20 +806,20 @@ subroutine crystallite_stressTangent() forall(p=1_pInt:3_pInt, o=1_pInt:3_pInt) dFpinvdF(1:3,1:3,p,o) & = -crystallite_subdt(c,i,e) & - * math_mul33x33(math_inv33(crystallite_subFp0(1:3,1:3,c,i,e)), & - math_mul33x33(temp_3333(1:3,1:3,p,o),crystallite_invFi(1:3,1:3,c,i,e))) + * matmul(math_inv33(crystallite_subFp0(1:3,1:3,c,i,e)), & + matmul(temp_3333(1:3,1:3,p,o),crystallite_invFi(1:3,1:3,c,i,e))) end forall !-------------------------------------------------------------------------------------------------- ! assemble dPdF - temp_33_1 = math_mul33x33(crystallite_invFp(1:3,1:3,c,i,e), & - math_mul33x33(crystallite_S(1:3,1:3,c,i,e), & + temp_33_1 = matmul(crystallite_invFp(1:3,1:3,c,i,e), & + matmul(crystallite_S(1:3,1:3,c,i,e), & transpose(crystallite_invFp(1:3,1:3,c,i,e)))) - temp_33_2 = math_mul33x33(crystallite_S(1:3,1:3,c,i,e), & + temp_33_2 = matmul(crystallite_S(1:3,1:3,c,i,e), & transpose(crystallite_invFp(1:3,1:3,c,i,e))) - temp_33_3 = math_mul33x33(crystallite_subF(1:3,1:3,c,i,e), & + temp_33_3 = matmul(crystallite_subF(1:3,1:3,c,i,e), & crystallite_invFp(1:3,1:3,c,i,e)) - temp_33_4 = math_mul33x33(math_mul33x33(crystallite_subF(1:3,1:3,c,i,e), & + temp_33_4 = matmul(matmul(crystallite_subF(1:3,1:3,c,i,e), & crystallite_invFp(1:3,1:3,c,i,e)), & crystallite_S(1:3,1:3,c,i,e)) @@ -832,9 +829,9 @@ subroutine crystallite_stressTangent() enddo forall(p=1_pInt:3_pInt, o=1_pInt:3_pInt) crystallite_dPdF(1:3,1:3,p,o,c,i,e) = crystallite_dPdF(1:3,1:3,p,o,c,i,e) + & - math_mul33x33(math_mul33x33(crystallite_subF(1:3,1:3,c,i,e),dFpinvdF(1:3,1:3,p,o)),temp_33_2) + & - math_mul33x33(math_mul33x33(temp_33_3,dSdF(1:3,1:3,p,o)),transpose(crystallite_invFp(1:3,1:3,c,i,e))) + & - math_mul33x33(temp_33_4,transpose(dFpinvdF(1:3,1:3,p,o))) + matmul(matmul(crystallite_subF(1:3,1:3,c,i,e),dFpinvdF(1:3,1:3,p,o)),temp_33_2) + & + matmul(matmul(temp_33_3,dSdF(1:3,1:3,p,o)),transpose(crystallite_invFp(1:3,1:3,c,i,e))) + & + matmul(temp_33_4,transpose(dFpinvdF(1:3,1:3,p,o))) end forall enddo; enddo @@ -895,7 +892,6 @@ end subroutine crystallite_orientations !-------------------------------------------------------------------------------------------------- function crystallite_push33ToRef(ipc,ip,el, tensor33) use math, only: & - math_mul33x33, & math_inv33, & math_EulerToR use material, only: & @@ -910,9 +906,9 @@ function crystallite_push33ToRef(ipc,ip,el, tensor33) ip, & ! integration point index ipc ! grain index - T = math_mul33x33(math_EulerToR(material_EulerAngles(1:3,ipc,ip,el)), & + T = matmul(math_EulerToR(material_EulerAngles(1:3,ipc,ip,el)), & transpose(math_inv33(crystallite_subF(1:3,1:3,ipc,ip,el)))) - crystallite_push33ToRef = math_mul33x33(transpose(T),math_mul33x33(tensor33,T)) + crystallite_push33ToRef = matmul(transpose(T),matmul(tensor33,T)) end function crystallite_push33ToRef @@ -924,7 +920,6 @@ function crystallite_postResults(ipc, ip, el) use math, only: & math_qToEuler, & math_qToEulerAxisAngle, & - math_mul33x33, & math_det33, & math_I3, & inDeg @@ -1093,11 +1088,7 @@ logical function integrateStress(& use constitutive, only: constitutive_LpAndItsTangents, & constitutive_LiAndItsTangents, & constitutive_SandItsTangents - use math, only: math_mul33x33, & -#ifdef __PGI - norm2, & -#endif - math_mul33xx33, & + use math, only: math_mul33xx33, & math_mul3333xx3333, & math_inv33, & math_det33, & @@ -1203,7 +1194,7 @@ logical function integrateStress(& #endif return endif failedInversionFp - A = math_mul33x33(Fg_new,invFp_current) ! intermediate tensor needed later to calculate dFe_dLp + A = matmul(Fg_new,invFp_current) ! intermediate tensor needed later to calculate dFe_dLp invFi_current = math_inv33(crystallite_subFi0(1:3,1:3,ipc,ip,el)) failedInversionFi: if (all(dEq0(invFi_current))) then @@ -1235,7 +1226,7 @@ logical function integrateStress(& return endif LiLoopLimit - invFi_new = math_mul33x33(invFi_current,math_I3 - dt*Liguess) + invFi_new = matmul(invFi_current,math_I3 - dt*Liguess) Fi_new = math_inv33(invFi_new) detInvFi = math_det33(invFi_new) @@ -1260,7 +1251,7 @@ logical function integrateStress(& !* calculate (elastic) 2nd Piola--Kirchhoff stress tensor and its tangent from constitutive law B = math_I3 - dt*Lpguess - Fe = math_mul33x33(math_mul33x33(A,B), invFi_new) + Fe = matmul(matmul(A,B), invFi_new) call constitutive_SandItsTangents(S, dS_dFe, dS_dFi, & Fe, Fi_new, ipc, ip, el) ! call constitutive law to calculate 2nd Piola-Kirchhoff stress and its derivative in unloaded configuration @@ -1406,13 +1397,13 @@ logical function integrateStress(& !* calculate Jacobian for correction term if (mod(jacoCounterLi, iJacoLpresiduum) == 0_pInt) then - temp_33 = math_mul33x33(math_mul33x33(A,B),invFi_current) + temp_33 = matmul(matmul(A,B),invFi_current) forall(o=1_pInt:3_pInt,p=1_pInt:3_pInt) dFe_dLi(1:3,o,1:3,p) = -dt*math_I3(o,p)*temp_33 ! dFe_dLp(i,j,k,l) = -dt * A(i,k) invFi(l,j) dFi_dLi(1:3,o,1:3,p) = -dt*math_I3(o,p)*invFi_current end forall forall(o=1_pInt:3_pInt,p=1_pInt:3_pInt) & - dFi_dLi(1:3,1:3,o,p) = math_mul33x33(math_mul33x33(Fi_new,dFi_dLi(1:3,1:3,o,p)),Fi_new) + dFi_dLi(1:3,1:3,o,p) = matmul(matmul(Fi_new,dFi_dLi(1:3,1:3,o,p)),Fi_new) dRLi_dLi = math_identity2nd(9_pInt) & - math_3333to99(math_mul3333xx3333(dLi_dS, math_mul3333xx3333(dS_dFe, dFe_dLi) + & @@ -1449,7 +1440,7 @@ logical function integrateStress(& enddo LiLoop !* calculate new plastic and elastic deformation gradient - invFp_new = math_mul33x33(invFp_current,B) + invFp_new = matmul(invFp_current,B) invFp_new = invFp_new / math_det33(invFp_new)**(1.0_pReal/3.0_pReal) ! regularize Fp_new = math_inv33(invFp_new) failedInversionInvFp: if (all(dEq0(Fp_new))) then @@ -1465,13 +1456,13 @@ logical function integrateStress(& #endif return endif failedInversionInvFp - Fe_new = math_mul33x33(math_mul33x33(Fg_new,invFp_new),invFi_new) + Fe_new = matmul(matmul(Fg_new,invFp_new),invFi_new) !-------------------------------------------------------------------------------------------------- ! stress integration was successful integrateStress = .true. - crystallite_P (1:3,1:3,ipc,ip,el) = math_mul33x33(math_mul33x33(Fg_new,invFp_new), & - math_mul33x33(S,transpose(invFp_new))) + crystallite_P (1:3,1:3,ipc,ip,el) = matmul(matmul(Fg_new,invFp_new), & + matmul(S,transpose(invFp_new))) crystallite_S (1:3,1:3,ipc,ip,el) = S crystallite_Lp (1:3,1:3,ipc,ip,el) = Lpguess crystallite_Li (1:3,1:3,ipc,ip,el) = Liguess @@ -1489,9 +1480,9 @@ logical function integrateStress(& write(6,'(a,/,3(12x,3(f12.7,1x)/))') '<< CRYST integrateStress >> P / MPa', & transpose(crystallite_P(1:3,1:3,ipc,ip,el))*1.0e-6_pReal write(6,'(a,/,3(12x,3(f12.7,1x)/))') '<< CRYST integrateStress >> Cauchy / MPa', & - math_mul33x33(crystallite_P(1:3,1:3,ipc,ip,el), transpose(Fg_new)) * 1.0e-6_pReal / math_det33(Fg_new) + matmul(crystallite_P(1:3,1:3,ipc,ip,el), transpose(Fg_new)) * 1.0e-6_pReal / math_det33(Fg_new) write(6,'(a,/,3(12x,3(f12.7,1x)/))') '<< CRYST integrateStress >> Fe Lp Fe^-1', & - transpose(math_mul33x33(Fe_new, math_mul33x33(crystallite_Lp(1:3,1:3,ipc,ip,el), math_inv33(Fe_new)))) + transpose(matmul(Fe_new, matmul(crystallite_Lp(1:3,1:3,ipc,ip,el), math_inv33(Fe_new)))) write(6,'(a,/,3(12x,3(f12.7,1x)/))') '<< CRYST integrateStress >> Fp',transpose(crystallite_Fp(1:3,1:3,ipc,ip,el)) write(6,'(a,/,3(12x,3(f12.7,1x)/))') '<< CRYST integrateStress >> Fi',transpose(crystallite_Fi(1:3,1:3,ipc,ip,el)) endif diff --git a/src/grid_damage_spectral.f90 b/src/grid_damage_spectral.f90 index 1ce6e0c45..2019664e2 100644 --- a/src/grid_damage_spectral.f90 +++ b/src/grid_damage_spectral.f90 @@ -286,8 +286,6 @@ subroutine formResidual(in,x_scal,f_scal,dummy,ierr) use mesh, only: & grid, & grid3 - use math, only: & - math_mul33x3 use spectral_utilities, only: & scalarField_real, & vectorField_real, & @@ -328,7 +326,7 @@ subroutine formResidual(in,x_scal,f_scal,dummy,ierr) cell = 0 do k = 1, grid3; do j = 1, grid(2); do i = 1,grid(1) cell = cell + 1 - vectorField_real(1:3,i,j,k) = math_mul33x3(damage_nonlocal_getDiffusion33(1,cell) - D_ref, & + vectorField_real(1:3,i,j,k) = matmul(damage_nonlocal_getDiffusion33(1,cell) - D_ref, & vectorField_real(1:3,i,j,k)) enddo; enddo; enddo call utilities_FFTvectorForward diff --git a/src/grid_mech_FEM.f90 b/src/grid_mech_FEM.f90 index 099d71d33..82273c8f1 100644 --- a/src/grid_mech_FEM.f90 +++ b/src/grid_mech_FEM.f90 @@ -316,7 +316,6 @@ end function grid_mech_FEM_solution !-------------------------------------------------------------------------------------------------- subroutine grid_mech_FEM_forward(guess,timeinc,timeinc_old,loadCaseTime,deformation_BC,stress_BC,rotation_BC) use math, only: & - math_mul33x33 ,& math_rotate_backward33 use numerics, only: & worldrank @@ -402,7 +401,7 @@ subroutine grid_mech_FEM_forward(guess,timeinc,timeinc_old,loadCaseTime,deformat ! calculate rate for aim if (deformation_BC%myType=='l') then ! calculate F_aimDot from given L and current F F_aimDot = & - F_aimDot + deformation_BC%maskFloat * math_mul33x33(deformation_BC%values, F_aim_lastInc) + F_aimDot + deformation_BC%maskFloat * matmul(deformation_BC%values, F_aim_lastInc) elseif(deformation_BC%myType=='fdot') then ! F_aimDot is prescribed F_aimDot = & F_aimDot + deformation_BC%maskFloat * deformation_BC%values diff --git a/src/grid_mech_spectral_basic.f90 b/src/grid_mech_spectral_basic.f90 index f17f2f8fd..99839e50f 100644 --- a/src/grid_mech_spectral_basic.f90 +++ b/src/grid_mech_spectral_basic.f90 @@ -285,7 +285,6 @@ end function grid_mech_spectral_basic_solution !-------------------------------------------------------------------------------------------------- subroutine grid_mech_spectral_basic_forward(guess,timeinc,timeinc_old,loadCaseTime,deformation_BC,stress_BC,rotation_BC) use math, only: & - math_mul33x33 ,& math_rotate_backward33 use numerics, only: & worldrank @@ -370,7 +369,7 @@ subroutine grid_mech_spectral_basic_forward(guess,timeinc,timeinc_old,loadCaseTi ! calculate rate for aim if (deformation_BC%myType=='l') then ! calculate F_aimDot from given L and current F F_aimDot = & - F_aimDot + deformation_BC%maskFloat * math_mul33x33(deformation_BC%values, F_aim_lastInc) + F_aimDot + deformation_BC%maskFloat * matmul(deformation_BC%values, F_aim_lastInc) elseif(deformation_BC%myType=='fdot') then ! F_aimDot is prescribed F_aimDot = & F_aimDot + deformation_BC%maskFloat * deformation_BC%values diff --git a/src/grid_mech_spectral_polarisation.f90 b/src/grid_mech_spectral_polarisation.f90 index 0a5501e98..aff4913b1 100644 --- a/src/grid_mech_spectral_polarisation.f90 +++ b/src/grid_mech_spectral_polarisation.f90 @@ -308,7 +308,6 @@ end function grid_mech_spectral_polarisation_solution !-------------------------------------------------------------------------------------------------- subroutine grid_mech_spectral_polarisation_forward(guess,timeinc,timeinc_old,loadCaseTime,deformation_BC,stress_BC,rotation_BC) use math, only: & - math_mul33x33, & math_mul3333xx33, & math_rotate_backward33 use numerics, only: & @@ -402,7 +401,7 @@ subroutine grid_mech_spectral_polarisation_forward(guess,timeinc,timeinc_old,loa ! calculate rate for aim if (deformation_BC%myType=='l') then ! calculate F_aimDot from given L and current F F_aimDot = & - F_aimDot + deformation_BC%maskFloat * math_mul33x33(deformation_BC%values, F_aim_lastInc) + F_aimDot + deformation_BC%maskFloat * matmul(deformation_BC%values, F_aim_lastInc) elseif(deformation_BC%myType=='fdot') then ! F_aimDot is prescribed F_aimDot = & F_aimDot + deformation_BC%maskFloat * deformation_BC%values @@ -435,9 +434,9 @@ subroutine grid_mech_spectral_polarisation_forward(guess,timeinc,timeinc_old,loa else do k = 1, grid3; do j = 1, grid(2); do i = 1, grid(1) F_lambda33 = reshape(F_tau(1:9,i,j,k)-F(1:9,i,j,k),[3,3]) - F_lambda33 = math_mul3333xx33(S_scale,math_mul33x33(F_lambda33, & + F_lambda33 = math_mul3333xx33(S_scale,matmul(F_lambda33, & math_mul3333xx33(C_scale,& - math_mul33x33(transpose(F_lambda33),& + matmul(transpose(F_lambda33),& F_lambda33)-math_I3))*0.5_pReal)& + math_I3 F_tau(1:9,i,j,k) = reshape(F_lambda33,[9])+F(1:9,i,j,k) @@ -528,8 +527,7 @@ subroutine formResidual(in, FandF_tau, & math_rotate_forward33, & math_rotate_backward33, & math_mul3333xx33, & - math_invSym3333, & - math_mul33x33 + math_invSym3333 use debug, only: & debug_level, & debug_spectral, & @@ -605,7 +603,7 @@ subroutine formResidual(in, FandF_tau, & do k = 1, grid3; do j = 1, grid(2); do i = 1, grid(1) tensorField_real(1:3,1:3,i,j,k) = & polarBeta*math_mul3333xx33(C_scale,F(1:3,1:3,i,j,k) - math_I3) -& - polarAlpha*math_mul33x33(F(1:3,1:3,i,j,k), & + polarAlpha*matmul(F(1:3,1:3,i,j,k), & math_mul3333xx33(C_scale,F_tau(1:3,1:3,i,j,k) - F(1:3,1:3,i,j,k) - math_I3)) enddo; enddo; enddo @@ -644,7 +642,7 @@ subroutine formResidual(in, FandF_tau, & e = e + 1 residual_F(1:3,1:3,i,j,k) = & math_mul3333xx33(math_invSym3333(materialpoint_dPdF(1:3,1:3,1:3,1:3,1,e) + C_scale), & - residual_F(1:3,1:3,i,j,k) - math_mul33x33(F(1:3,1:3,i,j,k), & + residual_F(1:3,1:3,i,j,k) - matmul(F(1:3,1:3,i,j,k), & math_mul3333xx33(C_scale,F_tau(1:3,1:3,i,j,k) - F(1:3,1:3,i,j,k) - math_I3))) & + residual_F_tau(1:3,1:3,i,j,k) enddo; enddo; enddo diff --git a/src/grid_thermal_spectral.f90 b/src/grid_thermal_spectral.f90 index 69e23c86b..adaf0d429 100644 --- a/src/grid_thermal_spectral.f90 +++ b/src/grid_thermal_spectral.f90 @@ -295,8 +295,6 @@ subroutine formResidual(in,x_scal,f_scal,dummy,ierr) use mesh, only: & grid, & grid3 - use math, only: & - math_mul33x3 use spectral_utilities, only: & scalarField_real, & vectorField_real, & @@ -338,7 +336,7 @@ subroutine formResidual(in,x_scal,f_scal,dummy,ierr) cell = 0 do k = 1, grid3; do j = 1, grid(2); do i = 1,grid(1) cell = cell + 1 - vectorField_real(1:3,i,j,k) = math_mul33x3(thermal_conduction_getConductivity33(1,cell) - D_ref, & + vectorField_real(1:3,i,j,k) = matmul(thermal_conduction_getConductivity33(1,cell) - D_ref, & vectorField_real(1:3,i,j,k)) enddo; enddo; enddo call utilities_FFTvectorForward diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 1a170c66c..6a513193b 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -932,8 +932,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- function surfaceCorrection(avgF,instance,of) use math, only: & - math_invert33, & - math_mul33x33 + math_invert33 implicit none real(pReal), dimension(3) :: surfaceCorrection @@ -947,7 +946,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) integer(pInt) :: i,j,iBase logical :: error - call math_invert33(math_mul33x33(transpose(avgF),avgF),invC,detF,error) + call math_invert33(matmul(transpose(avgF),avgF),invC,detF,error) surfaceCorrection = 0.0_pReal do iBase = 1_pInt,3_pInt @@ -1139,8 +1138,6 @@ end function relaxationVector !> @brief identify the normal of an interface !-------------------------------------------------------------------------------------------------- pure function interfaceNormal(intFace,instance,of) - use math, only: & - math_mul33x3 implicit none real(pReal), dimension (3) :: interfaceNormal @@ -1156,7 +1153,7 @@ pure function interfaceNormal(intFace,instance,of) nPos = abs(intFace(1)) ! identify the position of the interface in global state array interfaceNormal(nPos) = real(intFace(1)/abs(intFace(1)),pReal) ! get the normal vector w.r.t. cluster axis - interfaceNormal = math_mul33x3(dependentState(instance)%orientation(1:3,1:3,of),interfaceNormal) ! map the normal vector into sample coordinate system (basis) + interfaceNormal = matmul(dependentState(instance)%orientation(1:3,1:3,of),interfaceNormal) ! map the normal vector into sample coordinate system (basis) end function interfaceNormal diff --git a/src/lattice.f90 b/src/lattice.f90 index d3d2b3ce5..6c5a709e4 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -655,7 +655,6 @@ subroutine lattice_initializeStructure(myPhase,CoverA) use prec, only: & tol_math_check use math, only: & - math_mul33x33, & math_sym3333to66, & math_Voigt66to3333, & math_cross @@ -1141,8 +1140,7 @@ function lattice_C66_trans(Ntrans,C_parent66,structure_target, & math_axisAngleToR, & math_sym3333to66, & math_66toSym3333, & - math_rotate_forward3333, & - math_mul33x33 + math_rotate_forward3333 implicit none integer, dimension(:), intent(in) :: Ntrans !< number of active twin systems per family @@ -1210,7 +1208,6 @@ function lattice_nonSchmidMatrix(Nslip,nonSchmidCoefficients,sense) result(nonSc INRAD, & math_outer, & math_cross, & - math_mul33x3, & math_axisAngleToR implicit none integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family @@ -1232,7 +1229,7 @@ function lattice_nonSchmidMatrix(Nslip,nonSchmidCoefficients,sense) result(nonSc do i = 1,sum(Nslip) direction = coordinateSystem(1:3,1,i) normal = coordinateSystem(1:3,2,i) - np = math_mul33x3(math_axisAngleToR(direction,60.0_pReal*INRAD), normal) + np = matmul(math_axisAngleToR(direction,60.0_pReal*INRAD), normal) if (size(nonSchmidCoefficients)>0) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) & + nonSchmidCoefficients(1) * math_outer(direction, np) if (size(nonSchmidCoefficients)>1) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) & @@ -2401,8 +2398,6 @@ subroutine buildTransformationSystem(Q,S,Ntrans,cOverA,a_fcc,a_bcc) use math, only: & math_cross, & math_outer, & - math_mul33x33, & - math_mul33x3, & math_axisAngleToR, & INRAD, & MATH_I3 @@ -2508,8 +2503,8 @@ subroutine buildTransformationSystem(Q,S,Ntrans,cOverA,a_fcc,a_bcc) U = (a_bcc/a_fcc)*math_outer(x,x) & + (a_bcc/a_fcc)*math_outer(y,y) * sqrt(2.0_pReal) & + (a_bcc/a_fcc)*math_outer(z,z) * sqrt(2.0_pReal) - Q(1:3,1:3,i) = math_mul33x33(R,B) - S(1:3,1:3,i) = math_mul33x33(R,U) - MATH_I3 + Q(1:3,1:3,i) = matmul(R,B) + S(1:3,1:3,i) = matmul(R,U) - MATH_I3 enddo elseif (cOverA > 0.0_pReal .and. dEq0(a_bcc)) then ! fcc -> hex transformation ss = MATH_I3 @@ -2525,7 +2520,7 @@ subroutine buildTransformationSystem(Q,S,Ntrans,cOverA,a_fcc,a_bcc) Q(1:3,1,i) = x Q(1:3,2,i) = y Q(1:3,3,i) = z - S(1:3,1:3,i) = math_mul33x33(Q(1:3,1:3,i), math_mul33x33(math_mul33x33(sd,ss), transpose(Q(1:3,1:3,i)))) - MATH_I3 ! ToDo: This is of interest for the Schmid matrix only + S(1:3,1:3,i) = matmul(Q(1:3,1:3,i), matmul(matmul(sd,ss), transpose(Q(1:3,1:3,i)))) - MATH_I3 ! ToDo: This is of interest for the Schmid matrix only enddo else call IO_error(0) !ToDo: define error diff --git a/src/math.f90 b/src/math.f90 index 8c0020799..5ee50cbfc 100644 --- a/src/math.f90 +++ b/src/math.f90 @@ -277,7 +277,7 @@ subroutine math_check ! +++ check rotation sense of q and R +++ v = halton([2,8,5]) ! random vector R = math_qToR(q) - if (any(abs(math_mul33x3(R,v) - math_qRot(q,v)) > tol_math_check)) then + if (any(abs(matmul(R,v) - math_qRot(q,v)) > tol_math_check)) then write (error_msg, '(a)' ) 'R(q)*v has different sense than q*v' call IO_error(401,ext_msg=error_msg) endif @@ -700,7 +700,7 @@ pure function math_exp33(A,n) do i = 1, merge(n,5,present(n)) invFac = invFac/real(i,pReal) ! invfac = 1/i! - B = math_mul33x33(B,A) + B = matmul(B,A) math_exp33 = math_exp33 + invFac*B ! exp = SUM (A^i)/i! enddo @@ -1754,7 +1754,7 @@ real(pReal) pure function math_EulerMisorientation(EulerA,EulerB) real(pReal), dimension(3), intent(in) :: EulerA,EulerB real(pReal) :: cosTheta - cosTheta = (math_trace33(math_mul33x33(math_EulerToR(EulerB), & + cosTheta = (math_trace33(matmul(math_EulerToR(EulerB), & transpose(math_EulerToR(EulerA)))) - 1.0_pReal) * 0.5_pReal math_EulerMisorientation = acos(math_clip(cosTheta,-1.0_pReal,1.0_pReal)) @@ -1807,7 +1807,7 @@ function math_sampleGaussOri(center,FWHM) angle = math_EulerMisorientation([0.0_pReal,0.0_pReal,0.0_pReal],math_RtoEuler(R)) if (rnd(4) <= exp(-4.0_pReal*log(2.0_pReal)*(angle/FWHM)**2_pReal)) exit ! rejection sampling (Gaussian) enddo GaussConvolution - math_sampleGaussOri = math_RtoEuler(math_mul33x33(R,math_EulerToR(center))) + math_sampleGaussOri = math_RtoEuler(matmul(R,math_EulerToR(center))) endif end function math_sampleGaussOri @@ -1842,7 +1842,7 @@ function math_sampleFiberOri(alpha,beta,FWHM) R = math_EulerAxisAngleToR(math_crossproduct(fInC,fInS),-acos(dot_product(fInC,fInS))) !< rotation to align fiber axis in crystal and sample system rnd = halton([7,10,3]) - R = math_mul33x33(R,math_EulerAxisAngleToR(fInS,rnd(1)*2.0_pReal*PI)) !< additional rotation (0..360deg) perpendicular to fiber axis + R = matmul(R,math_EulerAxisAngleToR(fInS,rnd(1)*2.0_pReal*PI)) !< additional rotation (0..360deg) perpendicular to fiber axis if (FWHM > 0.1_pReal*INRAD) then reducedTo2D: do i=1,3 @@ -1863,7 +1863,7 @@ function math_sampleFiberOri(alpha,beta,FWHM) u(j) = fInS(j) rejectionSampling: if (rnd(3) <= exp(-4.0_pReal*log(2.0_pReal)*(angle/FWHM)**2_pReal)) then - R = math_mul33x33(R,math_EulerAxisAngleToR(math_crossproduct(u,fInS),angle)) ! tilt around direction of smallest component + R = matmul(R,math_EulerAxisAngleToR(math_crossproduct(u,fInS),angle)) ! tilt around direction of smallest component exit endif rejectionSampling rnd = halton([7,10,3]) @@ -2079,23 +2079,23 @@ pure function math_eigenvectorBasisSym33(m) N(1:3,1:3,2) = m-values(2)*math_I3 N(1:3,1:3,3) = m-values(3)*math_I3 twoSimilarEigenvalues: if(abs(values(1)-values(2)) < TOL) then - EB(1:3,1:3,3)=math_mul33x33(N(1:3,1:3,1),N(1:3,1:3,2))/ & + EB(1:3,1:3,3)=matmul(N(1:3,1:3,1),N(1:3,1:3,2))/ & ((values(3)-values(1))*(values(3)-values(2))) EB(1:3,1:3,1)=math_I3-EB(1:3,1:3,3) elseif(abs(values(2)-values(3)) < TOL) then twoSimilarEigenvalues - EB(1:3,1:3,1)=math_mul33x33(N(1:3,1:3,2),N(1:3,1:3,3))/ & + EB(1:3,1:3,1)=matmul(N(1:3,1:3,2),N(1:3,1:3,3))/ & ((values(1)-values(2))*(values(1)-values(3))) EB(1:3,1:3,2)=math_I3-EB(1:3,1:3,1) elseif(abs(values(3)-values(1)) < TOL) then twoSimilarEigenvalues - EB(1:3,1:3,2)=math_mul33x33(N(1:3,1:3,1),N(1:3,1:3,3))/ & + EB(1:3,1:3,2)=matmul(N(1:3,1:3,1),N(1:3,1:3,3))/ & ((values(2)-values(1))*(values(2)-values(3))) EB(1:3,1:3,1)=math_I3-EB(1:3,1:3,2) else twoSimilarEigenvalues - EB(1:3,1:3,1)=math_mul33x33(N(1:3,1:3,2),N(1:3,1:3,3))/ & + EB(1:3,1:3,1)=matmul(N(1:3,1:3,2),N(1:3,1:3,3))/ & ((values(1)-values(2))*(values(1)-values(3))) - EB(1:3,1:3,2)=math_mul33x33(N(1:3,1:3,1),N(1:3,1:3,3))/ & + EB(1:3,1:3,2)=matmul(N(1:3,1:3,1),N(1:3,1:3,3))/ & ((values(2)-values(1))*(values(2)-values(3))) - EB(1:3,1:3,3)=math_mul33x33(N(1:3,1:3,1),N(1:3,1:3,2))/ & + EB(1:3,1:3,3)=matmul(N(1:3,1:3,1),N(1:3,1:3,2))/ & ((values(3)-values(1))*(values(3)-values(2))) endif twoSimilarEigenvalues endif threeSimilarEigenvalues @@ -2144,23 +2144,23 @@ pure function math_eigenvectorBasisSym33_log(m) N(1:3,1:3,2) = m-values(2)*math_I3 N(1:3,1:3,3) = m-values(3)*math_I3 twoSimilarEigenvalues: if(abs(values(1)-values(2)) < TOL) then - EB(1:3,1:3,3)=math_mul33x33(N(1:3,1:3,1),N(1:3,1:3,2))/ & + EB(1:3,1:3,3)=matmul(N(1:3,1:3,1),N(1:3,1:3,2))/ & ((values(3)-values(1))*(values(3)-values(2))) EB(1:3,1:3,1)=math_I3-EB(1:3,1:3,3) elseif(abs(values(2)-values(3)) < TOL) then twoSimilarEigenvalues - EB(1:3,1:3,1)=math_mul33x33(N(1:3,1:3,2),N(1:3,1:3,3))/ & + EB(1:3,1:3,1)=matmul(N(1:3,1:3,2),N(1:3,1:3,3))/ & ((values(1)-values(2))*(values(1)-values(3))) EB(1:3,1:3,2)=math_I3-EB(1:3,1:3,1) elseif(abs(values(3)-values(1)) < TOL) then twoSimilarEigenvalues - EB(1:3,1:3,2)=math_mul33x33(N(1:3,1:3,1),N(1:3,1:3,3))/ & + EB(1:3,1:3,2)=matmul(N(1:3,1:3,1),N(1:3,1:3,3))/ & ((values(2)-values(1))*(values(2)-values(3))) EB(1:3,1:3,1)=math_I3-EB(1:3,1:3,2) else twoSimilarEigenvalues - EB(1:3,1:3,1)=math_mul33x33(N(1:3,1:3,2),N(1:3,1:3,3))/ & + EB(1:3,1:3,1)=matmul(N(1:3,1:3,2),N(1:3,1:3,3))/ & ((values(1)-values(2))*(values(1)-values(3))) - EB(1:3,1:3,2)=math_mul33x33(N(1:3,1:3,1),N(1:3,1:3,3))/ & + EB(1:3,1:3,2)=matmul(N(1:3,1:3,1),N(1:3,1:3,3))/ & ((values(2)-values(1))*(values(2)-values(3))) - EB(1:3,1:3,3)=math_mul33x33(N(1:3,1:3,1),N(1:3,1:3,2))/ & + EB(1:3,1:3,3)=matmul(N(1:3,1:3,1),N(1:3,1:3,2))/ & ((values(3)-values(1))*(values(3)-values(2))) endif twoSimilarEigenvalues endif threeSimilarEigenvalues @@ -2186,14 +2186,14 @@ function math_rotationalPart33(m) real(pReal), dimension(3,3) :: math_rotationalPart33 real(pReal), dimension(3,3) :: U , Uinv - U = math_eigenvectorBasisSym33(math_mul33x33(transpose(m),m)) + U = math_eigenvectorBasisSym33(matmul(transpose(m),m)) Uinv = math_inv33(U) inversionFailed: if (all(dEq0(Uinv))) then math_rotationalPart33 = math_I3 call IO_warning(650) else inversionFailed - math_rotationalPart33 = math_mul33x33(m,Uinv) + math_rotationalPart33 = matmul(m,Uinv) endif inversionFailed end function math_rotationalPart33 @@ -2586,7 +2586,7 @@ pure function math_rotate_forward33(tensor,rot_tensor) real(pReal), dimension(3,3) :: math_rotate_forward33 real(pReal), dimension(3,3), intent(in) :: tensor, rot_tensor - math_rotate_forward33 = math_mul33x33(rot_tensor,math_mul33x33(tensor,transpose(rot_tensor))) + math_rotate_forward33 = matmul(rot_tensor,matmul(tensor,transpose(rot_tensor))) end function math_rotate_forward33 @@ -2600,7 +2600,7 @@ pure function math_rotate_backward33(tensor,rot_tensor) real(pReal), dimension(3,3) :: math_rotate_backward33 real(pReal), dimension(3,3), intent(in) :: tensor, rot_tensor - math_rotate_backward33 = math_mul33x33(transpose(rot_tensor),math_mul33x33(tensor,rot_tensor)) + math_rotate_backward33 = matmul(transpose(rot_tensor),matmul(tensor,rot_tensor)) end function math_rotate_backward33 diff --git a/src/mesh_grid.f90 b/src/mesh_grid.f90 index 38abad1aa..95d8e5b27 100644 --- a/src/mesh_grid.f90 +++ b/src/mesh_grid.f90 @@ -561,8 +561,6 @@ function mesh_nodesAroundCentres(gDim,Favg,centres) result(nodes) debug_mesh, & debug_level, & debug_levelBasic - use math, only: & - math_mul33x3 implicit none real(pReal), intent(in), dimension(:,:,:,:) :: & @@ -624,7 +622,7 @@ function mesh_nodesAroundCentres(gDim,Favg,centres) result(nodes) lookup = me-diag+shift*iRes wrappedCentres(1:3,i+1_pInt, j+1_pInt, k+1_pInt) = & centres(1:3,lookup(1)+1_pInt,lookup(2)+1_pInt,lookup(3)+1_pInt) & - - math_mul33x3(Favg, real(shift,pReal)*gDim) + - matmul(Favg, real(shift,pReal)*gDim) endif enddo; enddo; enddo diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index a0a996dd6..cb13265b4 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -651,8 +651,7 @@ subroutine plastic_dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,T,instance,of) math_eigenValuesVectorsSym, & math_outer, & math_symmetric33, & - math_mul33xx33, & - math_mul33x3 + math_mul33xx33 implicit none real(pReal), dimension(3,3), intent(out) :: Lp @@ -723,8 +722,8 @@ subroutine plastic_dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,T,instance,of) call math_eigenValuesVectorsSym(Mp,eigValues,eigVectors,error) do i = 1,6 - P_sb = 0.5_pReal * math_outer(math_mul33x3(eigVectors,sb_sComposition(1:3,i)),& - math_mul33x3(eigVectors,sb_mComposition(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_mul33xx33(Mp,P_sb) significantShearBandStress: if (abs(tau) > tol_math_check) then diff --git a/src/plastic_nonlocal.f90 b/src/plastic_nonlocal.f90 index f0b28d711..94f0fde04 100644 --- a/src/plastic_nonlocal.f90 +++ b/src/plastic_nonlocal.f90 @@ -838,8 +838,7 @@ subroutine plastic_nonlocal_dependentState(Fe, Fp, ip, el) IO_error use math, only: & PI, & - math_mul33x3, & - math_mul3x3, & + math_inner, & math_inv33 #ifdef DEBUG use debug, only: & @@ -1004,10 +1003,10 @@ subroutine plastic_nonlocal_dependentState(Fe, Fp, ip, el) neighbor_rhoTotal(2,:,n) = sum(abs(rho_neighbor(:,scr)),2) connection_latticeConf(1:3,n) = & - math_mul33x3(invFe, mesh_ipCoordinates(1:3,neighbor_ip,neighbor_el) & + matmul(invFe, mesh_ipCoordinates(1:3,neighbor_ip,neighbor_el) & - mesh_ipCoordinates(1:3,ip,el)) - normal_latticeConf = math_mul33x3(transpose(invFp), mesh_ipAreaNormal(1:3,n,ip,el)) - if (math_mul3x3(normal_latticeConf,connection_latticeConf(1:3,n)) < 0.0_pReal) & ! neighboring connection points in opposite direction to face normal: must be periodic image + normal_latticeConf = matmul(transpose(invFp), mesh_ipAreaNormal(1:3,n,ip,el)) + if (math_inner(normal_latticeConf,connection_latticeConf(1:3,n)) < 0.0_pReal) & ! neighboring connection points in opposite direction to face normal: must be periodic image connection_latticeConf(1:3,n) = normal_latticeConf * mesh_ipVolume(ip,el)/mesh_ipArea(n,ip,el) ! instead take the surface normal scaled with the diameter of the cell else ! local neighbor or different lattice structure or different constitution instance -> use central values instead @@ -1047,7 +1046,7 @@ subroutine plastic_nonlocal_dependentState(Fe, Fp, ip, el) invConnections = math_inv33(connections) if (all(dEq0(invConnections))) call IO_error(-1,ext_msg='back stress calculation: inversion error') - rhoExcessGradient(c) = math_mul3x3(m(1:3,s,c), math_mul33x3(invConnections,rhoExcessDifferences)) + rhoExcessGradient(c) = math_inner(m(1:3,s,c), matmul(invConnections,rhoExcessDifferences)) enddo ! ... plus gradient from deads ... @@ -1528,13 +1527,8 @@ subroutine plastic_nonlocal_dotState(Mp, Fe, Fp, Temperature, & debug_e #endif use math, only: & -#ifdef __PGI - norm2, & -#endif - math_mul3x3, & - math_mul33x3, & + math_inner, & math_mul33xx33, & - math_mul33x33, & math_inv33, & math_det33, & PI @@ -1756,7 +1750,7 @@ subroutine plastic_nonlocal_dotState(Mp, Fe, Fp, Temperature, & m(1:3,1:ns,4) = prm%slip_transverse my_Fe = Fe(1:3,1:3,1,ip,el) - my_F = math_mul33x33(my_Fe, Fp(1:3,1:3,1,ip,el)) + my_F = matmul(my_Fe, Fp(1:3,1:3,1,ip,el)) neighbors: do n = 1,theMesh%elem%nIPneighbors @@ -1774,7 +1768,7 @@ subroutine plastic_nonlocal_dotState(Mp, Fe, Fp, Temperature, & if (neighbor_n > 0) then ! if neighbor exists, average deformation gradient neighbor_instance = phase_plasticityInstance(material_phase(1,neighbor_ip,neighbor_el)) neighbor_Fe = Fe(1:3,1:3,1,neighbor_ip,neighbor_el) - neighbor_F = math_mul33x33(neighbor_Fe, Fp(1:3,1:3,1,neighbor_ip,neighbor_el)) + neighbor_F = matmul(neighbor_Fe, Fp(1:3,1:3,1,neighbor_ip,neighbor_el)) Favg = 0.5_pReal * (my_F + neighbor_F) else ! if no neighbor, take my value as average Favg = my_F @@ -1809,9 +1803,9 @@ subroutine plastic_nonlocal_dotState(Mp, Fe, Fp, Temperature, & where (neighbor_rhoSgl * mesh_ipVolume(neighbor_ip,neighbor_el) ** 0.667_pReal < prm%significantN & .or. neighbor_rhoSgl < prm%significantRho) & neighbor_rhoSgl = 0.0_pReal - normal_neighbor2me_defConf = math_det33(Favg) * math_mul33x3(math_inv33(transpose(Favg)), & + normal_neighbor2me_defConf = math_det33(Favg) * matmul(math_inv33(transpose(Favg)), & mesh_ipAreaNormal(1:3,neighbor_n,neighbor_ip,neighbor_el)) ! calculate the normal of the interface in (average) deformed configuration (now pointing from my neighbor to me!!!) - normal_neighbor2me = math_mul33x3(transpose(neighbor_Fe), normal_neighbor2me_defConf) & + normal_neighbor2me = matmul(transpose(neighbor_Fe), normal_neighbor2me_defConf) & / math_det33(neighbor_Fe) ! interface normal in the lattice configuration of my neighbor area = mesh_ipArea(neighbor_n,neighbor_ip,neighbor_el) * norm2(normal_neighbor2me) normal_neighbor2me = normal_neighbor2me / norm2(normal_neighbor2me) ! normalize the surface normal to unit length @@ -1819,10 +1813,10 @@ subroutine plastic_nonlocal_dotState(Mp, Fe, Fp, Temperature, & do t = 1,4 c = (t + 1) / 2 topp = t + mod(t,2) - mod(t+1,2) - if (neighbor_v(s,t) * math_mul3x3(m(1:3,s,t), normal_neighbor2me) > 0.0_pReal & ! flux from my neighbor to me == entering flux for me + if (neighbor_v(s,t) * math_inner(m(1:3,s,t), normal_neighbor2me) > 0.0_pReal & ! flux from my neighbor to me == entering flux for me .and. v(s,t) * neighbor_v(s,t) >= 0.0_pReal ) then ! ... only if no sign change in flux density lineLength = neighbor_rhoSgl(s,t) * neighbor_v(s,t) & - * math_mul3x3(m(1:3,s,t), normal_neighbor2me) * area ! positive line length that wants to enter through this interface + * math_inner(m(1:3,s,t), normal_neighbor2me) * area ! positive line length that wants to enter through this interface where (compatibility(c,1:ns,s,n,ip,el) > 0.0_pReal) & ! positive compatibility... rhoDotFlux(1:ns,t) = rhoDotFlux(1:ns,t) & + lineLength / mesh_ipVolume(ip,el) & ! ... transferring to equally signed mobile dislocation type @@ -1856,23 +1850,23 @@ subroutine plastic_nonlocal_dotState(Mp, Fe, Fp, Temperature, & my_v = v normal_me2neighbor_defConf = math_det33(Favg) & - * math_mul33x3(math_inv33(transpose(Favg)), & + * matmul(math_inv33(transpose(Favg)), & mesh_ipAreaNormal(1:3,n,ip,el)) ! calculate the normal of the interface in (average) deformed configuration (pointing from me to my neighbor!!!) - normal_me2neighbor = math_mul33x3(transpose(my_Fe), normal_me2neighbor_defConf) & + normal_me2neighbor = matmul(transpose(my_Fe), normal_me2neighbor_defConf) & / math_det33(my_Fe) ! interface normal in my lattice configuration area = mesh_ipArea(n,ip,el) * norm2(normal_me2neighbor) normal_me2neighbor = normal_me2neighbor / norm2(normal_me2neighbor) ! normalize the surface normal to unit length do s = 1,ns do t = 1,4 c = (t + 1) / 2 - if (my_v(s,t) * math_mul3x3(m(1:3,s,t), normal_me2neighbor) > 0.0_pReal ) then ! flux from me to my neighbor == leaving flux for me (might also be a pure flux from my mobile density to dead density if interface not at all transmissive) + if (my_v(s,t) * math_inner(m(1:3,s,t), normal_me2neighbor) > 0.0_pReal ) then ! flux from me to my neighbor == leaving flux for me (might also be a pure flux from my mobile density to dead density if interface not at all transmissive) if (my_v(s,t) * neighbor_v(s,t) >= 0.0_pReal) then ! no sign change in flux density transmissivity = sum(compatibility(c,1:ns,s,n,ip,el)**2.0_pReal) ! overall transmissivity from this slip system to my neighbor else ! sign change in flux density means sign change in stress which does not allow for dislocations to arive at the neighbor transmissivity = 0.0_pReal endif lineLength = my_rhoSgl(s,t) * my_v(s,t) & - * math_mul3x3(m(1:3,s,t), normal_me2neighbor) * area ! positive line length of mobiles that wants to leave through this interface + * math_inner(m(1:3,s,t), normal_me2neighbor) * area ! positive line length of mobiles that wants to leave through this interface rhoDotFlux(s,t) = rhoDotFlux(s,t) - lineLength / mesh_ipVolume(ip,el) ! subtract dislocation flux from current type rhoDotFlux(s,t+4) = rhoDotFlux(s,t+4) & + lineLength / mesh_ipVolume(ip,el) * (1.0_pReal - transmissivity) & @@ -2017,7 +2011,7 @@ end subroutine plastic_nonlocal_dotState !-------------------------------------------------------------------------------------------------- subroutine plastic_nonlocal_updateCompatibility(orientation,i,e) use math, only: & - math_mul3x3, & + math_inner, & math_qRot use rotations, only: & rotation @@ -2134,13 +2128,13 @@ subroutine plastic_nonlocal_updateCompatibility(orientation,i,e) absoluteMisorientation = rot%asQuaternion() mySlipSystems: do s1 = 1,ns neighborSlipSystems: do s2 = 1,ns - my_compatibility(1,s2,s1,n) = math_mul3x3(prm%slip_normal(1:3,s1), & + my_compatibility(1,s2,s1,n) = math_inner(prm%slip_normal(1:3,s1), & math_qRot(absoluteMisorientation, prm%slip_normal(1:3,s2))) & - * abs(math_mul3x3(prm%slip_direction(1:3,s1), & + * abs(math_inner(prm%slip_direction(1:3,s1), & math_qRot(absoluteMisorientation, prm%slip_direction(1:3,s2)))) - my_compatibility(2,s2,s1,n) = abs(math_mul3x3(prm%slip_normal(1:3,s1), & + my_compatibility(2,s2,s1,n) = abs(math_inner(prm%slip_normal(1:3,s1), & math_qRot(absoluteMisorientation, prm%slip_normal(1:3,s2)))) & - * abs(math_mul3x3(prm%slip_direction(1:3,s1), & + * abs(math_inner(prm%slip_direction(1:3,s1), & math_qRot(absoluteMisorientation, prm%slip_direction(1:3,s2)))) enddo neighborSlipSystems diff --git a/src/source_damage_isoBrittle.f90 b/src/source_damage_isoBrittle.f90 index d6ee268a3..2d13277c7 100644 --- a/src/source_damage_isoBrittle.f90 +++ b/src/source_damage_isoBrittle.f90 @@ -174,8 +174,6 @@ subroutine source_damage_isoBrittle_deltaState(C, Fe, ipc, ip, el) sourceState use math, only : & math_sym33to6, & - math_mul33x33, & - math_mul66x6, & math_I3 implicit none @@ -200,9 +198,10 @@ subroutine source_damage_isoBrittle_deltaState(C, Fe, ipc, ip, el) sourceOffset = source_damage_isoBrittle_offset(phase) - strain = 0.5_pReal*math_sym33to6(math_mul33x33(transpose(Fe),Fe)-math_I3) + strain = 0.5_pReal*math_sym33to6(matmul(transpose(Fe),Fe)-math_I3) - strainenergy = 2.0_pReal*sum(strain*math_mul66x6(C,strain))/param(instance)%critStrainEnergy + strainenergy = 2.0_pReal*sum(strain*matmul(C,strain))/param(instance)%critStrainEnergy + ! ToDo: check strainenergy = 2.0_pReal*dot_product(strain,matmul(C,strain))/param(instance)%critStrainEnergy if (strainenergy > sourceState(phase)%p(sourceOffset)%subState0(1,constituent)) then sourceState(phase)%p(sourceOffset)%deltaState(1,constituent) = & diff --git a/src/spectral_utilities.f90 b/src/spectral_utilities.f90 index 26c1cf9fc..dd79e67e2 100644 --- a/src/spectral_utilities.f90 +++ b/src/spectral_utilities.f90 @@ -610,7 +610,6 @@ end subroutine utilities_fourierGammaConvolution !-------------------------------------------------------------------------------------------------- subroutine utilities_fourierGreenConvolution(D_ref, mobility_ref, deltaT) use math, only: & - math_mul33x3, & PI use mesh, only: & grid, & @@ -1158,8 +1157,6 @@ subroutine utilities_updateIPcoords(F) cNeq use IO, only: & IO_error - use math, only: & - math_mul33x3 use mesh, only: & grid, & grid3, & @@ -1200,12 +1197,12 @@ subroutine utilities_updateIPcoords(F) if (grid3Offset == 0) offset_coords = vectorField_real(1:3,1,1,1) call MPI_Bcast(offset_coords,3,MPI_DOUBLE,0,PETSC_COMM_WORLD,ierr) if(ierr /=0) call IO_error(894, ext_msg='update_IPcoords') - offset_coords = math_mul33x3(Favg,step/2.0_pReal) - offset_coords + offset_coords = matmul(Favg,step/2.0_pReal) - offset_coords m = 1 do k = 1,grid3; do j = 1,grid(2); do i = 1,grid(1) mesh_ipCoordinates(1:3,1,m) = vectorField_real(1:3,i,j,k) & + offset_coords & - + math_mul33x3(Favg,step*real([i,j,k+grid3Offset]-1,pReal)) + + matmul(Favg,step*real([i,j,k+grid3Offset]-1,pReal)) m = m+1 enddo; enddo; enddo From 3a8f48a0f89b19a27da1603cca69898cb6fa27fb Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 3 Apr 2019 08:25:42 +0200 Subject: [PATCH 32/47] easier to adjust to new versions --- src/DAMASK_interface.f90 | 29 +++++++++++++++++------------ 1 file changed, 17 insertions(+), 12 deletions(-) diff --git a/src/DAMASK_interface.f90 b/src/DAMASK_interface.f90 index 9d2e96571..0cee4862b 100644 --- a/src/DAMASK_interface.f90 +++ b/src/DAMASK_interface.f90 @@ -9,6 +9,11 @@ !> by DAMASK. Interpretating the command line arguments to get load case, geometry file, !> and working directory. !-------------------------------------------------------------------------------------------------- +#define GCC_MIN 6 +#define INTEL_MIN 1600 +#define PETSC_MAJOR 3 +#define PETSC_MINOR_MIN 10 +#define PETSC_MINOR_MAX 11 module DAMASK_interface implicit none private @@ -55,27 +60,27 @@ subroutine DAMASK_interface_init() getCWD #include -#if defined(__GFORTRAN__) && __GNUC__ < 5 +#if defined(__GFORTRAN__) && __GNUC__ <= GCC_MIN =================================================================================================== - 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 + ----- WRONG COMPILER VERSION ----- WRONG COMPILER VERSION ----- WRONG COMPILER VERSION ----- =================================================================================================== -================== THIS VERSION OF DAMASK REQUIRES gfortran > 5.0 ============================== -====================== THIS VERSION OF DAMASK REQUIRES gfortran > 5.0 ========================== -========================= THIS VERSION OF DAMASK REQUIRES gfortran > 5.0 ======================= +=============== THIS VERSION OF DAMASK REQUIRES A NEWER gfortran VERSION ====================== +================== THIS VERSION OF DAMASK REQUIRES A NEWER gfortran VERSION =================== +===================== THIS VERSION OF DAMASK REQUIRES A NEWER gfortran VERSION ================ =================================================================================================== - 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 + ----- WRONG COMPILER VERSION ----- WRONG COMPILER VERSION ----- WRONG COMPILER VERSION ----- =================================================================================================== #endif -#if defined(__INTEL_COMPILER) && __INTEL_COMPILER < 1600 +#if defined(__INTEL_COMPILER) && __INTEL_COMPILER <= INTEL_MIN =================================================================================================== - 16.0 16.0 16.0 16.0 16.0 16.0 16.0 16.0 16.0 16.0 16.0 16.0 16.0 16.0 16.0 16.0 16.0 16.0 16.0 + ----- WRONG COMPILER VERSION ----- WRONG COMPILER VERSION ----- WRONG COMPILER VERSION ----- =================================================================================================== -================== THIS VERSION OF DAMASK REQUIRES ifort > 16.0 ================================ -====================== THIS VERSION OF DAMASK REQUIRES ifort > 16.0 =========================== -========================= THIS VERSION OF DAMASK REQUIRES ifort > 16.0 ======================== +================= THIS VERSION OF DAMASK REQUIRES A NEWER ifort VERSION ======================= +==================== THIS VERSION OF DAMASK REQUIRES A NEWER ifort VERSION ==================== +======================= THIS VERSION OF DAMASK REQUIRES A NEWER ifort VERSION ================= =================================================================================================== - 16.0 16.0 16.0 16.0 16.0 16.0 16.0 16.0 16.0 16.0 16.0 16.0 16.0 16.0 16.0 16.0 16.0 16.0 16.0 + ----- WRONG COMPILER VERSION ----- WRONG COMPILER VERSION ----- WRONG COMPILER VERSION ----- =================================================================================================== #endif From 48633d887b0316d6381a8babd41af94f99843f6a Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 3 Apr 2019 11:53:59 +0200 Subject: [PATCH 33/47] allow to specify min and max of PETSc separately --- src/DAMASK_interface.f90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/DAMASK_interface.f90 b/src/DAMASK_interface.f90 index 0cee4862b..e3bc9d1fd 100644 --- a/src/DAMASK_interface.f90 +++ b/src/DAMASK_interface.f90 @@ -60,7 +60,7 @@ subroutine DAMASK_interface_init() getCWD #include -#if defined(__GFORTRAN__) && __GNUC__ <= GCC_MIN +#if defined(__GFORTRAN__) && __GNUC__<=GCC_MIN =================================================================================================== ----- WRONG COMPILER VERSION ----- WRONG COMPILER VERSION ----- WRONG COMPILER VERSION ----- =================================================================================================== @@ -72,7 +72,7 @@ subroutine DAMASK_interface_init() =================================================================================================== #endif -#if defined(__INTEL_COMPILER) && __INTEL_COMPILER <= INTEL_MIN +#if defined(__INTEL_COMPILER) && __INTEL_COMPILER<=INTEL_MIN =================================================================================================== ----- WRONG COMPILER VERSION ----- WRONG COMPILER VERSION ----- WRONG COMPILER VERSION ----- =================================================================================================== @@ -84,15 +84,15 @@ subroutine DAMASK_interface_init() =================================================================================================== #endif -#if PETSC_VERSION_MAJOR!=3 || PETSC_VERSION_MINOR!=10 +#if PETSC_VERSION_MAJOR!=3 || PETSC_VERSION_MINOR<=PETSC_MINOR_MIN || PETSC_VERSION_MINOR>PETSC_MINOR_MAX =================================================================================================== - 3.10.x 3.10.x 3.10.x 3.10.x 3.10.x 3.10.x 3.10.x 3.10.x 3.10.x 3.10.x 3.10.x 3.10.x 3.10.x 3.10.x +-- WRONG PETSc VERSION --- WRONG PETSc VERSION --- WRONG PETSc VERSION --- WRONG PETSc VERSION -- =================================================================================================== -=================== THIS VERSION OF DAMASK REQUIRES PETSc 3.10.x ============================== -====================== THIS VERSION OF DAMASK REQUIRES PETSc 3.10.x =========================== -========================= THIS VERSION OF DAMASK REQUIRES PETSc 3.10.x ======================== +============ THIS VERSION OF DAMASK REQUIRES A DIFFERENT PETSc VERSION ======================== +=============== THIS VERSION OF DAMASK REQUIRES A DIFFERENT PETSc VERSION ===================== +================== THIS VERSION OF DAMASK REQUIRES A DIFFERENT PETSc VERSION ================== =================================================================================================== - 3.10.x 3.10.x 3.10.x 3.10.x 3.10.x 3.10.x 3.10.x 3.10.x 3.10.x 3.10.x 3.10.x 3.10.x 3.10.x 3.10.x +-- WRONG PETSc VERSION --- WRONG PETSc VERSION --- WRONG PETSc VERSION --- WRONG PETSc VERSION -- =================================================================================================== #endif From 1d31c5c2db8e7c288b022910dc5d63102a7c322e Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 3 Apr 2019 12:32:30 +0200 Subject: [PATCH 34/47] pInt not needed --- src/crystallite.f90 | 373 ++++++++++++++++++++++---------------------- 1 file changed, 186 insertions(+), 187 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 305043606..2ab66d970 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -10,8 +10,7 @@ module crystallite use prec, only: & - pReal, & - pInt + pReal use rotations, only: & rotation use FEsolving, only: & @@ -25,11 +24,11 @@ module crystallite private character(len=64), dimension(:,:), allocatable, private :: & crystallite_output !< name of each post result output - integer(pInt), public, protected :: & + integer, public, protected :: & crystallite_maxSizePostResults !< description not available - integer(pInt), dimension(:), allocatable, public, protected :: & + integer, dimension(:), allocatable, public, protected :: & crystallite_sizePostResults !< description not available - integer(pInt), dimension(:,:), allocatable, private :: & + integer, dimension(:,:), allocatable, private :: & crystallite_sizePostResult !< description not available real(pReal), dimension(:,:,:), allocatable, public :: & @@ -163,13 +162,13 @@ subroutine crystallite_init implicit none - integer(pInt), parameter :: FILEUNIT=434_pInt + integer, parameter :: FILEUNIT=434 logical, dimension(:,:), allocatable :: devNull - integer(pInt) :: & + integer :: & c, & !< counter in integration point component loop i, & !< counter in integration point loop e, & !< counter in element loop - o = 0_pInt, & !< counter in output loop + o = 0, & !< counter in output loop r, & cMax, & !< maximum number of integration point components iMax, & !< maximum number of integration points @@ -229,26 +228,26 @@ subroutine crystallite_init size(config_crystallite))) ; crystallite_output = '' allocate(crystallite_outputID(maxval(crystallite_Noutput), & size(config_crystallite)), source=undefined_ID) - allocate(crystallite_sizePostResults(size(config_crystallite)),source=0_pInt) + allocate(crystallite_sizePostResults(size(config_crystallite)),source=0) allocate(crystallite_sizePostResult(maxval(crystallite_Noutput), & - size(config_crystallite)), source=0_pInt) + size(config_crystallite)), source=0) select case(numerics_integrator) - case(1_pInt) + case(1) integrateState => integrateStateFPI - case(2_pInt) + case(2) integrateState => integrateStateEuler - case(3_pInt) + case(3) integrateState => integrateStateAdaptiveEuler - case(4_pInt) + case(4) integrateState => integrateStateRK4 - case(5_pInt) + case(5) integrateState => integrateStateRKCK45 end select - do c = 1_pInt, size(config_crystallite) + do c = 1, size(config_crystallite) #if defined(__GFORTRAN__) str = ['GfortranBug86277'] str = config_crystallite(c)%getStrings('(output)',defaultVal=str) @@ -256,7 +255,7 @@ subroutine crystallite_init #else str = config_crystallite(c)%getStrings('(output)',defaultVal=[character(len=65536)::]) #endif - do o = 1_pInt, size(str) + do o = 1, size(str) crystallite_output(o,c) = str(o) outputName: select case(str(o)) case ('phase') outputName @@ -292,27 +291,27 @@ subroutine crystallite_init case ('neighboringelement') outputName ! ToDo: this is not a result, it is static. Should be written out by mesh crystallite_outputID(o,c) = neighboringelement_ID case default outputName - call IO_error(105_pInt,ext_msg=trim(str(o))//' (Crystallite)') + call IO_error(105,ext_msg=trim(str(o))//' (Crystallite)') end select outputName enddo enddo - do r = 1_pInt,size(config_crystallite) - do o = 1_pInt,crystallite_Noutput(r) + do r = 1,size(config_crystallite) + do o = 1,crystallite_Noutput(r) select case(crystallite_outputID(o,r)) case(phase_ID,texture_ID,volume_ID) - mySize = 1_pInt + mySize = 1 case(orientation_ID,grainrotation_ID) - mySize = 4_pInt + mySize = 4 case(defgrad_ID,fe_ID,fp_ID,fi_ID,lp_ID,li_ID,p_ID,s_ID) - mySize = 9_pInt + mySize = 9 case(elasmatrix_ID) - mySize = 36_pInt + mySize = 36 case(neighboringip_ID,neighboringelement_ID) mySize = theMesh%elem%nIPneighbors case default - mySize = 0_pInt + mySize = 0 end select crystallite_sizePostResult(o,r) = mySize crystallite_sizePostResults(r) = crystallite_sizePostResults(r) + mySize @@ -325,13 +324,13 @@ subroutine crystallite_init !-------------------------------------------------------------------------------------------------- ! write description file for crystallite output - if (worldrank == 0_pInt) then + if (worldrank == 0) then call IO_write_jobFile(FILEUNIT,'outputCrystallite') - do r = 1_pInt,size(config_crystallite) + do r = 1,size(config_crystallite) if (any(microstructure_crystallite(mesh_element(4,:)) == r)) then write(FILEUNIT,'(/,a,/)') '['//trim(crystallite_name(r))//']' - do o = 1_pInt,crystallite_Noutput(r) + do o = 1,crystallite_Noutput(r) write(FILEUNIT,'(a,i4)') trim(crystallite_output(o,r))//char(9),crystallite_sizePostResult(o,r) enddo endif @@ -347,7 +346,7 @@ subroutine crystallite_init !$OMP PARALLEL DO PRIVATE(myNcomponents,i,c) do e = FEsolving_execElem(1),FEsolving_execElem(2) myNcomponents = homogenization_Ngrains(mesh_element(3,e)) - forall (i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), c = 1_pInt:myNcomponents) + forall (i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), c = 1:myNcomponents) crystallite_Fp0(1:3,1:3,c,i,e) = math_EulerToR(material_EulerAngles(1:3,c,i,e)) ! plastic def gradient reflects init orientation crystallite_Fi0(1:3,1:3,c,i,e) = constitutive_initialFi(c,i,e) crystallite_F0(1:3,1:3,c,i,e) = math_I3 @@ -361,7 +360,7 @@ subroutine crystallite_init enddo !$OMP END PARALLEL DO - if(any(.not. crystallite_localPlasticity) .and. .not. usePingPong) call IO_error(601_pInt) ! exit if nonlocal but no ping-pong ToDo: Why not check earlier? or in nonlocal? + if(any(.not. crystallite_localPlasticity) .and. .not. usePingPong) call IO_error(601) ! exit if nonlocal but no ping-pong ToDo: Why not check earlier? or in nonlocal? crystallite_partionedFp0 = crystallite_Fp0 crystallite_partionedFi0 = crystallite_Fi0 @@ -374,7 +373,7 @@ subroutine crystallite_init !$OMP PARALLEL DO do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do c = 1_pInt,homogenization_Ngrains(mesh_element(3,e)) + do c = 1,homogenization_Ngrains(mesh_element(3,e)) call constitutive_microstructure(crystallite_Fe(1:3,1:3,c,i,e), & crystallite_Fp(1:3,1:3,c,i,e), & c,i,e) ! update dependent state variables to be consistent with basic states @@ -387,7 +386,7 @@ subroutine crystallite_init call crystallite_stressTangent #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) then + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) then write(6,'(a42,1x,i10)') ' # of elements: ', eMax write(6,'(a42,1x,i10)') 'max # of integration points/element: ', iMax write(6,'(a42,1x,i10)') 'max # of constituents/integration point: ', cMax @@ -446,7 +445,7 @@ function crystallite_stress(dummyArgumentToPreventInternalCompilerErrorWithGCC) dummyArgumentToPreventInternalCompilerErrorWithGCC real(pReal) :: & formerSubStep - integer(pInt) :: & + integer :: & NiterationCrystallite, & ! number of iterations in crystallite loop c, & !< counter in integration point component loop i, & !< counter in integration point loop @@ -455,7 +454,7 @@ function crystallite_stress(dummyArgumentToPreventInternalCompilerErrorWithGCC) s #ifdef DEBUG - if (iand(debug_level(debug_crystallite),debug_levelSelective) /= 0_pInt & + if (iand(debug_level(debug_crystallite),debug_levelSelective) /= 0 & .and. FEsolving_execElem(1) <= debug_e & .and. debug_e <= FEsolving_execElem(2)) then write(6,'(/,a,i8,1x,i2,1x,i3)') '<< CRYST stress >> boundary and initial values at el ip ipc ', & @@ -480,12 +479,12 @@ function crystallite_stress(dummyArgumentToPreventInternalCompilerErrorWithGCC) crystallite_subStep = 0.0_pReal !$OMP PARALLEL DO elementLooping1: do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e); do c = 1_pInt,homogenization_Ngrains(mesh_element(3,e)) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e); do c = 1,homogenization_Ngrains(mesh_element(3,e)) homogenizationRequestsCalculation: if (crystallite_requested(c,i,e)) then plasticState (phaseAt(c,i,e))%subState0( :,phasememberAt(c,i,e)) = & plasticState (phaseAt(c,i,e))%partionedState0(:,phasememberAt(c,i,e)) - do s = 1_pInt, phase_Nsources(phaseAt(c,i,e)) + do s = 1, phase_Nsources(phaseAt(c,i,e)) sourceState(phaseAt(c,i,e))%p(s)%subState0( :,phasememberAt(c,i,e)) = & sourceState(phaseAt(c,i,e))%p(s)%partionedState0(:,phasememberAt(c,i,e)) enddo @@ -509,16 +508,16 @@ function crystallite_stress(dummyArgumentToPreventInternalCompilerErrorWithGCC) startIP = FEsolving_execIP(1,FEsolving_execELem(1)) endIP = startIP else singleRun - startIP = 1_pInt + startIP = 1 endIP = theMesh%elem%nIPs endif singleRun - NiterationCrystallite = 0_pInt + NiterationCrystallite = 0 cutbackLooping: do while (any(crystallite_todo(:,startIP:endIP,FEsolving_execELem(1):FEsolving_execElem(2)))) - NiterationCrystallite = NiterationCrystallite + 1_pInt + NiterationCrystallite = NiterationCrystallite + 1 #ifdef DEBUG - if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) & + if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0) & write(6,'(a,i6)') '<< CRYST stress >> crystallite iteration ',NiterationCrystallite #endif !$OMP PARALLEL DO PRIVATE(formerSubStep) @@ -544,14 +543,14 @@ function crystallite_stress(dummyArgumentToPreventInternalCompilerErrorWithGCC) !if abbrevation, make c and p private in omp plasticState( phaseAt(c,i,e))%subState0(:,phasememberAt(c,i,e)) & = plasticState(phaseAt(c,i,e))%state( :,phasememberAt(c,i,e)) - do s = 1_pInt, phase_Nsources(phaseAt(c,i,e)) + do s = 1, phase_Nsources(phaseAt(c,i,e)) sourceState( phaseAt(c,i,e))%p(s)%subState0(:,phasememberAt(c,i,e)) & = sourceState(phaseAt(c,i,e))%p(s)%state( :,phasememberAt(c,i,e)) enddo #ifdef DEBUG - if (iand(debug_level(debug_crystallite),debug_levelBasic) /= 0_pInt & + if (iand(debug_level(debug_crystallite),debug_levelBasic) /= 0 & .and. ((e == debug_e .and. i == debug_i .and. c == debug_g) & - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) & write(6,'(a,f12.8,a,f12.8,a,i8,1x,i2,1x,i3,/)') '<< CRYST stress >> winding forward from ', & crystallite_subFrac(c,i,e)-formerSubStep,' to current crystallite_subfrac ', & crystallite_subFrac(c,i,e),' in crystallite_stress at el ip ipc ',e,i,c @@ -573,7 +572,7 @@ function crystallite_stress(dummyArgumentToPreventInternalCompilerErrorWithGCC) endif plasticState (phaseAt(c,i,e))%state( :,phasememberAt(c,i,e)) & = plasticState(phaseAt(c,i,e))%subState0(:,phasememberAt(c,i,e)) - do s = 1_pInt, phase_Nsources(phaseAt(c,i,e)) + do s = 1, phase_Nsources(phaseAt(c,i,e)) sourceState( phaseAt(c,i,e))%p(s)%state( :,phasememberAt(c,i,e)) & = sourceState(phaseAt(c,i,e))%p(s)%subState0(:,phasememberAt(c,i,e)) enddo @@ -581,9 +580,9 @@ function crystallite_stress(dummyArgumentToPreventInternalCompilerErrorWithGCC) ! cant restore dotState here, since not yet calculated in first cutback after initialization crystallite_todo(c,i,e) = crystallite_subStep(c,i,e) > subStepMinCryst ! still on track or already done (beyond repair) #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & .and. ((e == debug_e .and. i == debug_i .and. c == debug_g) & - .or. .not. iand(debug_level(debug_crystallite),debug_levelSelective) /= 0_pInt)) then + .or. .not. iand(debug_level(debug_crystallite),debug_levelSelective) /= 0)) then if (crystallite_todo(c,i,e)) then write(6,'(a,f12.8,a,i8,1x,i2,1x,i3,/)') '<< CRYST stress >> cutback with new crystallite_subStep: ', & crystallite_subStep(c,i,e),' at el ip ipc ',e,i,c @@ -613,13 +612,13 @@ function crystallite_stress(dummyArgumentToPreventInternalCompilerErrorWithGCC) !$OMP END PARALLEL DO #ifdef DEBUG - if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) then + if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0) then write(6,'(/,a,f8.5,a,f8.5,/)') '<< CRYST stress >> ',minval(crystallite_subStep), & ' ≤ subStep ≤ ',maxval(crystallite_subStep) write(6,'(/,a,f8.5,a,f8.5,/)') '<< CRYST stress >> ',minval(crystallite_subFrac), & ' ≤ subFrac ≤ ',maxval(crystallite_subFrac) flush(6) - if (iand(debug_level(debug_crystallite),debug_levelSelective) /= 0_pInt) then + if (iand(debug_level(debug_crystallite),debug_levelSelective) /= 0) then write(6,'(/,a,f8.5,1x,a,1x,f8.5,1x,a)') '<< CRYST stress >> subFrac + subStep = ',& crystallite_subFrac(debug_g,debug_i,debug_e),'+',crystallite_subStep(debug_g,debug_i,debug_e),'@selective' flush(6) @@ -648,13 +647,13 @@ function crystallite_stress(dummyArgumentToPreventInternalCompilerErrorWithGCC) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) do c = 1,homogenization_Ngrains(mesh_element(3,e)) if (.not. crystallite_converged(c,i,e)) then - if(iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) & + if(iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) & write(6,'(a,i8,1x,i2,1x,i3,/)') '<< CRYST stress >> no convergence at el ip ipc ', & e,i,c endif - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & .and. ((e == debug_e .and. i == debug_i .and. c == debug_g) & - .or. .not. iand(debug_level(debug_crystallite),debug_levelSelective) /= 0_pInt)) then + .or. .not. iand(debug_level(debug_crystallite),debug_levelSelective) /= 0)) then write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST stress >> solution at el ip ipc ',e,i,c write(6,'(/,a,/,3(12x,3(f12.4,1x)/))') '<< CRYST stress >> P / MPa', & transpose(crystallite_P(1:3,1:3,c,i,e))*1.0e-6_pReal @@ -706,7 +705,7 @@ subroutine crystallite_stressTangent() constitutive_LiAndItsTangents implicit none - integer(pInt) :: & + integer :: & c, & !< counter in integration point component loop i, & !< counter in integration point loop e, & !< counter in element loop @@ -733,7 +732,7 @@ subroutine crystallite_stressTangent() !$OMP rhs_3333,lhs_3333,temp_99,temp_33_1,temp_33_2,temp_33_3,temp_33_4,temp_3333,error) elementLooping: do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do c = 1_pInt,homogenization_Ngrains(mesh_element(3,e)) + do c = 1,homogenization_Ngrains(mesh_element(3,e)) call constitutive_SandItsTangents(devNull,dSdFe,dSdFi, & crystallite_Fe(1:3,1:3,c,i,e), & @@ -748,7 +747,7 @@ subroutine crystallite_stressTangent() else invSubFi0 = math_inv33(crystallite_subFi0(1:3,1:3,c,i,e)) lhs_3333 = 0.0_pReal; rhs_3333 = 0.0_pReal - do o=1_pInt,3_pInt; do p=1_pInt,3_pInt + do o=1,3; do p=1,3 lhs_3333(1:3,1:3,o,p) = lhs_3333(1:3,1:3,o,p) & + crystallite_subdt(c,i,e)*matmul(invSubFi0,dLidFi(1:3,1:3,o,p)) lhs_3333(1:3,o,1:3,p) = lhs_3333(1:3,o,1:3,p) & @@ -758,7 +757,7 @@ subroutine crystallite_stressTangent() enddo;enddo call math_invert2(temp_99,error,math_3333to99(lhs_3333)) if (error) then - call IO_warning(warning_ID=600_pInt,el=e,ip=i,g=c, & + call IO_warning(warning_ID=600,el=e,ip=i,g=c, & ext_msg='inversion error in analytic tangent calculation') dFidS = 0.0_pReal else @@ -782,7 +781,7 @@ subroutine crystallite_stressTangent() crystallite_invFp (1:3,1:3,c,i,e)), & math_inv33(crystallite_subFi0(1:3,1:3,c,i,e))) - forall(p=1_pInt:3_pInt, o=1_pInt:3_pInt) + forall(p=1:3, o=1:3) rhs_3333(p,o,1:3,1:3) = matmul(dSdFe(p,o,1:3,1:3),temp_33_1) temp_3333(1:3,1:3,p,o) = matmul(matmul(temp_33_2,dLpdS(1:3,1:3,p,o)), & crystallite_invFi(1:3,1:3,c,i,e)) & @@ -791,9 +790,9 @@ subroutine crystallite_stressTangent() lhs_3333 = crystallite_subdt(c,i,e)*math_mul3333xx3333(dSdFe,temp_3333) & + math_mul3333xx3333(dSdFi,dFidS) - call math_invert2(temp_99,error,math_identity2nd(9_pInt)+math_3333to99(lhs_3333)) + call math_invert2(temp_99,error,math_identity2nd(9)+math_3333to99(lhs_3333)) if (error) then - call IO_warning(warning_ID=600_pInt,el=e,ip=i,g=c, & + call IO_warning(warning_ID=600,el=e,ip=i,g=c, & ext_msg='inversion error in analytic tangent calculation') dSdF = rhs_3333 else @@ -803,7 +802,7 @@ subroutine crystallite_stressTangent() !-------------------------------------------------------------------------------------------------- ! calculate dFpinvdF temp_3333 = math_mul3333xx3333(dLpdS,dSdF) - forall(p=1_pInt:3_pInt, o=1_pInt:3_pInt) + forall(p=1:3, o=1:3) dFpinvdF(1:3,1:3,p,o) & = -crystallite_subdt(c,i,e) & * matmul(math_inv33(crystallite_subFp0(1:3,1:3,c,i,e)), & @@ -824,10 +823,10 @@ subroutine crystallite_stressTangent() crystallite_S(1:3,1:3,c,i,e)) crystallite_dPdF(1:3,1:3,1:3,1:3,c,i,e) = 0.0_pReal - do p=1_pInt, 3_pInt + do p=1, 3 crystallite_dPdF(p,1:3,p,1:3,c,i,e) = transpose(temp_33_1) enddo - forall(p=1_pInt:3_pInt, o=1_pInt:3_pInt) + forall(p=1:3, o=1:3) crystallite_dPdF(1:3,1:3,p,o,c,i,e) = crystallite_dPdF(1:3,1:3,p,o,c,i,e) + & matmul(matmul(crystallite_subF(1:3,1:3,c,i,e),dFpinvdF(1:3,1:3,p,o)),temp_33_2) + & matmul(matmul(temp_33_3,dSdF(1:3,1:3,p,o)),transpose(crystallite_invFp(1:3,1:3,c,i,e))) + & @@ -860,7 +859,7 @@ subroutine crystallite_orientations plastic_nonlocal_updateCompatibility implicit none - integer(pInt) & + integer & c, & !< counter in integration point component loop i, & !< counter in integration point loop e !< counter in element loop @@ -868,7 +867,7 @@ subroutine crystallite_orientations !$OMP PARALLEL DO do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do c = 1_pInt,homogenization_Ngrains(mesh_element(3,e)) + do c = 1,homogenization_Ngrains(mesh_element(3,e)) call crystallite_orientation(c,i,e)%fromRotationMatrix(transpose(math_rotationalPart33(crystallite_Fe(1:3,1:3,c,i,e)))) enddo; enddo; enddo !$OMP END PARALLEL DO @@ -901,7 +900,7 @@ function crystallite_push33ToRef(ipc,ip,el, tensor33) real(pReal), dimension(3,3) :: crystallite_push33ToRef real(pReal), dimension(3,3), intent(in) :: tensor33 real(pReal), dimension(3,3) :: T - integer(pInt), intent(in):: & + integer, intent(in):: & el, & ! element index ip, & ! integration point index ipc ! grain index @@ -943,7 +942,7 @@ function crystallite_postResults(ipc, ip, el) rotation implicit none - integer(pInt), intent(in):: & + integer, intent(in):: & el, & !< element index ip, & !< integration point index ipc !< grain index @@ -954,7 +953,7 @@ function crystallite_postResults(ipc, ip, el) crystallite_postResults real(pReal) :: & detF - integer(pInt) :: & + integer :: & o, & c, & crystID, & @@ -966,29 +965,29 @@ function crystallite_postResults(ipc, ip, el) crystallite_postResults = 0.0_pReal crystallite_postResults(1) = real(crystallite_sizePostResults(crystID),pReal) ! header-like information (length) - c = 1_pInt + c = 1 - do o = 1_pInt,crystallite_Noutput(crystID) - mySize = 0_pInt + do o = 1,crystallite_Noutput(crystID) + mySize = 0 select case(crystallite_outputID(o,crystID)) case (phase_ID) - mySize = 1_pInt + mySize = 1 crystallite_postResults(c+1) = real(material_phase(ipc,ip,el),pReal) ! phaseID of grain case (texture_ID) - mySize = 1_pInt + mySize = 1 crystallite_postResults(c+1) = real(material_texture(ipc,ip,el),pReal) ! textureID of grain case (volume_ID) - mySize = 1_pInt + mySize = 1 detF = math_det33(crystallite_partionedF(1:3,1:3,ipc,ip,el)) ! V_current = det(F) * V_reference crystallite_postResults(c+1) = detF * mesh_ipVolume(ip,el) & / real(homogenization_Ngrains(mesh_element(3,el)),pReal) ! grain volume (not fraction but absolute) case (orientation_ID) - mySize = 4_pInt + mySize = 4 crystallite_postResults(c+1:c+mySize) = crystallite_orientation(ipc,ip,el)%asQuaternion() case (grainrotation_ID) rot = crystallite_orientation0(ipc,ip,el)%misorientation(crystallite_orientation(ipc,ip,el)) - mySize = 4_pInt + mySize = 4 crystallite_postResults(c+1:c+mySize) = rot%asAxisAnglePair() crystallite_postResults(c+4) = inDeg * crystallite_postResults(c+4) ! angle in degree @@ -996,57 +995,57 @@ function crystallite_postResults(ipc, ip, el) ! thus row index i is slow, while column index j is fast. reminder: "row is slow" case (defgrad_ID) - mySize = 9_pInt + mySize = 9 crystallite_postResults(c+1:c+mySize) = & reshape(transpose(crystallite_partionedF(1:3,1:3,ipc,ip,el)),[mySize]) case (fe_ID) - mySize = 9_pInt + mySize = 9 crystallite_postResults(c+1:c+mySize) = & reshape(transpose(crystallite_Fe(1:3,1:3,ipc,ip,el)),[mySize]) case (fp_ID) - mySize = 9_pInt + mySize = 9 crystallite_postResults(c+1:c+mySize) = & reshape(transpose(crystallite_Fp(1:3,1:3,ipc,ip,el)),[mySize]) case (fi_ID) - mySize = 9_pInt + mySize = 9 crystallite_postResults(c+1:c+mySize) = & reshape(transpose(crystallite_Fi(1:3,1:3,ipc,ip,el)),[mySize]) case (lp_ID) - mySize = 9_pInt + mySize = 9 crystallite_postResults(c+1:c+mySize) = & reshape(transpose(crystallite_Lp(1:3,1:3,ipc,ip,el)),[mySize]) case (li_ID) - mySize = 9_pInt + mySize = 9 crystallite_postResults(c+1:c+mySize) = & reshape(transpose(crystallite_Li(1:3,1:3,ipc,ip,el)),[mySize]) case (p_ID) - mySize = 9_pInt + mySize = 9 crystallite_postResults(c+1:c+mySize) = & reshape(transpose(crystallite_P(1:3,1:3,ipc,ip,el)),[mySize]) case (s_ID) - mySize = 9_pInt + mySize = 9 crystallite_postResults(c+1:c+mySize) = & reshape(crystallite_S(1:3,1:3,ipc,ip,el),[mySize]) case (elasmatrix_ID) - mySize = 36_pInt + mySize = 36 crystallite_postResults(c+1:c+mySize) = reshape(constitutive_homogenizedC(ipc,ip,el),[mySize]) case(neighboringelement_ID) mySize = theMesh%elem%nIPneighbors crystallite_postResults(c+1:c+mySize) = 0.0_pReal - forall (n = 1_pInt:mySize) & + forall (n = 1:mySize) & crystallite_postResults(c+n) = real(mesh_ipNeighborhood(1,n,ip,el),pReal) case(neighboringip_ID) mySize = theMesh%elem%nIPneighbors crystallite_postResults(c+1:c+mySize) = 0.0_pReal - forall (n = 1_pInt:mySize) & + forall (n = 1:mySize) & crystallite_postResults(c+n) = real(mesh_ipNeighborhood(2,n,ip,el),pReal) end select c = c + mySize enddo crystallite_postResults(c+1) = real(plasticState(material_phase(ipc,ip,el))%sizePostResults,pReal) ! size of constitutive results - c = c + 1_pInt - if (size(crystallite_postResults)-c > 0_pInt) & + c = c + 1 + if (size(crystallite_postResults)-c > 0) & crystallite_postResults(c+1:size(crystallite_postResults)) = & constitutive_postResults(crystallite_S(1:3,1:3,ipc,ip,el), crystallite_Fi(1:3,1:3,ipc,ip,el), & ipc, ip, el) @@ -1099,7 +1098,7 @@ logical function integrateStress(& math_9to33 implicit none - integer(pInt), intent(in):: el, & ! element index + integer, intent(in):: el, & ! element index ip, & ! integration point index ipc ! grain index real(pReal), optional, intent(in) :: timeFraction ! fraction of timestep @@ -1129,8 +1128,8 @@ logical function integrateStress(& B, & Fe, & ! elastic deformation gradient temp_33 - real(pReal), dimension(9):: work ! needed for matrix inversion by LAPACK - integer(pInt), dimension(9) :: devNull ! needed for matrix inversion by LAPACK + real(pReal), dimension(9) :: work ! needed for matrix inversion by LAPACK + integer, dimension(9) :: devNull ! needed for matrix inversion by LAPACK real(pReal), dimension(9,9) :: dRLp_dLp, & ! partial derivative of residuum (Jacobian for Newton-Raphson scheme) dRLp_dLp2, & ! working copy of dRdLp dRLi_dLi ! partial derivative of residuumI (Jacobian for Newton-Raphson scheme) @@ -1149,7 +1148,7 @@ logical function integrateStress(& dt, & ! time increment aTolLp, & aTolLi - integer(pInt) NiterationStressLp, & ! number of stress integrations + integer NiterationStressLp, & ! number of stress integrations NiterationStressLi, & ! number of inner stress integrations ierr, & ! error indicator for LAPACK o, & @@ -1162,9 +1161,9 @@ logical function integrateStress(& !* be pessimistic integrateStress = .false. #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) & write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST integrateStress >> at el ip ipc ',el,ip,ipc #endif @@ -1186,10 +1185,10 @@ logical function integrateStress(& invFp_current = math_inv33(crystallite_subFp0(1:3,1:3,ipc,ip,el)) failedInversionFp: if (all(dEq0(invFp_current))) then #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) & + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) & write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST integrateStress >> failed on inversion of current Fp at el ip ipc ',& el,ip,ipc - if (iand(debug_level(debug_crystallite), debug_levelExtensive) > 0_pInt) & + if (iand(debug_level(debug_crystallite), debug_levelExtensive) > 0) & write(6,'(/,a,/,3(12x,3(f12.7,1x)/))') '<< CRYST >> current Fp ',transpose(crystallite_subFp0(1:3,1:3,ipc,ip,el)) #endif return @@ -1199,10 +1198,10 @@ logical function integrateStress(& invFi_current = math_inv33(crystallite_subFi0(1:3,1:3,ipc,ip,el)) failedInversionFi: if (all(dEq0(invFi_current))) then #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) & + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) & write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST integrateStress >> failed on inversion of current Fi at el ip ipc ',& el,ip,ipc - if (iand(debug_level(debug_crystallite), debug_levelExtensive) > 0_pInt) & + if (iand(debug_level(debug_crystallite), debug_levelExtensive) > 0) & write(6,'(/,a,/,3(12x,3(f12.7,1x)/))') '<< CRYST integrateStress >> current Fi ', & transpose(crystallite_subFi0(1:3,1:3,ipc,ip,el)) #endif @@ -1210,16 +1209,16 @@ logical function integrateStress(& endif failedInversionFi !* start Li loop with normal step length - NiterationStressLi = 0_pInt - jacoCounterLi = 0_pInt + NiterationStressLi = 0 + jacoCounterLi = 0 steplengthLi = 1.0_pReal residuumLi_old = 0.0_pReal LiLoop: do - NiterationStressLi = NiterationStressLi + 1_pInt + NiterationStressLi = NiterationStressLi + 1 LiLoopLimit: if (NiterationStressLi > nStress) then #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) & + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) & write(6,'(a,i3,a,i8,1x,i2,1x,i3,/)') '<< CRYST integrateStress >> reached Li loop limit',nStress, & ' at el ip ipc ', el,ip,ipc #endif @@ -1231,17 +1230,17 @@ logical function integrateStress(& detInvFi = math_det33(invFi_new) !* start Lp loop with normal step length - NiterationStressLp = 0_pInt - jacoCounterLp = 0_pInt + NiterationStressLp = 0 + jacoCounterLp = 0 steplengthLp = 1.0_pReal residuumLp_old = 0.0_pReal Lpguess_old = Lpguess LpLoop: do - NiterationStressLp = NiterationStressLp + 1_pInt + NiterationStressLp = NiterationStressLp + 1 LpLoopLimit: if (NiterationStressLp > nStress) then #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) & + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) & write(6,'(a,i3,a,i8,1x,i2,1x,i3,/)') '<< CRYST integrateStress >> reached Lp loop limit',nStress, & ' at el ip ipc ', el,ip,ipc #endif @@ -1260,9 +1259,9 @@ logical function integrateStress(& S, Fi_new, ipc, ip, el) #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) then write(6,'(a,i3,/)') '<< CRYST integrateStress >> iteration ', NiterationStressLp write(6,'(a,/,3(12x,3(e20.10,1x)/))') '<< CRYST integrateStress >> Lpguess', transpose(Lpguess) write(6,'(a,/,3(12x,3(e20.10,1x)/))') '<< CRYST integrateStress >> Lp_constitutive', transpose(Lp_constitutive) @@ -1279,7 +1278,7 @@ logical function integrateStress(& if (any(IEEE_is_NaN(residuumLp))) then #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) & + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) & write(6,'(a,i8,1x,i2,1x,i3,a,i3,a)') '<< CRYST integrateStress >> encountered NaN for Lp-residuum at el ip ipc ', & el,ip,ipc, & ' ; iteration ', NiterationStressLp,& @@ -1288,7 +1287,7 @@ logical function integrateStress(& return ! ...me = .false. to inform integrator about problem elseif (norm2(residuumLp) < aTolLp) then ! converged if below absolute tolerance exit LpLoop ! ...leave iteration loop - elseif ( NiterationStressLp == 1_pInt & + 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 @@ -1297,9 +1296,9 @@ logical function integrateStress(& steplengthLp = subStepSizeLp * steplengthLp ! ...try with smaller step length in same direction Lpguess = Lpguess_old + steplengthLp * deltaLp #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) then write(6,'(a,1x,f7.4)') '<< CRYST integrateStress >> linear search for Lpguess with step', steplengthLp endif #endif @@ -1308,32 +1307,32 @@ logical function integrateStress(& !* calculate Jacobian for correction term - if (mod(jacoCounterLp, iJacoLpresiduum) == 0_pInt) then - forall(o=1_pInt:3_pInt,p=1_pInt:3_pInt) dFe_dLp(o,1:3,p,1:3) = A(o,p)*transpose(invFi_new) ! dFe_dLp(i,j,k,l) = -dt * A(i,k) invFi(l,j) + if (mod(jacoCounterLp, iJacoLpresiduum) == 0) then + forall(o=1:3,p=1:3) dFe_dLp(o,1:3,p,1:3) = A(o,p)*transpose(invFi_new) ! dFe_dLp(i,j,k,l) = -dt * A(i,k) invFi(l,j) dFe_dLp = - dt * dFe_dLp - dRLp_dLp = math_identity2nd(9_pInt) & + dRLp_dLp = math_identity2nd(9) & - math_3333to99(math_mul3333xx3333(math_mul3333xx3333(dLp_dS,dS_dFe),dFe_dLp)) #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) then write(6,'(a,/,9(12x,9(e12.4,1x)/))') '<< CRYST integrateStress >> dLp_dS', math_3333to99(dLp_dS) write(6,'(a,1x,e20.10)') '<< CRYST integrateStress >> dLp_dS norm', norm2(math_3333to99(dLp_dS)) - write(6,'(a,/,9(12x,9(e12.4,1x)/))') '<< CRYST integrateStress >> dRLp_dLp', dRLp_dLp-math_identity2nd(9_pInt) - write(6,'(a,1x,e20.10)') '<< CRYST integrateStress >> dRLp_dLp norm', norm2(dRLp_dLp-math_identity2nd(9_pInt)) + write(6,'(a,/,9(12x,9(e12.4,1x)/))') '<< CRYST integrateStress >> dRLp_dLp', dRLp_dLp-math_identity2nd(9) + write(6,'(a,1x,e20.10)') '<< CRYST integrateStress >> dRLp_dLp norm', norm2(dRLp_dLp-math_identity2nd(9)) endif #endif dRLp_dLp2 = dRLp_dLp ! will be overwritten in first call to LAPACK routine work = math_33to9(residuumLp) call dgesv(9,1,dRLp_dLp2,9,devNull,work,9,ierr) ! solve dRLp/dLp * delta Lp = -res for delta Lp - if (ierr /= 0_pInt) then + if (ierr /= 0) then #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) then + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) then write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST integrateStress >> failed on dR/dLp inversion at el ip ipc ', & el,ip,ipc - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g)& - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) then write(6,*) write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST integrateStress >> dR_dLp',transpose(dRLp_dLp) write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST integrateStress >> dFe_dLp',transpose(math_3333to99(dFe_dLp)) @@ -1350,7 +1349,7 @@ logical function integrateStress(& endif deltaLp = - math_9to33(work) endif - jacoCounterLp = jacoCounterLp + 1_pInt + jacoCounterLp = jacoCounterLp + 1 Lpguess = Lpguess + steplengthLp * deltaLp @@ -1361,9 +1360,9 @@ logical function integrateStress(& S, Fi_new, ipc, ip, el) #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) then write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST integrateStress >> Li_constitutive', transpose(Li_constitutive) write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST integrateStress >> Liguess', transpose(Liguess) endif @@ -1375,7 +1374,7 @@ logical function integrateStress(& residuumLi = Liguess - Li_constitutive if (any(IEEE_is_NaN(residuumLi))) then ! NaN in residuum... #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) & + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) & write(6,'(a,i8,1x,i2,1x,i3,a,i3,a)') '<< CRYST integrateStress >> encountered NaN for Li-residuum at el ip ipc ', & el,ip,ipc, & ' ; iteration ', NiterationStressLi,& @@ -1384,7 +1383,7 @@ logical function integrateStress(& return ! ...me = .false. to inform integrator about problem elseif (norm2(residuumLi) < aTolLi) then ! converged if below absolute tolerance exit LiLoop ! ...leave iteration loop - elseif ( NiterationStressLi == 1_pInt & + 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 @@ -1396,29 +1395,29 @@ logical function integrateStress(& endif !* calculate Jacobian for correction term - if (mod(jacoCounterLi, iJacoLpresiduum) == 0_pInt) then + if (mod(jacoCounterLi, iJacoLpresiduum) == 0) then temp_33 = matmul(matmul(A,B),invFi_current) - forall(o=1_pInt:3_pInt,p=1_pInt:3_pInt) + forall(o=1:3,p=1:3) dFe_dLi(1:3,o,1:3,p) = -dt*math_I3(o,p)*temp_33 ! dFe_dLp(i,j,k,l) = -dt * A(i,k) invFi(l,j) dFi_dLi(1:3,o,1:3,p) = -dt*math_I3(o,p)*invFi_current end forall - forall(o=1_pInt:3_pInt,p=1_pInt:3_pInt) & + forall(o=1:3,p=1:3) & dFi_dLi(1:3,1:3,o,p) = matmul(matmul(Fi_new,dFi_dLi(1:3,1:3,o,p)),Fi_new) - dRLi_dLi = math_identity2nd(9_pInt) & + dRLi_dLi = math_identity2nd(9) & - math_3333to99(math_mul3333xx3333(dLi_dS, math_mul3333xx3333(dS_dFe, dFe_dLi) + & math_mul3333xx3333(dS_dFi, dFi_dLi))) & - math_3333to99(math_mul3333xx3333(dLi_dFi, dFi_dLi)) work = math_33to9(residuumLi) call dgesv(9,1,dRLi_dLi,9,devNull,work,9,ierr) ! solve dRLi/dLp * delta Li = -res for delta Li - if (ierr /= 0_pInt) then + if (ierr /= 0) then #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) then + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) then write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST integrateStress >> failed on dR/dLi inversion at el ip ipc ', & el,ip,ipc - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g)& - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) then write(6,*) write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST integrateStress >> dR_dLi',transpose(dRLi_dLi) write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST integrateStress >> dFe_dLi',transpose(math_3333to99(dFe_dLi)) @@ -1434,7 +1433,7 @@ logical function integrateStress(& deltaLi = - math_9to33(work) endif - jacoCounterLi = jacoCounterLi + 1_pInt + jacoCounterLi = jacoCounterLi + 1 Liguess = Liguess + steplengthLi * deltaLi enddo LiLoop @@ -1445,12 +1444,12 @@ logical function integrateStress(& Fp_new = math_inv33(invFp_new) failedInversionInvFp: if (all(dEq0(Fp_new))) then #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) then + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) then write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST integrateStress >> failed on invFp_new inversion at el ip ipc ', & el,ip,ipc - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) & write(6,'(/,a,/,3(12x,3(f12.7,1x)/))') '<< CRYST integrateStress >> invFp_new',transpose(invFp_new) endif #endif @@ -1473,9 +1472,9 @@ logical function integrateStress(& crystallite_invFi(1:3,1:3,ipc,ip,el) = invFi_new #ifdef DEBUG - if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt & + if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0 & .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) then write(6,'(a,/)') '<< CRYST integrateStress >> successful integration' write(6,'(a,/,3(12x,3(f12.7,1x)/))') '<< CRYST integrateStress >> P / MPa', & transpose(crystallite_P(1:3,1:3,ipc,ip,el))*1.0e-6_pReal @@ -1522,7 +1521,7 @@ subroutine integrateStateFPI() implicit none - integer(pInt) :: & + integer :: & NiterationState, & !< number of iterations in state loop e, & !< element index in element loop i, & !< integration point index in ip loop @@ -1544,13 +1543,13 @@ subroutine integrateStateFPI() call update_dotState(1.0_pReal) call update_state(1.0_pReal) - NiterationState = 0_pInt + NiterationState = 0 doneWithIntegration = .false. crystalliteLooping: do while (.not. doneWithIntegration .and. NiterationState < nState) - NiterationState = NiterationState + 1_pInt + NiterationState = NiterationState + 1 #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0) & write(6,'(a,i6)') '<< CRYST stateFPI >> state iteration ',NiterationState #endif @@ -1565,12 +1564,12 @@ subroutine integrateStateFPI() plasticState(p)%previousDotState2(:,c) = merge(plasticState(p)%previousDotState(:,c),& 0.0_pReal,& - NiterationState > 1_pInt) + NiterationState > 1) plasticState(p)%previousDotState (:,c) = plasticState(p)%dotState(:,c) - do s = 1_pInt, phase_Nsources(p) + do s = 1, phase_Nsources(p) sourceState(p)%p(s)%previousDotState2(:,c) = merge(sourceState(p)%p(s)%previousDotState(:,c),& 0.0_pReal, & - NiterationState > 1_pInt) + NiterationState > 1) sourceState(p)%p(s)%previousDotState (:,c) = sourceState(p)%p(s)%dotState(:,c) enddo endif @@ -1612,7 +1611,7 @@ subroutine integrateStateFPI() plasticState(p)%aTolState(1:sizeDotState)) - do s = 1_pInt, phase_Nsources(p) + do s = 1, phase_Nsources(p) sizeDotState = sourceState(p)%p(s)%sizeDotState zeta = damper(sourceState(p)%p(s)%dotState (:,c), & @@ -1744,7 +1743,7 @@ subroutine integrateStateAdaptiveEuler() constitutive_source_maxSizeDotState implicit none - integer(pInt) :: & + integer :: & e, & ! element index in element loop i, & ! integration point index in ip loop g, & ! grain index in grain loop @@ -1778,7 +1777,7 @@ subroutine integrateStateAdaptiveEuler() * (- 0.5_pReal * crystallite_subdt(g,i,e)) plasticState(p)%state(1:sizeDotState,c) = & plasticState(p)%state(1:sizeDotState,c) + plasticState(p)%dotstate(1:sizeDotState,c) * crystallite_subdt(g,i,e) !ToDo: state, partitioned state? - do s = 1_pInt, phase_Nsources(p) + do s = 1, phase_Nsources(p) sizeDotState = sourceState(p)%p(s)%sizeDotState residuum_source(1:sizeDotState,s,g,i,e) = sourceState(p)%p(s)%dotstate(1:sizeDotState,c) & @@ -1810,7 +1809,7 @@ subroutine integrateStateAdaptiveEuler() plasticState(p)%state(1:sizeDotState,c), & plasticState(p)%aTolState(1:sizeDotState)) - do s = 1_pInt, phase_Nsources(p) + do s = 1, phase_Nsources(p) sizeDotState = sourceState(p)%p(s)%sizeDotState residuum_source(1:sizeDotState,s,g,i,e) = & @@ -1851,7 +1850,7 @@ subroutine integrateStateRK4() real(pReal), dimension(4), parameter :: & WEIGHT = [1.0_pReal, 2.0_pReal, 2.0_pReal, 1.0_pReal/6.0_pReal] ! weight of slope used for Runge Kutta integration (final weight divided by 6) - integer(pInt) :: e, & ! element index in element loop + integer :: e, & ! element index in element loop i, & ! integration point index in ip loop g, & ! grain index in grain loop p, & ! phase loop @@ -1862,7 +1861,7 @@ subroutine integrateStateRK4() call update_dotState(1.0_pReal) - do n = 1_pInt,4_pInt + do n = 1,4 !$OMP PARALLEL DO PRIVATE(p,c) do e = FEsolving_execElem(1),FEsolving_execElem(2) @@ -1872,10 +1871,10 @@ subroutine integrateStateRK4() p = phaseAt(g,i,e); c = phasememberAt(g,i,e) plasticState(p)%RK4dotState(:,c) = WEIGHT(n)*plasticState(p)%dotState(:,c) & - + merge(plasticState(p)%RK4dotState(:,c),0.0_pReal,n>1_pInt) - do s = 1_pInt, phase_Nsources(p) + + merge(plasticState(p)%RK4dotState(:,c),0.0_pReal,n>1) + do s = 1, phase_Nsources(p) sourceState(p)%p(s)%RK4dotState(:,c) = WEIGHT(n)*sourceState(p)%p(s)%dotState(:,c) & - + merge(sourceState(p)%p(s)%RK4dotState(:,c),0.0_pReal,n>1_pInt) + + merge(sourceState(p)%p(s)%RK4dotState(:,c),0.0_pReal,n>1) enddo endif enddo; enddo; enddo @@ -1939,7 +1938,7 @@ subroutine integrateStateRKCK45() real(pReal), dimension(5), parameter :: & C = [0.2_pReal, 0.3_pReal, 0.6_pReal, 1.0_pReal, 0.875_pReal] !< coefficients in Butcher tableau (fractions of original time step in stages 2 to 6) - integer(pInt) :: & + integer :: & e, & ! element index in element loop i, & ! integration point index in ip loop g, & ! grain index in grain loop @@ -1965,7 +1964,7 @@ subroutine integrateStateRKCK45() ! --- SECOND TO SIXTH RUNGE KUTTA STEP --- - do stage = 1_pInt,5_pInt + do stage = 1,5 ! --- state update --- @@ -1979,15 +1978,15 @@ subroutine integrateStateRKCK45() plasticState(p)%RKCK45dotState(stage,:,cc) = plasticState(p)%dotState(:,cc) plasticState(p)%dotState(:,cc) = A(1,stage) * plasticState(p)%RKCK45dotState(1,:,cc) - do s = 1_pInt, phase_Nsources(p) + do s = 1, phase_Nsources(p) sourceState(p)%p(s)%RKCK45dotState(stage,:,cc) = sourceState(p)%p(s)%dotState(:,cc) sourceState(p)%p(s)%dotState(:,cc) = A(1,stage) * sourceState(p)%p(s)%RKCK45dotState(1,:,cc) enddo - do n = 2_pInt, stage + do n = 2, stage plasticState(p)%dotState(:,cc) = plasticState(p)%dotState(:,cc) & + A(n,stage) * plasticState(p)%RKCK45dotState(n,:,cc) - do s = 1_pInt, phase_Nsources(p) + do s = 1, phase_Nsources(p) sourceState(p)%p(s)%dotState(:,cc) = sourceState(p)%p(s)%dotState(:,cc) & + A(n,stage) * sourceState(p)%p(s)%RKCK45dotState(n,:,cc) enddo @@ -2027,7 +2026,7 @@ subroutine integrateStateRKCK45() plasticState(p)%dotState(:,cc) = & matmul(transpose(plasticState(p)%RKCK45dotState(1:6,1:sizeDotState,cc)), B) ! why transpose? Better to transpose constant B - do s = 1_pInt, phase_Nsources(p) + do s = 1, phase_Nsources(p) sizeDotState = sourceState(p)%p(s)%sizeDotState sourceState(p)%p(s)%RKCK45dotState(6,:,cc) = sourceState(p)%p(s)%dotState(:,cc) @@ -2061,7 +2060,7 @@ subroutine integrateStateRKCK45() plasticState(p)%state(1:sizeDotState,cc), & plasticState(p)%aTolState(1:sizeDotState)) - do s = 1_pInt, phase_Nsources(p) + do s = 1, phase_Nsources(p) sizeDotState = sourceState(p)%p(s)%sizeDotState crystallite_todo(g,i,e) = & @@ -2105,7 +2104,7 @@ subroutine setConvergenceFlag() use mesh, only: & mesh_element implicit none - integer(pInt) :: & + integer :: & e, & !< element index in element loop i, & !< integration point index in ip loop g !< grain index in grain loop @@ -2148,7 +2147,7 @@ subroutine update_stress(timeFraction) implicit none real(pReal), intent(in) :: & timeFraction - integer(pInt) :: & + integer :: & e, & !< element index in element loop i, & !< integration point index in ip loop g @@ -2182,7 +2181,7 @@ subroutine update_dependentState() constitutive_dependentState => constitutive_microstructure implicit none - integer(pInt) :: e, & ! element index in element loop + integer :: e, & ! element index in element loop i, & ! integration point index in ip loop g ! grain index in grain loop @@ -2215,7 +2214,7 @@ subroutine update_state(timeFraction) implicit none real(pReal), intent(in) :: & timeFraction - integer(pInt) :: & + integer :: & e, & !< element index in element loop i, & !< integration point index in ip loop g, & !< grain index in grain loop @@ -2235,7 +2234,7 @@ subroutine update_state(timeFraction) plasticState(p)%state(1:mySize,c) = plasticState(p)%subState0(1:mySize,c) & + plasticState(p)%dotState (1:mySize,c) & * crystallite_subdt(g,i,e) * timeFraction - do s = 1_pInt, phase_Nsources(p) + do s = 1, phase_Nsources(p) mySize = sourceState(p)%p(s)%sizeDotState sourceState(p)%p(s)%state(1:mySize,c) = sourceState(p)%p(s)%subState0(1:mySize,c) & + sourceState(p)%p(s)%dotState (1:mySize,c) & @@ -2268,7 +2267,7 @@ subroutine update_dotState(timeFraction) implicit none real(pReal), intent(in) :: & timeFraction - integer(pInt) :: & + integer :: & e, & !< element index in element loop i, & !< integration point index in ip loop g, & !< grain index in grain loop @@ -2294,7 +2293,7 @@ subroutine update_dotState(timeFraction) crystallite_subdt(g,i,e)*timeFraction, g,i,e) p = phaseAt(g,i,e); c = phasememberAt(g,i,e) NaN = any(IEEE_is_NaN(plasticState(p)%dotState(:,c))) - do s = 1_pInt, phase_Nsources(p) + do s = 1, phase_Nsources(p) NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(s)%dotState(:,c))) enddo if (NaN) then @@ -2325,7 +2324,7 @@ subroutine update_deltaState use constitutive, only: & constitutive_collectDeltaState implicit none - integer(pInt) :: & + integer :: & e, & !< element index in element loop i, & !< integration point index in ip loop g, & !< grain index in grain loop @@ -2357,16 +2356,16 @@ subroutine update_deltaState if (.not. NaN) then - plasticState(p)%state(myOffset + 1_pInt: myOffset + mySize,c) = & - plasticState(p)%state(myOffset + 1_pInt: myOffset + mySize,c) + plasticState(p)%deltaState(1:mySize,c) - do s = 1_pInt, phase_Nsources(p) + plasticState(p)%state(myOffset + 1: myOffset + mySize,c) = & + plasticState(p)%state(myOffset + 1: myOffset + mySize,c) + plasticState(p)%deltaState(1:mySize,c) + do s = 1, phase_Nsources(p) myOffset = sourceState(p)%p(s)%offsetDeltaState mySize = sourceState(p)%p(s)%sizeDeltaState NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(s)%deltaState(1:mySize,c))) if (.not. NaN) then - sourceState(p)%p(s)%state(myOffset + 1_pInt:myOffset + mySize,c) = & - sourceState(p)%p(s)%state(myOffset + 1_pInt:myOffset + mySize,c) + sourceState(p)%p(s)%deltaState(1:mySize,c) + sourceState(p)%p(s)%state(myOffset + 1:myOffset + mySize,c) = & + sourceState(p)%p(s)%state(myOffset + 1:myOffset + mySize,c) + sourceState(p)%p(s)%deltaState(1:mySize,c) endif enddo endif @@ -2414,12 +2413,12 @@ logical function stateJump(ipc,ip,el) constitutive_collectDeltaState implicit none - integer(pInt), intent(in):: & + integer, intent(in):: & el, & ! element index ip, & ! integration point index ipc ! grain index - integer(pInt) :: & + integer :: & c, & p, & mySource, & @@ -2442,29 +2441,29 @@ logical function stateJump(ipc,ip,el) return endif - plasticState(p)%state(myOffset + 1_pInt:myOffset + mySize,c) = & - plasticState(p)%state(myOffset + 1_pInt:myOffset + mySize,c) + plasticState(p)%deltaState(1:mySize,c) + plasticState(p)%state(myOffset + 1:myOffset + mySize,c) = & + plasticState(p)%state(myOffset + 1:myOffset + mySize,c) + plasticState(p)%deltaState(1:mySize,c) - do mySource = 1_pInt, phase_Nsources(p) + do mySource = 1, phase_Nsources(p) myOffset = sourceState(p)%p(mySource)%offsetDeltaState mySize = sourceState(p)%p(mySource)%sizeDeltaState if (any(IEEE_is_NaN(sourceState(p)%p(mySource)%deltaState(1:mySize,c)))) then ! NaN occured in deltaState stateJump = .false. return endif - sourceState(p)%p(mySource)%state(myOffset + 1_pInt: myOffset + mySize,c) = & - sourceState(p)%p(mySource)%state(myOffset + 1_pInt: myOffset + mySize,c) + sourceState(p)%p(mySource)%deltaState(1:mySize,c) + sourceState(p)%p(mySource)%state(myOffset + 1: myOffset + mySize,c) = & + sourceState(p)%p(mySource)%state(myOffset + 1: myOffset + mySize,c) + sourceState(p)%p(mySource)%deltaState(1:mySize,c) enddo #ifdef DEBUG if (any(dNeq0(plasticState(p)%deltaState(1:mySize,c))) & - .and. iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) then write(6,'(a,i8,1x,i2,1x,i3, /)') '<< CRYST >> update state at el ip ipc ',el,ip,ipc write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> deltaState', plasticState(p)%deltaState(1:mySize,c) write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> new state', & - plasticState(p)%state(myOffset + 1_pInt : & + plasticState(p)%state(myOffset + 1 : & myOffset + mySize,c) endif #endif From e33807aab30fbb08abae7aa1a407b458bd2ac55c Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 3 Apr 2019 12:54:07 +0200 Subject: [PATCH 35/47] fixed indentation --- src/crystallite.f90 | 2305 +++++++++++++++++++++---------------------- 1 file changed, 1149 insertions(+), 1156 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 2ab66d970..4fa85173d 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -9,117 +9,117 @@ !-------------------------------------------------------------------------------------------------- module crystallite - use prec, only: & - pReal - use rotations, only: & - rotation - use FEsolving, only: & - FEsolving_execElem, & - FEsolving_execIP - use material, only: & - homogenization_Ngrains - - implicit none - - private - character(len=64), dimension(:,:), allocatable, private :: & - crystallite_output !< name of each post result output - integer, public, protected :: & - crystallite_maxSizePostResults !< description not available - integer, dimension(:), allocatable, public, protected :: & - crystallite_sizePostResults !< description not available - integer, dimension(:,:), allocatable, private :: & - crystallite_sizePostResult !< description not available - - real(pReal), dimension(:,:,:), allocatable, public :: & - crystallite_dt !< requested time increment of each grain - real(pReal), dimension(:,:,:), allocatable, private :: & - crystallite_subdt, & !< substepped time increment of each grain - crystallite_subFrac, & !< already calculated fraction of increment - crystallite_subStep !< size of next integration step - type(rotation), dimension(:,:,:), allocatable, private :: & - crystallite_orientation, & !< orientation - crystallite_orientation0 !< initial orientation - real(pReal), dimension(:,:,:,:,:), allocatable, public, protected :: & - crystallite_Fe, & !< current "elastic" def grad (end of converged time step) - crystallite_P !< 1st Piola-Kirchhoff stress per grain - real(pReal), dimension(:,:,:,:,:), allocatable, public :: & - crystallite_S, & !< current 2nd Piola-Kirchhoff stress vector (end of converged time step) - crystallite_S0, & !< 2nd Piola-Kirchhoff stress vector at start of FE inc - crystallite_partionedS0, & !< 2nd Piola-Kirchhoff stress vector at start of homog inc - crystallite_Fp, & !< current plastic def grad (end of converged time step) - crystallite_Fp0, & !< plastic def grad at start of FE inc - crystallite_partionedFp0,& !< plastic def grad at start of homog inc - crystallite_Fi, & !< current intermediate def grad (end of converged time step) - crystallite_Fi0, & !< intermediate def grad at start of FE inc - crystallite_partionedFi0,& !< intermediate def grad at start of homog inc - crystallite_F0, & !< def grad at start of FE inc - crystallite_partionedF, & !< def grad to be reached at end of homog inc - crystallite_partionedF0, & !< def grad at start of homog inc - crystallite_Lp, & !< current plastic velocitiy grad (end of converged time step) - crystallite_Lp0, & !< plastic velocitiy grad at start of FE inc - crystallite_partionedLp0, & !< plastic velocity grad at start of homog inc - crystallite_Li, & !< current intermediate velocitiy grad (end of converged time step) - crystallite_Li0, & !< intermediate velocitiy grad at start of FE inc - crystallite_partionedLi0 !< intermediate velocity grad at start of homog inc - real(pReal), dimension(:,:,:,:,:), allocatable, private :: & - crystallite_subS0, & !< 2nd Piola-Kirchhoff stress vector at start of crystallite inc - crystallite_invFp, & !< inverse of current plastic def grad (end of converged time step) - crystallite_subFp0,& !< plastic def grad at start of crystallite inc - crystallite_invFi, & !< inverse of current intermediate def grad (end of converged time step) - crystallite_subFi0,& !< intermediate def grad at start of crystallite inc - crystallite_subF, & !< def grad to be reached at end of crystallite inc - crystallite_subF0, & !< def grad at start of crystallite inc - crystallite_subLp0,& !< plastic velocity grad at start of crystallite inc - crystallite_subLi0 !< intermediate velocity grad at start of crystallite inc - real(pReal), dimension(:,:,:,:,:,:,:), allocatable, public :: & - crystallite_dPdF !< current individual dPdF per grain (end of converged time step) - logical, dimension(:,:,:), allocatable, public :: & - crystallite_requested !< used by upper level (homogenization) to request crystallite calculation - logical, dimension(:,:,:), allocatable, private :: & - crystallite_converged, & !< convergence flag - crystallite_todo, & !< flag to indicate need for further computation - crystallite_localPlasticity !< indicates this grain to have purely local constitutive law - - enum, bind(c) - enumerator :: undefined_ID, & - phase_ID, & - texture_ID, & - volume_ID, & - orientation_ID, & - grainrotation_ID, & - defgrad_ID, & - fe_ID, & - fp_ID, & - fi_ID, & - lp_ID, & - li_ID, & - p_ID, & - s_ID, & - elasmatrix_ID, & - neighboringip_ID, & - neighboringelement_ID - end enum - integer(kind(undefined_ID)),dimension(:,:), allocatable, private :: & - crystallite_outputID !< ID of each post result output - procedure(), pointer :: integrateState - - public :: & - crystallite_init, & - crystallite_stress, & - crystallite_stressTangent, & - crystallite_orientations, & - crystallite_push33ToRef, & - crystallite_postResults - private :: & - integrateStress, & - integrateState, & - integrateStateFPI, & - integrateStateEuler, & - integrateStateAdaptiveEuler, & - integrateStateRK4, & - integrateStateRKCK45, & - stateJump + use prec, only: & + pReal + use rotations, only: & + rotation + use FEsolving, only: & + FEsolving_execElem, & + FEsolving_execIP + use material, only: & + homogenization_Ngrains + + implicit none + + private + character(len=64), dimension(:,:), allocatable, private :: & + crystallite_output !< name of each post result output + integer, public, protected :: & + crystallite_maxSizePostResults !< description not available + integer, dimension(:), allocatable, public, protected :: & + crystallite_sizePostResults !< description not available + integer, dimension(:,:), allocatable, private :: & + crystallite_sizePostResult !< description not available + + real(pReal), dimension(:,:,:), allocatable, public :: & + crystallite_dt !< requested time increment of each grain + real(pReal), dimension(:,:,:), allocatable, private :: & + crystallite_subdt, & !< substepped time increment of each grain + crystallite_subFrac, & !< already calculated fraction of increment + crystallite_subStep !< size of next integration step + type(rotation), dimension(:,:,:), allocatable, private :: & + crystallite_orientation, & !< orientation + crystallite_orientation0 !< initial orientation + real(pReal), dimension(:,:,:,:,:), allocatable, public, protected :: & + crystallite_Fe, & !< current "elastic" def grad (end of converged time step) + crystallite_P !< 1st Piola-Kirchhoff stress per grain + real(pReal), dimension(:,:,:,:,:), allocatable, public :: & + crystallite_S, & !< current 2nd Piola-Kirchhoff stress vector (end of converged time step) + crystallite_S0, & !< 2nd Piola-Kirchhoff stress vector at start of FE inc + crystallite_partionedS0, & !< 2nd Piola-Kirchhoff stress vector at start of homog inc + crystallite_Fp, & !< current plastic def grad (end of converged time step) + crystallite_Fp0, & !< plastic def grad at start of FE inc + crystallite_partionedFp0,& !< plastic def grad at start of homog inc + crystallite_Fi, & !< current intermediate def grad (end of converged time step) + crystallite_Fi0, & !< intermediate def grad at start of FE inc + crystallite_partionedFi0,& !< intermediate def grad at start of homog inc + crystallite_F0, & !< def grad at start of FE inc + crystallite_partionedF, & !< def grad to be reached at end of homog inc + crystallite_partionedF0, & !< def grad at start of homog inc + crystallite_Lp, & !< current plastic velocitiy grad (end of converged time step) + crystallite_Lp0, & !< plastic velocitiy grad at start of FE inc + crystallite_partionedLp0, & !< plastic velocity grad at start of homog inc + crystallite_Li, & !< current intermediate velocitiy grad (end of converged time step) + crystallite_Li0, & !< intermediate velocitiy grad at start of FE inc + crystallite_partionedLi0 !< intermediate velocity grad at start of homog inc + real(pReal), dimension(:,:,:,:,:), allocatable, private :: & + crystallite_subS0, & !< 2nd Piola-Kirchhoff stress vector at start of crystallite inc + crystallite_invFp, & !< inverse of current plastic def grad (end of converged time step) + crystallite_subFp0,& !< plastic def grad at start of crystallite inc + crystallite_invFi, & !< inverse of current intermediate def grad (end of converged time step) + crystallite_subFi0,& !< intermediate def grad at start of crystallite inc + crystallite_subF, & !< def grad to be reached at end of crystallite inc + crystallite_subF0, & !< def grad at start of crystallite inc + crystallite_subLp0,& !< plastic velocity grad at start of crystallite inc + crystallite_subLi0 !< intermediate velocity grad at start of crystallite inc + real(pReal), dimension(:,:,:,:,:,:,:), allocatable, public :: & + crystallite_dPdF !< current individual dPdF per grain (end of converged time step) + logical, dimension(:,:,:), allocatable, public :: & + crystallite_requested !< used by upper level (homogenization) to request crystallite calculation + logical, dimension(:,:,:), allocatable, private :: & + crystallite_converged, & !< convergence flag + crystallite_todo, & !< flag to indicate need for further computation + crystallite_localPlasticity !< indicates this grain to have purely local constitutive law + + enum, bind(c) + enumerator :: undefined_ID, & + phase_ID, & + texture_ID, & + volume_ID, & + orientation_ID, & + grainrotation_ID, & + defgrad_ID, & + fe_ID, & + fp_ID, & + fi_ID, & + lp_ID, & + li_ID, & + p_ID, & + s_ID, & + elasmatrix_ID, & + neighboringip_ID, & + neighboringelement_ID + end enum + integer(kind(undefined_ID)),dimension(:,:), allocatable, private :: & + crystallite_outputID !< ID of each post result output + procedure(), pointer :: integrateState + + public :: & + crystallite_init, & + crystallite_stress, & + crystallite_stressTangent, & + crystallite_orientations, & + crystallite_push33ToRef, & + crystallite_postResults + private :: & + integrateStress, & + integrateState, & + integrateStateFPI, & + integrateStateEuler, & + integrateStateAdaptiveEuler, & + integrateStateRK4, & + integrateStateRKCK45, & + stateJump contains @@ -129,274 +129,274 @@ contains !-------------------------------------------------------------------------------------------------- subroutine crystallite_init #ifdef DEBUG - use debug, only: & - debug_info, & - debug_reset, & - debug_level, & - debug_crystallite, & - debug_levelBasic + use debug, only: & + debug_info, & + debug_reset, & + debug_level, & + debug_crystallite, & + debug_levelBasic #endif - use numerics, only: & - numerics_integrator, & - worldrank, & - usePingPong - use math, only: & - math_I3, & - math_EulerToR, & - math_inv33 - use mesh, only: & - theMesh, & - mesh_element - use IO, only: & - IO_stringValue, & - IO_write_jobFile, & - IO_error - use material - use config, only: & - config_deallocate, & - config_crystallite, & - crystallite_name - use constitutive, only: & - constitutive_initialFi, & - constitutive_microstructure ! derived (shortcut) quantities of given state - - implicit none - - integer, parameter :: FILEUNIT=434 - logical, dimension(:,:), allocatable :: devNull - integer :: & - c, & !< counter in integration point component loop - i, & !< counter in integration point loop - e, & !< counter in element loop - o = 0, & !< counter in output loop - r, & - cMax, & !< maximum number of integration point components - iMax, & !< maximum number of integration points - eMax, & !< maximum number of elements - myNcomponents, & !< number of components at current IP - mySize - - character(len=65536), dimension(:), allocatable :: str - - write(6,'(/,a)') ' <<<+- crystallite init -+>>>' - - cMax = homogenization_maxNgrains - iMax = theMesh%elem%nIPs - eMax = theMesh%nElems - - allocate(crystallite_S0(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_partionedS0(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_S(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_subS0(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_P(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_F0(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_partionedF0(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_partionedF(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_subF0(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_subF(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_Fp0(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_partionedFp0(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_subFp0(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_Fp(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_invFp(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_Fi0(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_partionedFi0(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_subFi0(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_Fi(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_invFi(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_Fe(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_Lp0(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_partionedLp0(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_subLp0(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_Lp(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_Li0(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_partionedLi0(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_subLi0(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_Li(3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_dPdF(3,3,3,3,cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_dt(cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_subdt(cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_subFrac(cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_subStep(cMax,iMax,eMax), source=0.0_pReal) - allocate(crystallite_orientation(cMax,iMax,eMax)) - allocate(crystallite_orientation0(cMax,iMax,eMax)) - allocate(crystallite_localPlasticity(cMax,iMax,eMax), source=.true.) - allocate(crystallite_requested(cMax,iMax,eMax), source=.false.) - allocate(crystallite_todo(cMax,iMax,eMax), source=.false.) - allocate(crystallite_converged(cMax,iMax,eMax), source=.true.) - allocate(crystallite_output(maxval(crystallite_Noutput), & - size(config_crystallite))) ; crystallite_output = '' - allocate(crystallite_outputID(maxval(crystallite_Noutput), & - size(config_crystallite)), source=undefined_ID) - allocate(crystallite_sizePostResults(size(config_crystallite)),source=0) - allocate(crystallite_sizePostResult(maxval(crystallite_Noutput), & - size(config_crystallite)), source=0) - - select case(numerics_integrator) - case(1) - integrateState => integrateStateFPI - case(2) - integrateState => integrateStateEuler - case(3) - integrateState => integrateStateAdaptiveEuler - case(4) - integrateState => integrateStateRK4 - case(5) - integrateState => integrateStateRKCK45 - end select - - - - do c = 1, size(config_crystallite) + use numerics, only: & + numerics_integrator, & + worldrank, & + usePingPong + use math, only: & + math_I3, & + math_EulerToR, & + math_inv33 + use mesh, only: & + theMesh, & + mesh_element + use IO, only: & + IO_stringValue, & + IO_write_jobFile, & + IO_error + use material + use config, only: & + config_deallocate, & + config_crystallite, & + crystallite_name + use constitutive, only: & + constitutive_initialFi, & + constitutive_microstructure ! derived (shortcut) quantities of given state + + implicit none + + integer, parameter :: FILEUNIT=434 + logical, dimension(:,:), allocatable :: devNull + integer :: & + c, & !< counter in integration point component loop + i, & !< counter in integration point loop + e, & !< counter in element loop + o = 0, & !< counter in output loop + r, & + cMax, & !< maximum number of integration point components + iMax, & !< maximum number of integration points + eMax, & !< maximum number of elements + myNcomponents, & !< number of components at current IP + mySize + + character(len=65536), dimension(:), allocatable :: str + + write(6,'(/,a)') ' <<<+- crystallite init -+>>>' + + cMax = homogenization_maxNgrains + iMax = theMesh%elem%nIPs + eMax = theMesh%nElems + + allocate(crystallite_S0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_partionedS0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_S(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_subS0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_P(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_F0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_partionedF0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_partionedF(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_subF0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_subF(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_Fp0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_partionedFp0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_subFp0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_Fp(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_invFp(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_Fi0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_partionedFi0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_subFi0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_Fi(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_invFi(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_Fe(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_Lp0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_partionedLp0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_subLp0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_Lp(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_Li0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_partionedLi0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_subLi0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_Li(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_dPdF(3,3,3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_dt(cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_subdt(cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_subFrac(cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_subStep(cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_orientation(cMax,iMax,eMax)) + allocate(crystallite_orientation0(cMax,iMax,eMax)) + allocate(crystallite_localPlasticity(cMax,iMax,eMax), source=.true.) + allocate(crystallite_requested(cMax,iMax,eMax), source=.false.) + allocate(crystallite_todo(cMax,iMax,eMax), source=.false.) + allocate(crystallite_converged(cMax,iMax,eMax), source=.true.) + allocate(crystallite_output(maxval(crystallite_Noutput), & + size(config_crystallite))) ; crystallite_output = '' + allocate(crystallite_outputID(maxval(crystallite_Noutput), & + size(config_crystallite)), source=undefined_ID) + allocate(crystallite_sizePostResults(size(config_crystallite)),source=0) + allocate(crystallite_sizePostResult(maxval(crystallite_Noutput), & + size(config_crystallite)), source=0) + + select case(numerics_integrator) + case(1) + integrateState => integrateStateFPI + case(2) + integrateState => integrateStateEuler + case(3) + integrateState => integrateStateAdaptiveEuler + case(4) + integrateState => integrateStateRK4 + case(5) + integrateState => integrateStateRKCK45 + end select + + + + do c = 1, size(config_crystallite) #if defined(__GFORTRAN__) - str = ['GfortranBug86277'] - str = config_crystallite(c)%getStrings('(output)',defaultVal=str) - if (str(1) == 'GfortranBug86277') str = [character(len=65536)::] + str = ['GfortranBug86277'] + str = config_crystallite(c)%getStrings('(output)',defaultVal=str) + if (str(1) == 'GfortranBug86277') str = [character(len=65536)::] #else - str = config_crystallite(c)%getStrings('(output)',defaultVal=[character(len=65536)::]) + str = config_crystallite(c)%getStrings('(output)',defaultVal=[character(len=65536)::]) #endif - do o = 1, size(str) - crystallite_output(o,c) = str(o) - outputName: select case(str(o)) - case ('phase') outputName - crystallite_outputID(o,c) = phase_ID - case ('texture') outputName - crystallite_outputID(o,c) = texture_ID - case ('volume') outputName - crystallite_outputID(o,c) = volume_ID - case ('orientation') outputName - crystallite_outputID(o,c) = orientation_ID - case ('grainrotation') outputName - crystallite_outputID(o,c) = grainrotation_ID - case ('defgrad','f') outputName ! ToDo: no alias (f only) - crystallite_outputID(o,c) = defgrad_ID - case ('fe') outputName - crystallite_outputID(o,c) = fe_ID - case ('fp') outputName - crystallite_outputID(o,c) = fp_ID - case ('fi') outputName - crystallite_outputID(o,c) = fi_ID - case ('lp') outputName - crystallite_outputID(o,c) = lp_ID - case ('li') outputName - crystallite_outputID(o,c) = li_ID - case ('p','firstpiola','1stpiola') outputName ! ToDo: no alias (p only) - crystallite_outputID(o,c) = p_ID - case ('s','tstar','secondpiola','2ndpiola') outputName ! ToDo: no alias (s only) - crystallite_outputID(o,c) = s_ID - case ('elasmatrix') outputName - crystallite_outputID(o,c) = elasmatrix_ID - case ('neighboringip') outputName ! ToDo: this is not a result, it is static. Should be written out by mesh - crystallite_outputID(o,c) = neighboringip_ID - case ('neighboringelement') outputName ! ToDo: this is not a result, it is static. Should be written out by mesh - crystallite_outputID(o,c) = neighboringelement_ID - case default outputName - call IO_error(105,ext_msg=trim(str(o))//' (Crystallite)') - end select outputName - enddo - enddo + do o = 1, size(str) + crystallite_output(o,c) = str(o) + outputName: select case(str(o)) + case ('phase') outputName + crystallite_outputID(o,c) = phase_ID + case ('texture') outputName + crystallite_outputID(o,c) = texture_ID + case ('volume') outputName + crystallite_outputID(o,c) = volume_ID + case ('orientation') outputName + crystallite_outputID(o,c) = orientation_ID + case ('grainrotation') outputName + crystallite_outputID(o,c) = grainrotation_ID + case ('defgrad','f') outputName ! ToDo: no alias (f only) + crystallite_outputID(o,c) = defgrad_ID + case ('fe') outputName + crystallite_outputID(o,c) = fe_ID + case ('fp') outputName + crystallite_outputID(o,c) = fp_ID + case ('fi') outputName + crystallite_outputID(o,c) = fi_ID + case ('lp') outputName + crystallite_outputID(o,c) = lp_ID + case ('li') outputName + crystallite_outputID(o,c) = li_ID + case ('p','firstpiola','1stpiola') outputName ! ToDo: no alias (p only) + crystallite_outputID(o,c) = p_ID + case ('s','tstar','secondpiola','2ndpiola') outputName ! ToDo: no alias (s only) + crystallite_outputID(o,c) = s_ID + case ('elasmatrix') outputName + crystallite_outputID(o,c) = elasmatrix_ID + case ('neighboringip') outputName ! ToDo: this is not a result, it is static. Should be written out by mesh + crystallite_outputID(o,c) = neighboringip_ID + case ('neighboringelement') outputName ! ToDo: this is not a result, it is static. Should be written out by mesh + crystallite_outputID(o,c) = neighboringelement_ID + case default outputName + call IO_error(105,ext_msg=trim(str(o))//' (Crystallite)') + end select outputName + enddo + enddo - do r = 1,size(config_crystallite) - do o = 1,crystallite_Noutput(r) - select case(crystallite_outputID(o,r)) - case(phase_ID,texture_ID,volume_ID) - mySize = 1 - case(orientation_ID,grainrotation_ID) - mySize = 4 - case(defgrad_ID,fe_ID,fp_ID,fi_ID,lp_ID,li_ID,p_ID,s_ID) - mySize = 9 - case(elasmatrix_ID) - mySize = 36 - case(neighboringip_ID,neighboringelement_ID) - mySize = theMesh%elem%nIPneighbors - case default - mySize = 0 - end select - crystallite_sizePostResult(o,r) = mySize - crystallite_sizePostResults(r) = crystallite_sizePostResults(r) + mySize - enddo - enddo - - crystallite_maxSizePostResults = & - maxval(crystallite_sizePostResults(microstructure_crystallite),microstructure_active) + do r = 1,size(config_crystallite) + do o = 1,crystallite_Noutput(r) + select case(crystallite_outputID(o,r)) + case(phase_ID,texture_ID,volume_ID) + mySize = 1 + case(orientation_ID,grainrotation_ID) + mySize = 4 + case(defgrad_ID,fe_ID,fp_ID,fi_ID,lp_ID,li_ID,p_ID,s_ID) + mySize = 9 + case(elasmatrix_ID) + mySize = 36 + case(neighboringip_ID,neighboringelement_ID) + mySize = theMesh%elem%nIPneighbors + case default + mySize = 0 + end select + crystallite_sizePostResult(o,r) = mySize + crystallite_sizePostResults(r) = crystallite_sizePostResults(r) + mySize + enddo + enddo + + crystallite_maxSizePostResults = & + maxval(crystallite_sizePostResults(microstructure_crystallite),microstructure_active) !-------------------------------------------------------------------------------------------------- ! write description file for crystallite output - if (worldrank == 0) then - call IO_write_jobFile(FILEUNIT,'outputCrystallite') - - do r = 1,size(config_crystallite) - if (any(microstructure_crystallite(mesh_element(4,:)) == r)) then - write(FILEUNIT,'(/,a,/)') '['//trim(crystallite_name(r))//']' - do o = 1,crystallite_Noutput(r) - write(FILEUNIT,'(a,i4)') trim(crystallite_output(o,r))//char(9),crystallite_sizePostResult(o,r) - enddo - endif - enddo - - close(FILEUNIT) - endif - - call config_deallocate('material.config/crystallite') + if (worldrank == 0) then + call IO_write_jobFile(FILEUNIT,'outputCrystallite') + + do r = 1,size(config_crystallite) + if (any(microstructure_crystallite(mesh_element(4,:)) == r)) then + write(FILEUNIT,'(/,a,/)') '['//trim(crystallite_name(r))//']' + do o = 1,crystallite_Noutput(r) + write(FILEUNIT,'(a,i4)') trim(crystallite_output(o,r))//char(9),crystallite_sizePostResult(o,r) + enddo + endif + enddo + + close(FILEUNIT) + endif + + call config_deallocate('material.config/crystallite') !-------------------------------------------------------------------------------------------------- ! initialize !$OMP PARALLEL DO PRIVATE(myNcomponents,i,c) - do e = FEsolving_execElem(1),FEsolving_execElem(2) - myNcomponents = homogenization_Ngrains(mesh_element(3,e)) - forall (i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), c = 1:myNcomponents) - crystallite_Fp0(1:3,1:3,c,i,e) = math_EulerToR(material_EulerAngles(1:3,c,i,e)) ! plastic def gradient reflects init orientation - crystallite_Fi0(1:3,1:3,c,i,e) = constitutive_initialFi(c,i,e) - crystallite_F0(1:3,1:3,c,i,e) = math_I3 - crystallite_localPlasticity(c,i,e) = phase_localPlasticity(material_phase(c,i,e)) - crystallite_Fe(1:3,1:3,c,i,e) = math_inv33(matmul(crystallite_Fi0(1:3,1:3,c,i,e), & - crystallite_Fp0(1:3,1:3,c,i,e))) ! assuming that euler angles are given in internal strain free configuration - crystallite_Fp(1:3,1:3,c,i,e) = crystallite_Fp0(1:3,1:3,c,i,e) - crystallite_Fi(1:3,1:3,c,i,e) = crystallite_Fi0(1:3,1:3,c,i,e) - crystallite_requested(c,i,e) = .true. - endforall - enddo - !$OMP END PARALLEL DO - - if(any(.not. crystallite_localPlasticity) .and. .not. usePingPong) call IO_error(601) ! exit if nonlocal but no ping-pong ToDo: Why not check earlier? or in nonlocal? - - crystallite_partionedFp0 = crystallite_Fp0 - crystallite_partionedFi0 = crystallite_Fi0 - crystallite_partionedF0 = crystallite_F0 - crystallite_partionedF = crystallite_F0 - - call crystallite_orientations() - crystallite_orientation0 = crystallite_orientation ! store initial orientations for calculation of grain rotations - - !$OMP PARALLEL DO - do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do c = 1,homogenization_Ngrains(mesh_element(3,e)) - call constitutive_microstructure(crystallite_Fe(1:3,1:3,c,i,e), & - crystallite_Fp(1:3,1:3,c,i,e), & - c,i,e) ! update dependent state variables to be consistent with basic states + do e = FEsolving_execElem(1),FEsolving_execElem(2) + myNcomponents = homogenization_Ngrains(mesh_element(3,e)) + forall (i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), c = 1:myNcomponents) + crystallite_Fp0(1:3,1:3,c,i,e) = math_EulerToR(material_EulerAngles(1:3,c,i,e)) ! plastic def gradient reflects init orientation + crystallite_Fi0(1:3,1:3,c,i,e) = constitutive_initialFi(c,i,e) + crystallite_F0(1:3,1:3,c,i,e) = math_I3 + crystallite_localPlasticity(c,i,e) = phase_localPlasticity(material_phase(c,i,e)) + crystallite_Fe(1:3,1:3,c,i,e) = math_inv33(matmul(crystallite_Fi0(1:3,1:3,c,i,e), & + crystallite_Fp0(1:3,1:3,c,i,e))) ! assuming that euler angles are given in internal strain free configuration + crystallite_Fp(1:3,1:3,c,i,e) = crystallite_Fp0(1:3,1:3,c,i,e) + crystallite_Fi(1:3,1:3,c,i,e) = crystallite_Fi0(1:3,1:3,c,i,e) + crystallite_requested(c,i,e) = .true. + endforall + enddo + !$OMP END PARALLEL DO + + if(any(.not. crystallite_localPlasticity) .and. .not. usePingPong) call IO_error(601) ! exit if nonlocal but no ping-pong ToDo: Why not check earlier? or in nonlocal? + + crystallite_partionedFp0 = crystallite_Fp0 + crystallite_partionedFi0 = crystallite_Fi0 + crystallite_partionedF0 = crystallite_F0 + crystallite_partionedF = crystallite_F0 + + call crystallite_orientations() + crystallite_orientation0 = crystallite_orientation ! store initial orientations for calculation of grain rotations + + !$OMP PARALLEL DO + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do c = 1,homogenization_Ngrains(mesh_element(3,e)) + call constitutive_microstructure(crystallite_Fe(1:3,1:3,c,i,e), & + crystallite_Fp(1:3,1:3,c,i,e), & + c,i,e) ! update dependent state variables to be consistent with basic states + enddo enddo - enddo - enddo - !$OMP END PARALLEL DO - - devNull = crystallite_stress() - call crystallite_stressTangent + enddo + !$OMP END PARALLEL DO + + devNull = crystallite_stress() + call crystallite_stressTangent #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) then - write(6,'(a42,1x,i10)') ' # of elements: ', eMax - write(6,'(a42,1x,i10)') 'max # of integration points/element: ', iMax - write(6,'(a42,1x,i10)') 'max # of constituents/integration point: ', cMax - write(6,'(a42,1x,i10)') 'max # of neigbours/integration point: ', theMesh%elem%nIPneighbors - write(6,'(a42,1x,i10)') ' # of nonlocal constituents: ',count(.not. crystallite_localPlasticity) - flush(6) - endif - - call debug_info - call debug_reset + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) then + write(6,'(a42,1x,i10)') ' # of elements: ', eMax + write(6,'(a42,1x,i10)') 'max # of integration points/element: ', iMax + write(6,'(a42,1x,i10)') 'max # of constituents/integration point: ', cMax + write(6,'(a42,1x,i10)') 'max # of neigbours/integration point: ', theMesh%elem%nIPneighbors + write(6,'(a42,1x,i10)') ' # of nonlocal constituents: ',count(.not. crystallite_localPlasticity) + flush(6) + endif + + call debug_info + call debug_reset #endif end subroutine crystallite_init @@ -406,270 +406,270 @@ end subroutine crystallite_init !> @brief calculate stress (P) !-------------------------------------------------------------------------------------------------- function crystallite_stress(dummyArgumentToPreventInternalCompilerErrorWithGCC) - use prec, only: & - tol_math_check, & - dNeq0 - use numerics, only: & - subStepMinCryst, & - subStepSizeCryst, & - stepIncreaseCryst + use prec, only: & + tol_math_check, & + dNeq0 + use numerics, only: & + subStepMinCryst, & + subStepSizeCryst, & + stepIncreaseCryst #ifdef DEBUG - use debug, only: & - debug_level, & - debug_crystallite, & - debug_levelBasic, & - debug_levelExtensive, & - debug_levelSelective, & - debug_e, & - debug_i, & - debug_g + use debug, only: & + debug_level, & + debug_crystallite, & + debug_levelBasic, & + debug_levelExtensive, & + debug_levelSelective, & + debug_e, & + debug_i, & + debug_g #endif - use IO, only: & - IO_warning, & - IO_error - use math, only: & - math_inv33 - use mesh, only: & - theMesh, & - mesh_element - use material, only: & - homogenization_Ngrains, & - plasticState, & - sourceState, & - phase_Nsources, & - phaseAt, phasememberAt - - implicit none - logical, dimension(theMesh%elem%nIPs,theMesh%Nelems) :: crystallite_stress - real(pReal), intent(in), optional :: & - dummyArgumentToPreventInternalCompilerErrorWithGCC - real(pReal) :: & - formerSubStep - integer :: & - NiterationCrystallite, & ! number of iterations in crystallite loop - c, & !< counter in integration point component loop - i, & !< counter in integration point loop - e, & !< counter in element loop - startIP, endIP, & - s - + use IO, only: & + IO_warning, & + IO_error + use math, only: & + math_inv33 + use mesh, only: & + theMesh, & + mesh_element + use material, only: & + homogenization_Ngrains, & + plasticState, & + sourceState, & + phase_Nsources, & + phaseAt, phasememberAt + + implicit none + logical, dimension(theMesh%elem%nIPs,theMesh%Nelems) :: crystallite_stress + real(pReal), intent(in), optional :: & + dummyArgumentToPreventInternalCompilerErrorWithGCC + real(pReal) :: & + formerSubStep + integer :: & + NiterationCrystallite, & ! number of iterations in crystallite loop + c, & !< counter in integration point component loop + i, & !< counter in integration point loop + e, & !< counter in element loop + startIP, endIP, & + s + #ifdef DEBUG - if (iand(debug_level(debug_crystallite),debug_levelSelective) /= 0 & - .and. FEsolving_execElem(1) <= debug_e & - .and. debug_e <= FEsolving_execElem(2)) then - write(6,'(/,a,i8,1x,i2,1x,i3)') '<< CRYST stress >> boundary and initial values at el ip ipc ', & - debug_e,debug_i, debug_g - write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST stress >> F ', & - transpose(crystallite_partionedF(1:3,1:3,debug_g,debug_i,debug_e)) - write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST stress >> F0 ', & - transpose(crystallite_partionedF0(1:3,1:3,debug_g,debug_i,debug_e)) - write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST stress >> Fp0', & - transpose(crystallite_partionedFp0(1:3,1:3,debug_g,debug_i,debug_e)) - write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST stress >> Fi0', & - transpose(crystallite_partionedFi0(1:3,1:3,debug_g,debug_i,debug_e)) - write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST stress >> Lp0', & - transpose(crystallite_partionedLp0(1:3,1:3,debug_g,debug_i,debug_e)) - write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST stress >> Li0', & - transpose(crystallite_partionedLi0(1:3,1:3,debug_g,debug_i,debug_e)) - endif + if (iand(debug_level(debug_crystallite),debug_levelSelective) /= 0 & + .and. FEsolving_execElem(1) <= debug_e & + .and. debug_e <= FEsolving_execElem(2)) then + write(6,'(/,a,i8,1x,i2,1x,i3)') '<< CRYST stress >> boundary and initial values at el ip ipc ', & + debug_e,debug_i, debug_g + write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST stress >> F ', & + transpose(crystallite_partionedF(1:3,1:3,debug_g,debug_i,debug_e)) + write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST stress >> F0 ', & + transpose(crystallite_partionedF0(1:3,1:3,debug_g,debug_i,debug_e)) + write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST stress >> Fp0', & + transpose(crystallite_partionedFp0(1:3,1:3,debug_g,debug_i,debug_e)) + write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST stress >> Fi0', & + transpose(crystallite_partionedFi0(1:3,1:3,debug_g,debug_i,debug_e)) + write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST stress >> Lp0', & + transpose(crystallite_partionedLp0(1:3,1:3,debug_g,debug_i,debug_e)) + write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST stress >> Li0', & + transpose(crystallite_partionedLi0(1:3,1:3,debug_g,debug_i,debug_e)) + endif #endif !-------------------------------------------------------------------------------------------------- ! initialize to starting condition - crystallite_subStep = 0.0_pReal - !$OMP PARALLEL DO - elementLooping1: do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e); do c = 1,homogenization_Ngrains(mesh_element(3,e)) - homogenizationRequestsCalculation: if (crystallite_requested(c,i,e)) then - plasticState (phaseAt(c,i,e))%subState0( :,phasememberAt(c,i,e)) = & - plasticState (phaseAt(c,i,e))%partionedState0(:,phasememberAt(c,i,e)) + crystallite_subStep = 0.0_pReal + !$OMP PARALLEL DO + elementLooping1: do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e); do c = 1,homogenization_Ngrains(mesh_element(3,e)) + homogenizationRequestsCalculation: if (crystallite_requested(c,i,e)) then + plasticState (phaseAt(c,i,e))%subState0( :,phasememberAt(c,i,e)) = & + plasticState (phaseAt(c,i,e))%partionedState0(:,phasememberAt(c,i,e)) - do s = 1, phase_Nsources(phaseAt(c,i,e)) - sourceState(phaseAt(c,i,e))%p(s)%subState0( :,phasememberAt(c,i,e)) = & - sourceState(phaseAt(c,i,e))%p(s)%partionedState0(:,phasememberAt(c,i,e)) - enddo - crystallite_subFp0(1:3,1:3,c,i,e) = crystallite_partionedFp0(1:3,1:3,c,i,e) - crystallite_subLp0(1:3,1:3,c,i,e) = crystallite_partionedLp0(1:3,1:3,c,i,e) - crystallite_subFi0(1:3,1:3,c,i,e) = crystallite_partionedFi0(1:3,1:3,c,i,e) - crystallite_subLi0(1:3,1:3,c,i,e) = crystallite_partionedLi0(1:3,1:3,c,i,e) - crystallite_subF0(1:3,1:3,c,i,e) = crystallite_partionedF0(1:3,1:3,c,i,e) - crystallite_subS0(1:3,1:3,c,i,e) = crystallite_partionedS0(1:3,1:3,c,i,e) - crystallite_subFrac(c,i,e) = 0.0_pReal - crystallite_subStep(c,i,e) = 1.0_pReal/subStepSizeCryst - crystallite_todo(c,i,e) = .true. - crystallite_converged(c,i,e) = .false. ! pretend failed step of 1/subStepSizeCryst - endif homogenizationRequestsCalculation - enddo; enddo - enddo elementLooping1 - !$OMP END PARALLEL DO + do s = 1, phase_Nsources(phaseAt(c,i,e)) + sourceState(phaseAt(c,i,e))%p(s)%subState0( :,phasememberAt(c,i,e)) = & + sourceState(phaseAt(c,i,e))%p(s)%partionedState0(:,phasememberAt(c,i,e)) + enddo + crystallite_subFp0(1:3,1:3,c,i,e) = crystallite_partionedFp0(1:3,1:3,c,i,e) + crystallite_subLp0(1:3,1:3,c,i,e) = crystallite_partionedLp0(1:3,1:3,c,i,e) + crystallite_subFi0(1:3,1:3,c,i,e) = crystallite_partionedFi0(1:3,1:3,c,i,e) + crystallite_subLi0(1:3,1:3,c,i,e) = crystallite_partionedLi0(1:3,1:3,c,i,e) + crystallite_subF0(1:3,1:3,c,i,e) = crystallite_partionedF0(1:3,1:3,c,i,e) + crystallite_subS0(1:3,1:3,c,i,e) = crystallite_partionedS0(1:3,1:3,c,i,e) + crystallite_subFrac(c,i,e) = 0.0_pReal + crystallite_subStep(c,i,e) = 1.0_pReal/subStepSizeCryst + crystallite_todo(c,i,e) = .true. + crystallite_converged(c,i,e) = .false. ! pretend failed step of 1/subStepSizeCryst + endif homogenizationRequestsCalculation + enddo; enddo + enddo elementLooping1 + !$OMP END PARALLEL DO - singleRun: if (FEsolving_execELem(1) == FEsolving_execElem(2) .and. & - FEsolving_execIP(1,FEsolving_execELem(1))==FEsolving_execIP(2,FEsolving_execELem(1))) then - startIP = FEsolving_execIP(1,FEsolving_execELem(1)) - endIP = startIP - else singleRun - startIP = 1 - endIP = theMesh%elem%nIPs - endif singleRun + singleRun: if (FEsolving_execELem(1) == FEsolving_execElem(2) .and. & + FEsolving_execIP(1,FEsolving_execELem(1))==FEsolving_execIP(2,FEsolving_execELem(1))) then + startIP = FEsolving_execIP(1,FEsolving_execELem(1)) + endIP = startIP + else singleRun + startIP = 1 + endIP = theMesh%elem%nIPs + endif singleRun - NiterationCrystallite = 0 - cutbackLooping: do while (any(crystallite_todo(:,startIP:endIP,FEsolving_execELem(1):FEsolving_execElem(2)))) - NiterationCrystallite = NiterationCrystallite + 1 + NiterationCrystallite = 0 + cutbackLooping: do while (any(crystallite_todo(:,startIP:endIP,FEsolving_execELem(1):FEsolving_execElem(2)))) + NiterationCrystallite = NiterationCrystallite + 1 #ifdef DEBUG - if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0) & - write(6,'(a,i6)') '<< CRYST stress >> crystallite iteration ',NiterationCrystallite + if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0) & + write(6,'(a,i6)') '<< CRYST stress >> crystallite iteration ',NiterationCrystallite #endif - !$OMP PARALLEL DO PRIVATE(formerSubStep) - elementLooping3: do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do c = 1,homogenization_Ngrains(mesh_element(3,e)) + !$OMP PARALLEL DO PRIVATE(formerSubStep) + elementLooping3: do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do c = 1,homogenization_Ngrains(mesh_element(3,e)) !-------------------------------------------------------------------------------------------------- ! wind forward - if (crystallite_converged(c,i,e)) then - formerSubStep = crystallite_subStep(c,i,e) - crystallite_subFrac(c,i,e) = crystallite_subFrac(c,i,e) + crystallite_subStep(c,i,e) - crystallite_subStep(c,i,e) = min(1.0_pReal - crystallite_subFrac(c,i,e), & - stepIncreaseCryst * crystallite_subStep(c,i,e)) + if (crystallite_converged(c,i,e)) then + formerSubStep = crystallite_subStep(c,i,e) + crystallite_subFrac(c,i,e) = crystallite_subFrac(c,i,e) + crystallite_subStep(c,i,e) + crystallite_subStep(c,i,e) = min(1.0_pReal - crystallite_subFrac(c,i,e), & + stepIncreaseCryst * crystallite_subStep(c,i,e)) - crystallite_todo(c,i,e) = crystallite_subStep(c,i,e) > 0.0_pReal ! still time left to integrate on? - if (crystallite_todo(c,i,e)) then - crystallite_subF0 (1:3,1:3,c,i,e) = crystallite_subF(1:3,1:3,c,i,e) - crystallite_subLp0(1:3,1:3,c,i,e) = crystallite_Lp (1:3,1:3,c,i,e) - crystallite_subLi0(1:3,1:3,c,i,e) = crystallite_Li (1:3,1:3,c,i,e) - crystallite_subFp0(1:3,1:3,c,i,e) = crystallite_Fp (1:3,1:3,c,i,e) - crystallite_subFi0(1:3,1:3,c,i,e) = crystallite_Fi (1:3,1:3,c,i,e) - crystallite_subS0 (1:3,1:3,c,i,e) = crystallite_S (1:3,1:3,c,i,e) - !if abbrevation, make c and p private in omp - plasticState( phaseAt(c,i,e))%subState0(:,phasememberAt(c,i,e)) & - = plasticState(phaseAt(c,i,e))%state( :,phasememberAt(c,i,e)) - do s = 1, phase_Nsources(phaseAt(c,i,e)) - sourceState( phaseAt(c,i,e))%p(s)%subState0(:,phasememberAt(c,i,e)) & - = sourceState(phaseAt(c,i,e))%p(s)%state( :,phasememberAt(c,i,e)) - enddo + crystallite_todo(c,i,e) = crystallite_subStep(c,i,e) > 0.0_pReal ! still time left to integrate on? + if (crystallite_todo(c,i,e)) then + crystallite_subF0 (1:3,1:3,c,i,e) = crystallite_subF(1:3,1:3,c,i,e) + crystallite_subLp0(1:3,1:3,c,i,e) = crystallite_Lp (1:3,1:3,c,i,e) + crystallite_subLi0(1:3,1:3,c,i,e) = crystallite_Li (1:3,1:3,c,i,e) + crystallite_subFp0(1:3,1:3,c,i,e) = crystallite_Fp (1:3,1:3,c,i,e) + crystallite_subFi0(1:3,1:3,c,i,e) = crystallite_Fi (1:3,1:3,c,i,e) + crystallite_subS0 (1:3,1:3,c,i,e) = crystallite_S (1:3,1:3,c,i,e) + !if abbrevation, make c and p private in omp + plasticState( phaseAt(c,i,e))%subState0(:,phasememberAt(c,i,e)) & + = plasticState(phaseAt(c,i,e))%state( :,phasememberAt(c,i,e)) + do s = 1, phase_Nsources(phaseAt(c,i,e)) + sourceState( phaseAt(c,i,e))%p(s)%subState0(:,phasememberAt(c,i,e)) & + = sourceState(phaseAt(c,i,e))%p(s)%state( :,phasememberAt(c,i,e)) + enddo #ifdef DEBUG - if (iand(debug_level(debug_crystallite),debug_levelBasic) /= 0 & - .and. ((e == debug_e .and. i == debug_i .and. c == debug_g) & - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) & - write(6,'(a,f12.8,a,f12.8,a,i8,1x,i2,1x,i3,/)') '<< CRYST stress >> winding forward from ', & - crystallite_subFrac(c,i,e)-formerSubStep,' to current crystallite_subfrac ', & - crystallite_subFrac(c,i,e),' in crystallite_stress at el ip ipc ',e,i,c + if (iand(debug_level(debug_crystallite),debug_levelBasic) /= 0 & + .and. ((e == debug_e .and. i == debug_i .and. c == debug_g) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) & + write(6,'(a,f12.8,a,f12.8,a,i8,1x,i2,1x,i3,/)') '<< CRYST stress >> winding forward from ', & + crystallite_subFrac(c,i,e)-formerSubStep,' to current crystallite_subfrac ', & + crystallite_subFrac(c,i,e),' in crystallite_stress at el ip ipc ',e,i,c #endif - endif + endif !-------------------------------------------------------------------------------------------------- ! cut back (reduced time and restore) - else - crystallite_subStep(c,i,e) = subStepSizeCryst * crystallite_subStep(c,i,e) - crystallite_Fp (1:3,1:3,c,i,e) = crystallite_subFp0(1:3,1:3,c,i,e) - crystallite_invFp(1:3,1:3,c,i,e) = math_inv33(crystallite_Fp (1:3,1:3,c,i,e)) - crystallite_Fi (1:3,1:3,c,i,e) = crystallite_subFi0(1:3,1:3,c,i,e) - crystallite_invFi(1:3,1:3,c,i,e) = math_inv33(crystallite_Fi (1:3,1:3,c,i,e)) - crystallite_S (1:3,1:3,c,i,e) = crystallite_S0 (1:3,1:3,c,i,e) - if (crystallite_subStep(c,i,e) < 1.0_pReal) then ! actual (not initial) cutback - crystallite_Lp (1:3,1:3,c,i,e) = crystallite_subLp0(1:3,1:3,c,i,e) - crystallite_Li (1:3,1:3,c,i,e) = crystallite_subLi0(1:3,1:3,c,i,e) - endif - plasticState (phaseAt(c,i,e))%state( :,phasememberAt(c,i,e)) & - = plasticState(phaseAt(c,i,e))%subState0(:,phasememberAt(c,i,e)) - do s = 1, phase_Nsources(phaseAt(c,i,e)) - sourceState( phaseAt(c,i,e))%p(s)%state( :,phasememberAt(c,i,e)) & - = sourceState(phaseAt(c,i,e))%p(s)%subState0(:,phasememberAt(c,i,e)) - enddo + else + crystallite_subStep(c,i,e) = subStepSizeCryst * crystallite_subStep(c,i,e) + crystallite_Fp (1:3,1:3,c,i,e) = crystallite_subFp0(1:3,1:3,c,i,e) + crystallite_invFp(1:3,1:3,c,i,e) = math_inv33(crystallite_Fp (1:3,1:3,c,i,e)) + crystallite_Fi (1:3,1:3,c,i,e) = crystallite_subFi0(1:3,1:3,c,i,e) + crystallite_invFi(1:3,1:3,c,i,e) = math_inv33(crystallite_Fi (1:3,1:3,c,i,e)) + crystallite_S (1:3,1:3,c,i,e) = crystallite_S0 (1:3,1:3,c,i,e) + if (crystallite_subStep(c,i,e) < 1.0_pReal) then ! actual (not initial) cutback + crystallite_Lp (1:3,1:3,c,i,e) = crystallite_subLp0(1:3,1:3,c,i,e) + crystallite_Li (1:3,1:3,c,i,e) = crystallite_subLi0(1:3,1:3,c,i,e) + endif + plasticState (phaseAt(c,i,e))%state( :,phasememberAt(c,i,e)) & + = plasticState(phaseAt(c,i,e))%subState0(:,phasememberAt(c,i,e)) + do s = 1, phase_Nsources(phaseAt(c,i,e)) + sourceState( phaseAt(c,i,e))%p(s)%state( :,phasememberAt(c,i,e)) & + = sourceState(phaseAt(c,i,e))%p(s)%subState0(:,phasememberAt(c,i,e)) + enddo - ! cant restore dotState here, since not yet calculated in first cutback after initialization - crystallite_todo(c,i,e) = crystallite_subStep(c,i,e) > subStepMinCryst ! still on track or already done (beyond repair) + ! cant restore dotState here, since not yet calculated in first cutback after initialization + crystallite_todo(c,i,e) = crystallite_subStep(c,i,e) > subStepMinCryst ! still on track or already done (beyond repair) #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & - .and. ((e == debug_e .and. i == debug_i .and. c == debug_g) & - .or. .not. iand(debug_level(debug_crystallite),debug_levelSelective) /= 0)) then - if (crystallite_todo(c,i,e)) then - write(6,'(a,f12.8,a,i8,1x,i2,1x,i3,/)') '<< CRYST stress >> cutback with new crystallite_subStep: ', & - crystallite_subStep(c,i,e),' at el ip ipc ',e,i,c - else - write(6,'(a,i8,1x,i2,1x,i3,/)') '<< CRYST stress >> reached minimum step size at el ip ipc ',e,i,c - endif - endif + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & + .and. ((e == debug_e .and. i == debug_i .and. c == debug_g) & + .or. .not. iand(debug_level(debug_crystallite),debug_levelSelective) /= 0)) then + if (crystallite_todo(c,i,e)) then + write(6,'(a,f12.8,a,i8,1x,i2,1x,i3,/)') '<< CRYST stress >> cutback with new crystallite_subStep: ', & + crystallite_subStep(c,i,e),' at el ip ipc ',e,i,c + else + write(6,'(a,i8,1x,i2,1x,i3,/)') '<< CRYST stress >> reached minimum step size at el ip ipc ',e,i,c + endif + endif #endif - endif + endif !-------------------------------------------------------------------------------------------------- ! prepare for integration - if (crystallite_todo(c,i,e)) then - crystallite_subF(1:3,1:3,c,i,e) = crystallite_subF0(1:3,1:3,c,i,e) & - + crystallite_subStep(c,i,e) * (crystallite_partionedF (1:3,1:3,c,i,e) & - - crystallite_partionedF0(1:3,1:3,c,i,e)) - crystallite_Fe(1:3,1:3,c,i,e) = matmul(matmul(crystallite_subF (1:3,1:3,c,i,e), & - crystallite_invFp(1:3,1:3,c,i,e)), & - crystallite_invFi(1:3,1:3,c,i,e)) - crystallite_subdt(c,i,e) = crystallite_subStep(c,i,e) * crystallite_dt(c,i,e) - crystallite_converged(c,i,e) = .false. - endif + if (crystallite_todo(c,i,e)) then + crystallite_subF(1:3,1:3,c,i,e) = crystallite_subF0(1:3,1:3,c,i,e) & + + crystallite_subStep(c,i,e) * (crystallite_partionedF (1:3,1:3,c,i,e) & + - crystallite_partionedF0(1:3,1:3,c,i,e)) + crystallite_Fe(1:3,1:3,c,i,e) = matmul(matmul(crystallite_subF (1:3,1:3,c,i,e), & + crystallite_invFp(1:3,1:3,c,i,e)), & + crystallite_invFi(1:3,1:3,c,i,e)) + crystallite_subdt(c,i,e) = crystallite_subStep(c,i,e) * crystallite_dt(c,i,e) + crystallite_converged(c,i,e) = .false. + endif - enddo - enddo - enddo elementLooping3 - !$OMP END PARALLEL DO + enddo + enddo + enddo elementLooping3 + !$OMP END PARALLEL DO #ifdef DEBUG - if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0) then - write(6,'(/,a,f8.5,a,f8.5,/)') '<< CRYST stress >> ',minval(crystallite_subStep), & - ' ≤ subStep ≤ ',maxval(crystallite_subStep) - write(6,'(/,a,f8.5,a,f8.5,/)') '<< CRYST stress >> ',minval(crystallite_subFrac), & - ' ≤ subFrac ≤ ',maxval(crystallite_subFrac) - flush(6) - if (iand(debug_level(debug_crystallite),debug_levelSelective) /= 0) then - write(6,'(/,a,f8.5,1x,a,1x,f8.5,1x,a)') '<< CRYST stress >> subFrac + subStep = ',& - crystallite_subFrac(debug_g,debug_i,debug_e),'+',crystallite_subStep(debug_g,debug_i,debug_e),'@selective' - flush(6) - endif - endif + if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0) then + write(6,'(/,a,f8.5,a,f8.5,/)') '<< CRYST stress >> ',minval(crystallite_subStep), & + ' ≤ subStep ≤ ',maxval(crystallite_subStep) + write(6,'(/,a,f8.5,a,f8.5,/)') '<< CRYST stress >> ',minval(crystallite_subFrac), & + ' ≤ subFrac ≤ ',maxval(crystallite_subFrac) + flush(6) + if (iand(debug_level(debug_crystallite),debug_levelSelective) /= 0) then + write(6,'(/,a,f8.5,1x,a,1x,f8.5,1x,a)') '<< CRYST stress >> subFrac + subStep = ',& + crystallite_subFrac(debug_g,debug_i,debug_e),'+',crystallite_subStep(debug_g,debug_i,debug_e),'@selective' + flush(6) + endif + endif #endif !-------------------------------------------------------------------------------------------------- ! integrate --- requires fully defined state array (basic + dependent state) - if (any(crystallite_todo)) call integrateState() ! TODO: unroll into proper elementloop to avoid N^2 for single point evaluation - where(.not. crystallite_converged .and. crystallite_subStep > subStepMinCryst) & ! do not try non-converged but fully cutbacked any further - crystallite_todo = .true. ! TODO: again unroll this into proper elementloop to avoid N^2 for single point evaluation + if (any(crystallite_todo)) call integrateState ! TODO: unroll into proper elementloop to avoid N^2 for single point evaluation + where(.not. crystallite_converged .and. crystallite_subStep > subStepMinCryst) & ! do not try non-converged but fully cutbacked any further + crystallite_todo = .true. ! TODO: again unroll this into proper elementloop to avoid N^2 for single point evaluation - enddo cutbackLooping + enddo cutbackLooping ! return whether converged or not - crystallite_stress = .false. - elementLooping5: do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - crystallite_stress(i,e) = all(crystallite_converged(:,i,e)) - enddo - enddo elementLooping5 + crystallite_stress = .false. + elementLooping5: do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + crystallite_stress(i,e) = all(crystallite_converged(:,i,e)) + enddo + enddo elementLooping5 #ifdef DEBUG - elementLooping6: do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do c = 1,homogenization_Ngrains(mesh_element(3,e)) - if (.not. crystallite_converged(c,i,e)) then - if(iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) & - write(6,'(a,i8,1x,i2,1x,i3,/)') '<< CRYST stress >> no convergence at el ip ipc ', & - e,i,c - endif - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & - .and. ((e == debug_e .and. i == debug_i .and. c == debug_g) & - .or. .not. iand(debug_level(debug_crystallite),debug_levelSelective) /= 0)) then - write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST stress >> solution at el ip ipc ',e,i,c - write(6,'(/,a,/,3(12x,3(f12.4,1x)/))') '<< CRYST stress >> P / MPa', & - transpose(crystallite_P(1:3,1:3,c,i,e))*1.0e-6_pReal - write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST stress >> Fp', & - transpose(crystallite_Fp(1:3,1:3,c,i,e)) - write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST stress >> Fi', & - transpose(crystallite_Fi(1:3,1:3,c,i,e)) - write(6,'(a,/,3(12x,3(f14.9,1x)/),/)') '<< CRYST stress >> Lp', & - transpose(crystallite_Lp(1:3,1:3,c,i,e)) - write(6,'(a,/,3(12x,3(f14.9,1x)/),/)') '<< CRYST stress >> Li', & - transpose(crystallite_Li(1:3,1:3,c,i,e)) - flush(6) - endif - enddo - enddo - enddo elementLooping6 + elementLooping6: do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do c = 1,homogenization_Ngrains(mesh_element(3,e)) + if (.not. crystallite_converged(c,i,e)) then + if(iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) & + write(6,'(a,i8,1x,i2,1x,i3,/)') '<< CRYST stress >> no convergence at el ip ipc ', & + e,i,c + endif + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & + .and. ((e == debug_e .and. i == debug_i .and. c == debug_g) & + .or. .not. iand(debug_level(debug_crystallite),debug_levelSelective) /= 0)) then + write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST stress >> solution at el ip ipc ',e,i,c + write(6,'(/,a,/,3(12x,3(f12.4,1x)/))') '<< CRYST stress >> P / MPa', & + transpose(crystallite_P(1:3,1:3,c,i,e))*1.0e-6_pReal + write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST stress >> Fp', & + transpose(crystallite_Fp(1:3,1:3,c,i,e)) + write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST stress >> Fi', & + transpose(crystallite_Fi(1:3,1:3,c,i,e)) + write(6,'(a,/,3(12x,3(f14.9,1x)/),/)') '<< CRYST stress >> Lp', & + transpose(crystallite_Lp(1:3,1:3,c,i,e)) + write(6,'(a,/,3(12x,3(f14.9,1x)/),/)') '<< CRYST stress >> Li', & + transpose(crystallite_Li(1:3,1:3,c,i,e)) + flush(6) + endif + enddo + enddo + enddo elementLooping6 #endif end function crystallite_stress @@ -679,163 +679,163 @@ end function crystallite_stress !> @brief calculate tangent (dPdF) !-------------------------------------------------------------------------------------------------- subroutine crystallite_stressTangent() - use prec, only: & - tol_math_check, & - dNeq0 - use IO, only: & - IO_warning, & - IO_error - use math, only: & - math_inv33, & - math_identity2nd, & - math_3333to99, & - math_99to3333, & - math_I3, & - math_mul3333xx3333, & - math_mul33xx33, & - math_invert2, & - math_det33 - use mesh, only: & - mesh_element - use material, only: & - homogenization_Ngrains - use constitutive, only: & - constitutive_SandItsTangents, & - constitutive_LpAndItsTangents, & - constitutive_LiAndItsTangents + use prec, only: & + tol_math_check, & + dNeq0 + use IO, only: & + IO_warning, & + IO_error + use math, only: & + math_inv33, & + math_identity2nd, & + math_3333to99, & + math_99to3333, & + math_I3, & + math_mul3333xx3333, & + math_mul33xx33, & + math_invert2, & + math_det33 + use mesh, only: & + mesh_element + use material, only: & + homogenization_Ngrains + use constitutive, only: & + constitutive_SandItsTangents, & + constitutive_LpAndItsTangents, & + constitutive_LiAndItsTangents - implicit none - integer :: & - c, & !< counter in integration point component loop - i, & !< counter in integration point loop - e, & !< counter in element loop - o, & - p + implicit none + integer :: & + c, & !< counter in integration point component loop + i, & !< counter in integration point loop + e, & !< counter in element loop + o, & + p - real(pReal), dimension(3,3) :: temp_33_1, devNull,invSubFi0, temp_33_2, temp_33_3, temp_33_4 - real(pReal), dimension(3,3,3,3) :: dSdFe, & - dSdF, & - dSdFi, & - dLidS, & - dLidFi, & - dLpdS, & - dLpdFi, & - dFidS, & - dFpinvdF, & - rhs_3333, & - lhs_3333, & - temp_3333 - real(pReal), dimension(9,9):: temp_99 - logical :: error + real(pReal), dimension(3,3) :: temp_33_1, devNull,invSubFi0, temp_33_2, temp_33_3, temp_33_4 + real(pReal), dimension(3,3,3,3) :: dSdFe, & + dSdF, & + dSdFi, & + dLidS, & + dLidFi, & + dLpdS, & + dLpdFi, & + dFidS, & + dFpinvdF, & + rhs_3333, & + lhs_3333, & + temp_3333 + real(pReal), dimension(9,9):: temp_99 + logical :: error - !$OMP PARALLEL DO PRIVATE(dSdF,dSdFe,dSdFi,dLpdS,dLpdFi,dFpinvdF,dLidS,dLidFi,dFidS,invSubFi0,o,p, & - !$OMP rhs_3333,lhs_3333,temp_99,temp_33_1,temp_33_2,temp_33_3,temp_33_4,temp_3333,error) - elementLooping: do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do c = 1,homogenization_Ngrains(mesh_element(3,e)) + !$OMP PARALLEL DO PRIVATE(dSdF,dSdFe,dSdFi,dLpdS,dLpdFi,dFpinvdF,dLidS,dLidFi,dFidS,invSubFi0,o,p, & + !$OMP rhs_3333,lhs_3333,temp_99,temp_33_1,temp_33_2,temp_33_3,temp_33_4,temp_3333,error) + elementLooping: do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do c = 1,homogenization_Ngrains(mesh_element(3,e)) - call constitutive_SandItsTangents(devNull,dSdFe,dSdFi, & - crystallite_Fe(1:3,1:3,c,i,e), & - crystallite_Fi(1:3,1:3,c,i,e),c,i,e) ! call constitutive law to calculate elastic stress tangent - call constitutive_LiAndItsTangents(devNull,dLidS,dLidFi, & - crystallite_S (1:3,1:3,c,i,e), & - crystallite_Fi(1:3,1:3,c,i,e), & - c,i,e) ! call constitutive law to calculate Li tangent in lattice configuration + call constitutive_SandItsTangents(devNull,dSdFe,dSdFi, & + crystallite_Fe(1:3,1:3,c,i,e), & + crystallite_Fi(1:3,1:3,c,i,e),c,i,e) ! call constitutive law to calculate elastic stress tangent + call constitutive_LiAndItsTangents(devNull,dLidS,dLidFi, & + crystallite_S (1:3,1:3,c,i,e), & + crystallite_Fi(1:3,1:3,c,i,e), & + c,i,e) ! call constitutive law to calculate Li tangent in lattice configuration - if (sum(abs(dLidS)) < tol_math_check) then - dFidS = 0.0_pReal - else - invSubFi0 = math_inv33(crystallite_subFi0(1:3,1:3,c,i,e)) - lhs_3333 = 0.0_pReal; rhs_3333 = 0.0_pReal - do o=1,3; do p=1,3 - lhs_3333(1:3,1:3,o,p) = lhs_3333(1:3,1:3,o,p) & - + crystallite_subdt(c,i,e)*matmul(invSubFi0,dLidFi(1:3,1:3,o,p)) - lhs_3333(1:3,o,1:3,p) = lhs_3333(1:3,o,1:3,p) & - + crystallite_invFi(1:3,1:3,c,i,e)*crystallite_invFi(p,o,c,i,e) - rhs_3333(1:3,1:3,o,p) = rhs_3333(1:3,1:3,o,p) & - - crystallite_subdt(c,i,e)*matmul(invSubFi0,dLidS(1:3,1:3,o,p)) - enddo;enddo - call math_invert2(temp_99,error,math_3333to99(lhs_3333)) - if (error) then - call IO_warning(warning_ID=600,el=e,ip=i,g=c, & - ext_msg='inversion error in analytic tangent calculation') - dFidS = 0.0_pReal - else - dFidS = math_mul3333xx3333(math_99to3333(temp_99),rhs_3333) - endif - dLidS = math_mul3333xx3333(dLidFi,dFidS) + dLidS - endif + if (sum(abs(dLidS)) < tol_math_check) then + dFidS = 0.0_pReal + else + invSubFi0 = math_inv33(crystallite_subFi0(1:3,1:3,c,i,e)) + lhs_3333 = 0.0_pReal; rhs_3333 = 0.0_pReal + do o=1,3; do p=1,3 + lhs_3333(1:3,1:3,o,p) = lhs_3333(1:3,1:3,o,p) & + + crystallite_subdt(c,i,e)*matmul(invSubFi0,dLidFi(1:3,1:3,o,p)) + lhs_3333(1:3,o,1:3,p) = lhs_3333(1:3,o,1:3,p) & + + crystallite_invFi(1:3,1:3,c,i,e)*crystallite_invFi(p,o,c,i,e) + rhs_3333(1:3,1:3,o,p) = rhs_3333(1:3,1:3,o,p) & + - crystallite_subdt(c,i,e)*matmul(invSubFi0,dLidS(1:3,1:3,o,p)) + enddo;enddo + call math_invert2(temp_99,error,math_3333to99(lhs_3333)) + if (error) then + call IO_warning(warning_ID=600,el=e,ip=i,g=c, & + ext_msg='inversion error in analytic tangent calculation') + dFidS = 0.0_pReal + else + dFidS = math_mul3333xx3333(math_99to3333(temp_99),rhs_3333) + endif + dLidS = math_mul3333xx3333(dLidFi,dFidS) + dLidS + endif - call constitutive_LpAndItsTangents(devNull,dLpdS,dLpdFi, & - crystallite_S (1:3,1:3,c,i,e), & - crystallite_Fi(1:3,1:3,c,i,e),c,i,e) ! call constitutive law to calculate Lp tangent in lattice configuration - dLpdS = math_mul3333xx3333(dLpdFi,dFidS) + dLpdS + call constitutive_LpAndItsTangents(devNull,dLpdS,dLpdFi, & + crystallite_S (1:3,1:3,c,i,e), & + crystallite_Fi(1:3,1:3,c,i,e),c,i,e) ! call constitutive law to calculate Lp tangent in lattice configuration + dLpdS = math_mul3333xx3333(dLpdFi,dFidS) + dLpdS !-------------------------------------------------------------------------------------------------- ! calculate dSdF - temp_33_1 = transpose(matmul(crystallite_invFp(1:3,1:3,c,i,e), & - crystallite_invFi(1:3,1:3,c,i,e))) - temp_33_2 = matmul( crystallite_subF (1:3,1:3,c,i,e), & - math_inv33(crystallite_subFp0(1:3,1:3,c,i,e))) - temp_33_3 = matmul(matmul(crystallite_subF (1:3,1:3,c,i,e), & - crystallite_invFp (1:3,1:3,c,i,e)), & - math_inv33(crystallite_subFi0(1:3,1:3,c,i,e))) + temp_33_1 = transpose(matmul(crystallite_invFp(1:3,1:3,c,i,e), & + crystallite_invFi(1:3,1:3,c,i,e))) + temp_33_2 = matmul( crystallite_subF (1:3,1:3,c,i,e), & + math_inv33(crystallite_subFp0(1:3,1:3,c,i,e))) + temp_33_3 = matmul(matmul(crystallite_subF (1:3,1:3,c,i,e), & + crystallite_invFp (1:3,1:3,c,i,e)), & + math_inv33(crystallite_subFi0(1:3,1:3,c,i,e))) - forall(p=1:3, o=1:3) - rhs_3333(p,o,1:3,1:3) = matmul(dSdFe(p,o,1:3,1:3),temp_33_1) - temp_3333(1:3,1:3,p,o) = matmul(matmul(temp_33_2,dLpdS(1:3,1:3,p,o)), & - crystallite_invFi(1:3,1:3,c,i,e)) & - + matmul(temp_33_3,dLidS(1:3,1:3,p,o)) - end forall - lhs_3333 = crystallite_subdt(c,i,e)*math_mul3333xx3333(dSdFe,temp_3333) & - + math_mul3333xx3333(dSdFi,dFidS) + forall(p=1:3, o=1:3) + rhs_3333(p,o,1:3,1:3) = matmul(dSdFe(p,o,1:3,1:3),temp_33_1) + temp_3333(1:3,1:3,p,o) = matmul(matmul(temp_33_2,dLpdS(1:3,1:3,p,o)), & + crystallite_invFi(1:3,1:3,c,i,e)) & + + matmul(temp_33_3,dLidS(1:3,1:3,p,o)) + end forall + lhs_3333 = crystallite_subdt(c,i,e)*math_mul3333xx3333(dSdFe,temp_3333) & + + math_mul3333xx3333(dSdFi,dFidS) - call math_invert2(temp_99,error,math_identity2nd(9)+math_3333to99(lhs_3333)) - if (error) then - call IO_warning(warning_ID=600,el=e,ip=i,g=c, & - ext_msg='inversion error in analytic tangent calculation') - dSdF = rhs_3333 - else - dSdF = math_mul3333xx3333(math_99to3333(temp_99),rhs_3333) - endif + call math_invert2(temp_99,error,math_identity2nd(9)+math_3333to99(lhs_3333)) + if (error) then + call IO_warning(warning_ID=600,el=e,ip=i,g=c, & + ext_msg='inversion error in analytic tangent calculation') + dSdF = rhs_3333 + else + dSdF = math_mul3333xx3333(math_99to3333(temp_99),rhs_3333) + endif !-------------------------------------------------------------------------------------------------- ! calculate dFpinvdF - temp_3333 = math_mul3333xx3333(dLpdS,dSdF) - forall(p=1:3, o=1:3) - dFpinvdF(1:3,1:3,p,o) & - = -crystallite_subdt(c,i,e) & - * matmul(math_inv33(crystallite_subFp0(1:3,1:3,c,i,e)), & - matmul(temp_3333(1:3,1:3,p,o),crystallite_invFi(1:3,1:3,c,i,e))) - end forall + temp_3333 = math_mul3333xx3333(dLpdS,dSdF) + forall(p=1:3, o=1:3) + dFpinvdF(1:3,1:3,p,o) & + = -crystallite_subdt(c,i,e) & + * matmul(math_inv33(crystallite_subFp0(1:3,1:3,c,i,e)), & + matmul(temp_3333(1:3,1:3,p,o),crystallite_invFi(1:3,1:3,c,i,e))) + end forall !-------------------------------------------------------------------------------------------------- ! assemble dPdF - temp_33_1 = matmul(crystallite_invFp(1:3,1:3,c,i,e), & - matmul(crystallite_S(1:3,1:3,c,i,e), & - transpose(crystallite_invFp(1:3,1:3,c,i,e)))) - temp_33_2 = matmul(crystallite_S(1:3,1:3,c,i,e), & - transpose(crystallite_invFp(1:3,1:3,c,i,e))) - temp_33_3 = matmul(crystallite_subF(1:3,1:3,c,i,e), & - crystallite_invFp(1:3,1:3,c,i,e)) - temp_33_4 = matmul(matmul(crystallite_subF(1:3,1:3,c,i,e), & - crystallite_invFp(1:3,1:3,c,i,e)), & - crystallite_S(1:3,1:3,c,i,e)) + temp_33_1 = matmul(crystallite_invFp(1:3,1:3,c,i,e), & + matmul(crystallite_S(1:3,1:3,c,i,e), & + transpose(crystallite_invFp(1:3,1:3,c,i,e)))) + temp_33_2 = matmul(crystallite_S(1:3,1:3,c,i,e), & + transpose(crystallite_invFp(1:3,1:3,c,i,e))) + temp_33_3 = matmul(crystallite_subF(1:3,1:3,c,i,e), & + crystallite_invFp(1:3,1:3,c,i,e)) + temp_33_4 = matmul(matmul(crystallite_subF(1:3,1:3,c,i,e), & + crystallite_invFp(1:3,1:3,c,i,e)), & + crystallite_S(1:3,1:3,c,i,e)) - crystallite_dPdF(1:3,1:3,1:3,1:3,c,i,e) = 0.0_pReal - do p=1, 3 - crystallite_dPdF(p,1:3,p,1:3,c,i,e) = transpose(temp_33_1) - enddo - forall(p=1:3, o=1:3) - crystallite_dPdF(1:3,1:3,p,o,c,i,e) = crystallite_dPdF(1:3,1:3,p,o,c,i,e) + & - matmul(matmul(crystallite_subF(1:3,1:3,c,i,e),dFpinvdF(1:3,1:3,p,o)),temp_33_2) + & - matmul(matmul(temp_33_3,dSdF(1:3,1:3,p,o)),transpose(crystallite_invFp(1:3,1:3,c,i,e))) + & - matmul(temp_33_4,transpose(dFpinvdF(1:3,1:3,p,o))) - end forall + crystallite_dPdF(1:3,1:3,1:3,1:3,c,i,e) = 0.0_pReal + do p=1, 3 + crystallite_dPdF(p,1:3,p,1:3,c,i,e) = transpose(temp_33_1) + enddo + forall(p=1:3, o=1:3) + crystallite_dPdF(1:3,1:3,p,o,c,i,e) = crystallite_dPdF(1:3,1:3,p,o,c,i,e) + & + matmul(matmul(crystallite_subF(1:3,1:3,c,i,e),dFpinvdF(1:3,1:3,p,o)),temp_33_2) + & + matmul(matmul(temp_33_3,dSdF(1:3,1:3,p,o)),transpose(crystallite_invFp(1:3,1:3,c,i,e))) + & + matmul(temp_33_4,transpose(dFpinvdF(1:3,1:3,p,o))) + end forall - enddo; enddo - enddo elementLooping - !$OMP END PARALLEL DO + enddo; enddo + enddo elementLooping + !$OMP END PARALLEL DO end subroutine crystallite_stressTangent @@ -844,44 +844,43 @@ end subroutine crystallite_stressTangent !> @brief calculates orientations !-------------------------------------------------------------------------------------------------- subroutine crystallite_orientations - use math, only: & - math_rotationalPart33, & - math_RtoQ - use material, only: & - plasticState, & - material_phase, & - homogenization_Ngrains - use mesh, only: & - mesh_element - use lattice, only: & - lattice_qDisorientation - use plastic_nonlocal, only: & - plastic_nonlocal_updateCompatibility - - implicit none - integer & - c, & !< counter in integration point component loop - i, & !< counter in integration point loop - e !< counter in element loop - -!$OMP PARALLEL DO - do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do c = 1,homogenization_Ngrains(mesh_element(3,e)) - call crystallite_orientation(c,i,e)%fromRotationMatrix(transpose(math_rotationalPart33(crystallite_Fe(1:3,1:3,c,i,e)))) - enddo; enddo; enddo -!$OMP END PARALLEL DO + use math, only: & + math_rotationalPart33, & + math_RtoQ + use material, only: & + plasticState, & + material_phase, & + homogenization_Ngrains + use mesh, only: & + mesh_element + use lattice, only: & + lattice_qDisorientation + use plastic_nonlocal, only: & + plastic_nonlocal_updateCompatibility - ! --- we use crystallite_orientation from above, so need a separate loop - nonlocalPresent: if (any(plasticState%nonLocal)) then -!$OMP PARALLEL DO - do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - if (plasticState(material_phase(1,i,e))%nonLocal) & ! if nonlocal model - call plastic_nonlocal_updateCompatibility(crystallite_orientation,i,e) - enddo; enddo -!$OMP END PARALLEL DO - endif nonlocalPresent + implicit none + integer & + c, & !< counter in integration point component loop + i, & !< counter in integration point loop + e !< counter in element loop + + !$OMP PARALLEL DO + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do c = 1,homogenization_Ngrains(mesh_element(3,e)) + call crystallite_orientation(c,i,e)%fromRotationMatrix(transpose(math_rotationalPart33(crystallite_Fe(1:3,1:3,c,i,e)))) + enddo; enddo; enddo + !$OMP END PARALLEL DO + + nonlocalPresent: if (any(plasticState%nonLocal)) then + !$OMP PARALLEL DO + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + if (plasticState(material_phase(1,i,e))%nonLocal) & ! if nonlocal model + call plastic_nonlocal_updateCompatibility(crystallite_orientation,i,e) + enddo; enddo + !$OMP END PARALLEL DO + endif nonlocalPresent end subroutine crystallite_orientations @@ -890,24 +889,24 @@ end subroutine crystallite_orientations !> @brief Map 2nd order tensor to reference config !-------------------------------------------------------------------------------------------------- function crystallite_push33ToRef(ipc,ip,el, tensor33) - use math, only: & - math_inv33, & - math_EulerToR - use material, only: & - material_EulerAngles ! ToDo: Why stored? We also have crystallite_orientation0 - - implicit none - real(pReal), dimension(3,3) :: crystallite_push33ToRef - real(pReal), dimension(3,3), intent(in) :: tensor33 - real(pReal), dimension(3,3) :: T - integer, intent(in):: & - el, & ! element index - ip, & ! integration point index - ipc ! grain index - - T = matmul(math_EulerToR(material_EulerAngles(1:3,ipc,ip,el)), & - transpose(math_inv33(crystallite_subF(1:3,1:3,ipc,ip,el)))) - crystallite_push33ToRef = matmul(transpose(T),matmul(tensor33,T)) + use math, only: & + math_inv33, & + math_EulerToR + use material, only: & + material_EulerAngles ! ToDo: Why stored? We also have crystallite_orientation0 + + implicit none + real(pReal), dimension(3,3) :: crystallite_push33ToRef + real(pReal), dimension(3,3), intent(in) :: tensor33 + real(pReal), dimension(3,3) :: T + integer, intent(in):: & + el, & + ip, & + ipc + + T = matmul(math_EulerToR(material_EulerAngles(1:3,ipc,ip,el)), & + transpose(math_inv33(crystallite_subF(1:3,1:3,ipc,ip,el)))) + crystallite_push33ToRef = matmul(transpose(T),matmul(tensor33,T)) end function crystallite_push33ToRef @@ -1057,434 +1056,428 @@ end function crystallite_postResults !> @brief calculation of stress (P) with time integration based on a residuum in Lp and !> intermediate acceleration of the Newton-Raphson correction !-------------------------------------------------------------------------------------------------- -logical function integrateStress(& - ipc,& ! grain number - ip,& ! integration point number - el,& ! element number - timeFraction & - ) - use, intrinsic :: & - IEEE_arithmetic - use prec, only: tol_math_check, & - dEq0 - use numerics, only: nStress, & - aTol_crystalliteStress, & - rTol_crystalliteStress, & - iJacoLpresiduum, & - subStepSizeLp, & - subStepSizeLi +logical function integrateStress(ipc,ip,el,timeFraction) + use, intrinsic :: & + IEEE_arithmetic + use prec, only: tol_math_check, & + dEq0 + use numerics, only: nStress, & + aTol_crystalliteStress, & + rTol_crystalliteStress, & + iJacoLpresiduum, & + subStepSizeLp, & + subStepSizeLi #ifdef DEBUG - use debug, only: debug_level, & - debug_e, & - debug_i, & - debug_g, & - debug_crystallite, & - debug_levelBasic, & - debug_levelExtensive, & - debug_levelSelective + use debug, only: debug_level, & + debug_e, & + debug_i, & + debug_g, & + debug_crystallite, & + debug_levelBasic, & + debug_levelExtensive, & + debug_levelSelective #endif - use constitutive, only: constitutive_LpAndItsTangents, & - constitutive_LiAndItsTangents, & - constitutive_SandItsTangents - use math, only: math_mul33xx33, & - math_mul3333xx3333, & - math_inv33, & - math_det33, & - math_I3, & - math_identity2nd, & - math_3333to99, & - math_33to9, & - math_9to33 - - implicit none - integer, intent(in):: el, & ! element index - ip, & ! integration point index - ipc ! grain index - real(pReal), optional, intent(in) :: timeFraction ! fraction of timestep - - real(pReal), dimension(3,3):: Fg_new, & ! deformation gradient at end of timestep - Fp_new, & ! plastic deformation gradient at end of timestep - Fe_new, & ! elastic deformation gradient at end of timestep - invFp_new, & ! inverse of Fp_new - Fi_new, & ! gradient of intermediate deformation stages - invFi_new, & - invFp_current, & ! inverse of Fp_current - invFi_current, & ! inverse of Fp_current - Lpguess, & ! current guess for plastic velocity gradient - Lpguess_old, & ! known last good guess for plastic velocity gradient - Lp_constitutive, & ! plastic velocity gradient resulting from constitutive law - residuumLp, & ! current residuum of plastic velocity gradient - residuumLp_old, & ! last residuum of plastic velocity gradient - deltaLp, & ! direction of next guess - Liguess, & ! current guess for intermediate velocity gradient - Liguess_old, & ! known last good guess for intermediate velocity gradient - Li_constitutive, & ! intermediate velocity gradient resulting from constitutive law - residuumLi, & ! current residuum of intermediate velocity gradient - residuumLi_old, & ! last residuum of intermediate velocity gradient - deltaLi, & ! direction of next guess - S, & ! 2nd Piola-Kirchhoff Stress in plastic (lattice) configuration - A, & - B, & - Fe, & ! elastic deformation gradient - temp_33 - real(pReal), dimension(9) :: work ! needed for matrix inversion by LAPACK - integer, dimension(9) :: devNull ! needed for matrix inversion by LAPACK - real(pReal), dimension(9,9) :: dRLp_dLp, & ! partial derivative of residuum (Jacobian for Newton-Raphson scheme) - dRLp_dLp2, & ! working copy of dRdLp - dRLi_dLi ! partial derivative of residuumI (Jacobian for Newton-Raphson scheme) - real(pReal), dimension(3,3,3,3):: dS_dFe, & ! partial derivative of 2nd Piola-Kirchhoff stress - dS_dFi, & - dFe_dLp, & ! partial derivative of elastic deformation gradient - dFe_dLi, & - dFi_dLi, & - dLp_dFi, & - dLi_dFi, & - dLp_dS, & - dLi_dS - real(pReal) detInvFi, & ! determinant of InvFi - steplengthLp, & - steplengthLi, & - dt, & ! time increment - aTolLp, & - aTolLi - integer NiterationStressLp, & ! number of stress integrations - NiterationStressLi, & ! number of inner stress integrations - ierr, & ! error indicator for LAPACK - o, & - p, & - jacoCounterLp, & - jacoCounterLi ! counters to check for Jacobian update - external :: & - dgesv - - !* be pessimistic - integrateStress = .false. + use constitutive, only: constitutive_LpAndItsTangents, & + constitutive_LiAndItsTangents, & + constitutive_SandItsTangents + use math, only: math_mul33xx33, & + math_mul3333xx3333, & + math_inv33, & + math_det33, & + math_I3, & + math_identity2nd, & + math_3333to99, & + math_33to9, & + math_9to33 + + implicit none + integer, intent(in):: el, & ! element index + ip, & ! integration point index + ipc ! grain index + real(pReal), optional, intent(in) :: timeFraction ! fraction of timestep + + real(pReal), dimension(3,3):: Fg_new, & ! deformation gradient at end of timestep + Fp_new, & ! plastic deformation gradient at end of timestep + Fe_new, & ! elastic deformation gradient at end of timestep + invFp_new, & ! inverse of Fp_new + Fi_new, & ! gradient of intermediate deformation stages + invFi_new, & + invFp_current, & ! inverse of Fp_current + invFi_current, & ! inverse of Fp_current + Lpguess, & ! current guess for plastic velocity gradient + Lpguess_old, & ! known last good guess for plastic velocity gradient + Lp_constitutive, & ! plastic velocity gradient resulting from constitutive law + residuumLp, & ! current residuum of plastic velocity gradient + residuumLp_old, & ! last residuum of plastic velocity gradient + deltaLp, & ! direction of next guess + Liguess, & ! current guess for intermediate velocity gradient + Liguess_old, & ! known last good guess for intermediate velocity gradient + Li_constitutive, & ! intermediate velocity gradient resulting from constitutive law + residuumLi, & ! current residuum of intermediate velocity gradient + residuumLi_old, & ! last residuum of intermediate velocity gradient + deltaLi, & ! direction of next guess + S, & ! 2nd Piola-Kirchhoff Stress in plastic (lattice) configuration + A, & + B, & + Fe, & ! elastic deformation gradient + temp_33 + real(pReal), dimension(9) :: work ! needed for matrix inversion by LAPACK + integer, dimension(9) :: devNull ! needed for matrix inversion by LAPACK + real(pReal), dimension(9,9) :: dRLp_dLp, & ! partial derivative of residuum (Jacobian for Newton-Raphson scheme) + dRLp_dLp2, & ! working copy of dRdLp + dRLi_dLi ! partial derivative of residuumI (Jacobian for Newton-Raphson scheme) + real(pReal), dimension(3,3,3,3):: dS_dFe, & ! partial derivative of 2nd Piola-Kirchhoff stress + dS_dFi, & + dFe_dLp, & ! partial derivative of elastic deformation gradient + dFe_dLi, & + dFi_dLi, & + dLp_dFi, & + dLi_dFi, & + dLp_dS, & + dLi_dS + real(pReal) detInvFi, & ! determinant of InvFi + steplengthLp, & + steplengthLi, & + dt, & ! time increment + aTolLp, & + aTolLi + integer NiterationStressLp, & ! number of stress integrations + NiterationStressLi, & ! number of inner stress integrations + ierr, & ! error indicator for LAPACK + o, & + p, & + jacoCounterLp, & + jacoCounterLi ! counters to check for Jacobian update + external :: & + dgesv + + !* be pessimistic + integrateStress = .false. #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & - .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) & - write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST integrateStress >> at el ip ipc ',el,ip,ipc + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & + .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) & + write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST integrateStress >> at el ip ipc ',el,ip,ipc #endif - if (present(timeFraction)) then - dt = crystallite_subdt(ipc,ip,el) * timeFraction - Fg_new = crystallite_subF0(1:3,1:3,ipc,ip,el) & - + (crystallite_subF(1:3,1:3,ipc,ip,el) - crystallite_subF0(1:3,1:3,ipc,ip,el)) * timeFraction - else - dt = crystallite_subdt(ipc,ip,el) - Fg_new = crystallite_subF(1:3,1:3,ipc,ip,el) - endif + if (present(timeFraction)) then + dt = crystallite_subdt(ipc,ip,el) * timeFraction + Fg_new = crystallite_subF0(1:3,1:3,ipc,ip,el) & + + (crystallite_subF(1:3,1:3,ipc,ip,el) - crystallite_subF0(1:3,1:3,ipc,ip,el)) * timeFraction + else + dt = crystallite_subdt(ipc,ip,el) + Fg_new = crystallite_subF(1:3,1:3,ipc,ip,el) + endif !* feed local variables - Lpguess = crystallite_Lp(1:3,1:3,ipc,ip,el) ! ... and take it as first guess - Liguess = crystallite_Li(1:3,1:3,ipc,ip,el) ! ... and take it as first guess - Liguess_old = Liguess - - invFp_current = math_inv33(crystallite_subFp0(1:3,1:3,ipc,ip,el)) - failedInversionFp: if (all(dEq0(invFp_current))) then + Lpguess = crystallite_Lp(1:3,1:3,ipc,ip,el) ! ... and take it as first guess + Liguess = crystallite_Li(1:3,1:3,ipc,ip,el) ! ... and take it as first guess + Liguess_old = Liguess + + invFp_current = math_inv33(crystallite_subFp0(1:3,1:3,ipc,ip,el)) + failedInversionFp: if (all(dEq0(invFp_current))) then #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) & - write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST integrateStress >> failed on inversion of current Fp at el ip ipc ',& - el,ip,ipc - if (iand(debug_level(debug_crystallite), debug_levelExtensive) > 0) & - write(6,'(/,a,/,3(12x,3(f12.7,1x)/))') '<< CRYST >> current Fp ',transpose(crystallite_subFp0(1:3,1:3,ipc,ip,el)) + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) & + write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST integrateStress >> failed on inversion of current Fp at el ip ipc ',& + el,ip,ipc + if (iand(debug_level(debug_crystallite), debug_levelExtensive) > 0) & + write(6,'(/,a,/,3(12x,3(f12.7,1x)/))') '<< CRYST >> current Fp ',transpose(crystallite_subFp0(1:3,1:3,ipc,ip,el)) #endif - return - endif failedInversionFp - A = matmul(Fg_new,invFp_current) ! intermediate tensor needed later to calculate dFe_dLp + return + endif failedInversionFp + A = matmul(Fg_new,invFp_current) ! intermediate tensor needed later to calculate dFe_dLp - invFi_current = math_inv33(crystallite_subFi0(1:3,1:3,ipc,ip,el)) - failedInversionFi: if (all(dEq0(invFi_current))) then + invFi_current = math_inv33(crystallite_subFi0(1:3,1:3,ipc,ip,el)) + failedInversionFi: if (all(dEq0(invFi_current))) then #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) & - write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST integrateStress >> failed on inversion of current Fi at el ip ipc ',& - el,ip,ipc - if (iand(debug_level(debug_crystallite), debug_levelExtensive) > 0) & - write(6,'(/,a,/,3(12x,3(f12.7,1x)/))') '<< CRYST integrateStress >> current Fi ', & - transpose(crystallite_subFi0(1:3,1:3,ipc,ip,el)) + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) & + write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST integrateStress >> failed on inversion of current Fi at el ip ipc ',& + el,ip,ipc + if (iand(debug_level(debug_crystallite), debug_levelExtensive) > 0) & + write(6,'(/,a,/,3(12x,3(f12.7,1x)/))') '<< CRYST integrateStress >> current Fi ', & + transpose(crystallite_subFi0(1:3,1:3,ipc,ip,el)) #endif - return - endif failedInversionFi - - !* start Li loop with normal step length - NiterationStressLi = 0 - jacoCounterLi = 0 - steplengthLi = 1.0_pReal - residuumLi_old = 0.0_pReal - - LiLoop: do - NiterationStressLi = NiterationStressLi + 1 - LiLoopLimit: if (NiterationStressLi > nStress) then + return + endif failedInversionFi + + !* start Li loop with normal step length + NiterationStressLi = 0 + jacoCounterLi = 0 + steplengthLi = 1.0_pReal + residuumLi_old = 0.0_pReal + + LiLoop: do + NiterationStressLi = NiterationStressLi + 1 + LiLoopLimit: if (NiterationStressLi > nStress) then #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) & - write(6,'(a,i3,a,i8,1x,i2,1x,i3,/)') '<< CRYST integrateStress >> reached Li loop limit',nStress, & + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) & + write(6,'(a,i3,a,i8,1x,i2,1x,i3,/)') '<< CRYST integrateStress >> reached Li loop limit',nStress, & ' at el ip ipc ', el,ip,ipc #endif - return - endif LiLoopLimit - - invFi_new = matmul(invFi_current,math_I3 - dt*Liguess) - Fi_new = math_inv33(invFi_new) - detInvFi = math_det33(invFi_new) - - !* start Lp loop with normal step length - NiterationStressLp = 0 - jacoCounterLp = 0 - steplengthLp = 1.0_pReal - residuumLp_old = 0.0_pReal - Lpguess_old = Lpguess - - LpLoop: do - NiterationStressLp = NiterationStressLp + 1 - LpLoopLimit: if (NiterationStressLp > nStress) then + return + endif LiLoopLimit + + invFi_new = matmul(invFi_current,math_I3 - dt*Liguess) + Fi_new = math_inv33(invFi_new) + detInvFi = math_det33(invFi_new) + + !* start Lp loop with normal step length + NiterationStressLp = 0 + jacoCounterLp = 0 + steplengthLp = 1.0_pReal + residuumLp_old = 0.0_pReal + Lpguess_old = Lpguess + + LpLoop: do + NiterationStressLp = NiterationStressLp + 1 + LpLoopLimit: if (NiterationStressLp > nStress) then #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) & - write(6,'(a,i3,a,i8,1x,i2,1x,i3,/)') '<< CRYST integrateStress >> reached Lp loop limit',nStress, & - ' at el ip ipc ', el,ip,ipc + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) & + write(6,'(a,i3,a,i8,1x,i2,1x,i3,/)') '<< CRYST integrateStress >> reached Lp loop limit',nStress, & + ' at el ip ipc ', el,ip,ipc #endif - return - endif LpLoopLimit - - !* calculate (elastic) 2nd Piola--Kirchhoff stress tensor and its tangent from constitutive law - - B = math_I3 - dt*Lpguess - Fe = matmul(matmul(A,B), invFi_new) - call constitutive_SandItsTangents(S, dS_dFe, dS_dFi, & - Fe, Fi_new, ipc, ip, el) ! call constitutive law to calculate 2nd Piola-Kirchhoff stress and its derivative in unloaded configuration - - !* calculate plastic velocity gradient and its tangent from constitutive law - call constitutive_LpAndItsTangents(Lp_constitutive, dLp_dS, dLp_dFi, & - S, Fi_new, ipc, ip, el) - + return + endif LpLoopLimit + + !* calculate (elastic) 2nd Piola--Kirchhoff stress tensor and its tangent from constitutive law + + B = math_I3 - dt*Lpguess + Fe = matmul(matmul(A,B), invFi_new) + call constitutive_SandItsTangents(S, dS_dFe, dS_dFi, & + Fe, Fi_new, ipc, ip, el) ! call constitutive law to calculate 2nd Piola-Kirchhoff stress and its derivative in unloaded configuration + + !* calculate plastic velocity gradient and its tangent from constitutive law + call constitutive_LpAndItsTangents(Lp_constitutive, dLp_dS, dLp_dFi, & + S, Fi_new, ipc, ip, el) + #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & - .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) then - write(6,'(a,i3,/)') '<< CRYST integrateStress >> iteration ', NiterationStressLp - write(6,'(a,/,3(12x,3(e20.10,1x)/))') '<< CRYST integrateStress >> Lpguess', transpose(Lpguess) - write(6,'(a,/,3(12x,3(e20.10,1x)/))') '<< CRYST integrateStress >> Lp_constitutive', transpose(Lp_constitutive) - write(6,'(a,/,3(12x,3(e20.10,1x)/))') '<< CRYST integrateStress >> Fi', transpose(Fi_new) - write(6,'(a,/,3(12x,3(e20.10,1x)/))') '<< CRYST integrateStress >> Fe', transpose(Fe) - write(6,'(a,/,3(12x,3(e20.10,1x)/))') '<< CRYST integrateStress >> S', transpose(S) - endif + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & + .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) then + write(6,'(a,i3,/)') '<< CRYST integrateStress >> iteration ', NiterationStressLp + write(6,'(a,/,3(12x,3(e20.10,1x)/))') '<< CRYST integrateStress >> Lpguess', transpose(Lpguess) + write(6,'(a,/,3(12x,3(e20.10,1x)/))') '<< CRYST integrateStress >> Lp_constitutive', transpose(Lp_constitutive) + write(6,'(a,/,3(12x,3(e20.10,1x)/))') '<< CRYST integrateStress >> Fi', transpose(Fi_new) + write(6,'(a,/,3(12x,3(e20.10,1x)/))') '<< CRYST integrateStress >> Fe', transpose(Fe) + write(6,'(a,/,3(12x,3(e20.10,1x)/))') '<< CRYST integrateStress >> S', transpose(S) + endif #endif - !* update current residuum and check for convergence of loop - aTolLp = max(rTol_crystalliteStress * max(norm2(Lpguess),norm2(Lp_constitutive)), & ! absolute tolerance from largest acceptable relative error - aTol_crystalliteStress) ! minimum lower cutoff - residuumLp = Lpguess - Lp_constitutive - - if (any(IEEE_is_NaN(residuumLp))) then + !* update current residuum and check for convergence of loop + aTolLp = max(rTol_crystalliteStress * max(norm2(Lpguess),norm2(Lp_constitutive)), & ! absolute tolerance from largest acceptable relative error + aTol_crystalliteStress) ! minimum lower cutoff + residuumLp = Lpguess - Lp_constitutive + + if (any(IEEE_is_NaN(residuumLp))) then #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) & - write(6,'(a,i8,1x,i2,1x,i3,a,i3,a)') '<< CRYST integrateStress >> encountered NaN for Lp-residuum at el ip ipc ', & - el,ip,ipc, & - ' ; iteration ', NiterationStressLp,& - ' >> returning..!' + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) & + write(6,'(a,i8,1x,i2,1x,i3,a,i3,a)') '<< CRYST integrateStress >> encountered NaN for Lp-residuum at el ip ipc ', & + el,ip,ipc, & + ' ; iteration ', NiterationStressLp,& + ' >> returning..!' #endif - return ! ...me = .false. to inform integrator about problem - elseif (norm2(residuumLp) < aTolLp) then ! converged if below absolute tolerance - exit LpLoop ! ...leave iteration loop - elseif ( NiterationStressLp == 1 & - .or. norm2(residuumLp) < norm2(residuumLp_old)) then ! not converged, but improved norm of residuum (always proceed in first iteration)... - residuumLp_old = residuumLp ! ...remember old values and... - Lpguess_old = Lpguess - steplengthLp = 1.0_pReal ! ...proceed with normal step length (calculate new search direction) - else ! not converged and residuum not improved... - steplengthLp = subStepSizeLp * steplengthLp ! ...try with smaller step length in same direction - Lpguess = Lpguess_old + steplengthLp * deltaLp + return ! ...me = .false. to inform integrator about problem + elseif (norm2(residuumLp) < aTolLp) then ! converged if below absolute tolerance + exit LpLoop ! ...leave iteration loop + elseif ( NiterationStressLp == 1 & + .or. norm2(residuumLp) < norm2(residuumLp_old)) then ! not converged, but improved norm of residuum (always proceed in first iteration)... + residuumLp_old = residuumLp ! ...remember old values and... + Lpguess_old = Lpguess + steplengthLp = 1.0_pReal ! ...proceed with normal step length (calculate new search direction) + else ! not converged and residuum not improved... + steplengthLp = subStepSizeLp * steplengthLp ! ...try with smaller step length in same direction + Lpguess = Lpguess_old + steplengthLp * deltaLp #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & - .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) then - write(6,'(a,1x,f7.4)') '<< CRYST integrateStress >> linear search for Lpguess with step', steplengthLp - endif + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & + .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) then + write(6,'(a,1x,f7.4)') '<< CRYST integrateStress >> linear search for Lpguess with step', steplengthLp + endif #endif - cycle LpLoop - endif + cycle LpLoop + endif !* calculate Jacobian for correction term - if (mod(jacoCounterLp, iJacoLpresiduum) == 0) then - forall(o=1:3,p=1:3) dFe_dLp(o,1:3,p,1:3) = A(o,p)*transpose(invFi_new) ! dFe_dLp(i,j,k,l) = -dt * A(i,k) invFi(l,j) - dFe_dLp = - dt * dFe_dLp - dRLp_dLp = math_identity2nd(9) & - - math_3333to99(math_mul3333xx3333(math_mul3333xx3333(dLp_dS,dS_dFe),dFe_dLp)) + if (mod(jacoCounterLp, iJacoLpresiduum) == 0) then + forall(o=1:3,p=1:3) dFe_dLp(o,1:3,p,1:3) = A(o,p)*transpose(invFi_new) ! dFe_dLp(i,j,k,l) = -dt * A(i,k) invFi(l,j) + dFe_dLp = - dt * dFe_dLp + dRLp_dLp = math_identity2nd(9) & + - math_3333to99(math_mul3333xx3333(math_mul3333xx3333(dLp_dS,dS_dFe),dFe_dLp)) #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & - .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) then - write(6,'(a,/,9(12x,9(e12.4,1x)/))') '<< CRYST integrateStress >> dLp_dS', math_3333to99(dLp_dS) - write(6,'(a,1x,e20.10)') '<< CRYST integrateStress >> dLp_dS norm', norm2(math_3333to99(dLp_dS)) - write(6,'(a,/,9(12x,9(e12.4,1x)/))') '<< CRYST integrateStress >> dRLp_dLp', dRLp_dLp-math_identity2nd(9) - write(6,'(a,1x,e20.10)') '<< CRYST integrateStress >> dRLp_dLp norm', norm2(dRLp_dLp-math_identity2nd(9)) - endif + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & + .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) then + write(6,'(a,/,9(12x,9(e12.4,1x)/))') '<< CRYST integrateStress >> dLp_dS', math_3333to99(dLp_dS) + write(6,'(a,1x,e20.10)') '<< CRYST integrateStress >> dLp_dS norm', norm2(math_3333to99(dLp_dS)) + write(6,'(a,/,9(12x,9(e12.4,1x)/))') '<< CRYST integrateStress >> dRLp_dLp', dRLp_dLp-math_identity2nd(9) + write(6,'(a,1x,e20.10)') '<< CRYST integrateStress >> dRLp_dLp norm', norm2(dRLp_dLp-math_identity2nd(9)) + endif #endif - dRLp_dLp2 = dRLp_dLp ! will be overwritten in first call to LAPACK routine - work = math_33to9(residuumLp) - call dgesv(9,1,dRLp_dLp2,9,devNull,work,9,ierr) ! solve dRLp/dLp * delta Lp = -res for delta Lp - if (ierr /= 0) then + dRLp_dLp2 = dRLp_dLp ! will be overwritten in first call to LAPACK routine + work = math_33to9(residuumLp) + call dgesv(9,1,dRLp_dLp2,9,devNull,work,9,ierr) ! solve dRLp/dLp * delta Lp = -res for delta Lp + if (ierr /= 0) then #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) then - write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST integrateStress >> failed on dR/dLp inversion at el ip ipc ', & - el,ip,ipc - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & - .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g)& - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) then - write(6,*) - write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST integrateStress >> dR_dLp',transpose(dRLp_dLp) - write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST integrateStress >> dFe_dLp',transpose(math_3333to99(dFe_dLp)) - write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST integrateStress >> dS_dFe (cnst)',transpose(math_3333to99(dS_dFe)) - write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST integrateStress >> dLp_dS (cnst)',transpose(math_3333to99(dLp_dS)) - write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST integrateStress >> A',transpose(A) - write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST integrateStress >> B',transpose(B) - write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST integrateStress >> Lp_constitutive',transpose(Lp_constitutive) - write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST integrateStress >> Lpguess',transpose(Lpguess) - endif - endif + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) then + write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST integrateStress >> failed on dR/dLp inversion at el ip ipc ', & + el,ip,ipc + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & + .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g)& + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) then + write(6,*) + write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST integrateStress >> dR_dLp',transpose(dRLp_dLp) + write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST integrateStress >> dFe_dLp',transpose(math_3333to99(dFe_dLp)) + write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST integrateStress >> dS_dFe (cnst)',transpose(math_3333to99(dS_dFe)) + write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST integrateStress >> dLp_dS (cnst)',transpose(math_3333to99(dLp_dS)) + write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST integrateStress >> A',transpose(A) + write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST integrateStress >> B',transpose(B) + write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST integrateStress >> Lp_constitutive',transpose(Lp_constitutive) + write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST integrateStress >> Lpguess',transpose(Lpguess) + endif + endif #endif - return - endif - deltaLp = - math_9to33(work) - endif - jacoCounterLp = jacoCounterLp + 1 + return + endif + deltaLp = - math_9to33(work) + endif + jacoCounterLp = jacoCounterLp + 1 - Lpguess = Lpguess + steplengthLp * deltaLp + Lpguess = Lpguess + steplengthLp * deltaLp - enddo LpLoop + enddo LpLoop !* calculate intermediate velocity gradient and its tangent from constitutive law - call constitutive_LiAndItsTangents(Li_constitutive, dLi_dS, dLi_dFi, & - S, Fi_new, ipc, ip, el) + call constitutive_LiAndItsTangents(Li_constitutive, dLi_dS, dLi_dFi, & + S, Fi_new, ipc, ip, el) #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & - .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) then - write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST integrateStress >> Li_constitutive', transpose(Li_constitutive) - write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST integrateStress >> Liguess', transpose(Liguess) - endif + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & + .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) then + write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST integrateStress >> Li_constitutive', transpose(Li_constitutive) + write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST integrateStress >> Liguess', transpose(Liguess) + endif #endif - !* update current residuum and check for convergence of loop - aTolLi = max(rTol_crystalliteStress * max(norm2(Liguess),norm2(Li_constitutive)), & ! absolute tolerance from largest acceptable relative error - aTol_crystalliteStress) ! minimum lower cutoff - residuumLi = Liguess - Li_constitutive - if (any(IEEE_is_NaN(residuumLi))) then ! NaN in residuum... + !* update current residuum and check for convergence of loop + aTolLi = max(rTol_crystalliteStress * max(norm2(Liguess),norm2(Li_constitutive)), & ! absolute tolerance from largest acceptable relative error + aTol_crystalliteStress) ! minimum lower cutoff + residuumLi = Liguess - Li_constitutive + if (any(IEEE_is_NaN(residuumLi))) then ! NaN in residuum... #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) & - write(6,'(a,i8,1x,i2,1x,i3,a,i3,a)') '<< CRYST integrateStress >> encountered NaN for Li-residuum at el ip ipc ', & - el,ip,ipc, & - ' ; iteration ', NiterationStressLi,& - ' >> returning..!' + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) & + write(6,'(a,i8,1x,i2,1x,i3,a,i3,a)') '<< CRYST integrateStress >> encountered NaN for Li-residuum at el ip ipc ', & + el,ip,ipc, & + ' ; iteration ', NiterationStressLi,& + ' >> returning..!' #endif - return ! ...me = .false. to inform integrator about problem - elseif (norm2(residuumLi) < aTolLi) then ! converged if below absolute tolerance - exit LiLoop ! ...leave iteration loop - elseif ( NiterationStressLi == 1 & - .or. norm2(residuumLi) < norm2(residuumLi_old)) then ! not converged, but improved norm of residuum (always proceed in first iteration)... - residuumLi_old = residuumLi ! ...remember old values and... - Liguess_old = Liguess - steplengthLi = 1.0_pReal ! ...proceed with normal step length (calculate new search direction) - else ! not converged and residuum not improved... - steplengthLi = subStepSizeLi * steplengthLi ! ...try with smaller step length in same direction - Liguess = Liguess_old + steplengthLi * deltaLi - cycle LiLoop - endif - - !* calculate Jacobian for correction term - if (mod(jacoCounterLi, iJacoLpresiduum) == 0) then - temp_33 = matmul(matmul(A,B),invFi_current) - forall(o=1:3,p=1:3) - dFe_dLi(1:3,o,1:3,p) = -dt*math_I3(o,p)*temp_33 ! dFe_dLp(i,j,k,l) = -dt * A(i,k) invFi(l,j) - dFi_dLi(1:3,o,1:3,p) = -dt*math_I3(o,p)*invFi_current - end forall - forall(o=1:3,p=1:3) & - dFi_dLi(1:3,1:3,o,p) = matmul(matmul(Fi_new,dFi_dLi(1:3,1:3,o,p)),Fi_new) - - dRLi_dLi = math_identity2nd(9) & - - math_3333to99(math_mul3333xx3333(dLi_dS, math_mul3333xx3333(dS_dFe, dFe_dLi) + & - math_mul3333xx3333(dS_dFi, dFi_dLi))) & - - math_3333to99(math_mul3333xx3333(dLi_dFi, dFi_dLi)) - work = math_33to9(residuumLi) - call dgesv(9,1,dRLi_dLi,9,devNull,work,9,ierr) ! solve dRLi/dLp * delta Li = -res for delta Li - if (ierr /= 0) then + return ! ...me = .false. to inform integrator about problem + elseif (norm2(residuumLi) < aTolLi) then ! converged if below absolute tolerance + exit LiLoop ! ...leave iteration loop + elseif ( NiterationStressLi == 1 & + .or. norm2(residuumLi) < norm2(residuumLi_old)) then ! not converged, but improved norm of residuum (always proceed in first iteration)... + residuumLi_old = residuumLi ! ...remember old values and... + Liguess_old = Liguess + steplengthLi = 1.0_pReal ! ...proceed with normal step length (calculate new search direction) + else ! not converged and residuum not improved... + steplengthLi = subStepSizeLi * steplengthLi ! ...try with smaller step length in same direction + Liguess = Liguess_old + steplengthLi * deltaLi + cycle LiLoop + endif + + !* calculate Jacobian for correction term + if (mod(jacoCounterLi, iJacoLpresiduum) == 0) then + temp_33 = matmul(matmul(A,B),invFi_current) + forall(o=1:3,p=1:3) + dFe_dLi(1:3,o,1:3,p) = -dt*math_I3(o,p)*temp_33 ! dFe_dLp(i,j,k,l) = -dt * A(i,k) invFi(l,j) + dFi_dLi(1:3,o,1:3,p) = -dt*math_I3(o,p)*invFi_current + end forall + forall(o=1:3,p=1:3) & + dFi_dLi(1:3,1:3,o,p) = matmul(matmul(Fi_new,dFi_dLi(1:3,1:3,o,p)),Fi_new) + + dRLi_dLi = math_identity2nd(9) & + - math_3333to99(math_mul3333xx3333(dLi_dS, math_mul3333xx3333(dS_dFe, dFe_dLi) + & + math_mul3333xx3333(dS_dFi, dFi_dLi))) & + - math_3333to99(math_mul3333xx3333(dLi_dFi, dFi_dLi)) + work = math_33to9(residuumLi) + call dgesv(9,1,dRLi_dLi,9,devNull,work,9,ierr) ! solve dRLi/dLp * delta Li = -res for delta Li + if (ierr /= 0) then #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) then - write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST integrateStress >> failed on dR/dLi inversion at el ip ipc ', & - el,ip,ipc - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & - .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g)& - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) then - write(6,*) - write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST integrateStress >> dR_dLi',transpose(dRLi_dLi) - write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST integrateStress >> dFe_dLi',transpose(math_3333to99(dFe_dLi)) - write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST integrateStress >> dS_dFi (cnst)',transpose(math_3333to99(dS_dFi)) - write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST integrateStress >> dLi_dS (cnst)',transpose(math_3333to99(dLi_dS)) - write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST integrateStress >> Li_constitutive',transpose(Li_constitutive) - write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST integrateStress >> Liguess',transpose(Liguess) - endif - endif + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) then + write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST integrateStress >> failed on dR/dLi inversion at el ip ipc ', & + el,ip,ipc + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & + .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g)& + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) then + write(6,*) + write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST integrateStress >> dR_dLi',transpose(dRLi_dLi) + write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST integrateStress >> dFe_dLi',transpose(math_3333to99(dFe_dLi)) + write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST integrateStress >> dS_dFi (cnst)',transpose(math_3333to99(dS_dFi)) + write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST integrateStress >> dLi_dS (cnst)',transpose(math_3333to99(dLi_dS)) + write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST integrateStress >> Li_constitutive',transpose(Li_constitutive) + write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST integrateStress >> Liguess',transpose(Liguess) + endif + endif #endif - return - endif - - deltaLi = - math_9to33(work) - endif - jacoCounterLi = jacoCounterLi + 1 - - Liguess = Liguess + steplengthLi * deltaLi - enddo LiLoop - - !* calculate new plastic and elastic deformation gradient - invFp_new = matmul(invFp_current,B) - invFp_new = invFp_new / math_det33(invFp_new)**(1.0_pReal/3.0_pReal) ! regularize - Fp_new = math_inv33(invFp_new) - failedInversionInvFp: if (all(dEq0(Fp_new))) then + return + endif + + deltaLi = - math_9to33(work) + endif + jacoCounterLi = jacoCounterLi + 1 + + Liguess = Liguess + steplengthLi * deltaLi + enddo LiLoop + + !* calculate new plastic and elastic deformation gradient + invFp_new = matmul(invFp_current,B) + invFp_new = invFp_new / math_det33(invFp_new)**(1.0_pReal/3.0_pReal) ! regularize + Fp_new = math_inv33(invFp_new) + failedInversionInvFp: if (all(dEq0(Fp_new))) then #ifdef DEBUG - if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) then - write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST integrateStress >> failed on invFp_new inversion at el ip ipc ', & - el,ip,ipc - if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & - .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) & - write(6,'(/,a,/,3(12x,3(f12.7,1x)/))') '<< CRYST integrateStress >> invFp_new',transpose(invFp_new) - endif + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) then + write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST integrateStress >> failed on invFp_new inversion at el ip ipc ', & + el,ip,ipc + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0 & + .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) & + write(6,'(/,a,/,3(12x,3(f12.7,1x)/))') '<< CRYST integrateStress >> invFp_new',transpose(invFp_new) + endif #endif - return - endif failedInversionInvFp - Fe_new = matmul(matmul(Fg_new,invFp_new),invFi_new) + return + endif failedInversionInvFp + Fe_new = matmul(matmul(Fg_new,invFp_new),invFi_new) !-------------------------------------------------------------------------------------------------- ! stress integration was successful - integrateStress = .true. - crystallite_P (1:3,1:3,ipc,ip,el) = matmul(matmul(Fg_new,invFp_new), & - matmul(S,transpose(invFp_new))) - crystallite_S (1:3,1:3,ipc,ip,el) = S - crystallite_Lp (1:3,1:3,ipc,ip,el) = Lpguess - crystallite_Li (1:3,1:3,ipc,ip,el) = Liguess - crystallite_Fp (1:3,1:3,ipc,ip,el) = Fp_new - crystallite_Fi (1:3,1:3,ipc,ip,el) = Fi_new - crystallite_Fe (1:3,1:3,ipc,ip,el) = Fe_new - crystallite_invFp(1:3,1:3,ipc,ip,el) = invFp_new - crystallite_invFi(1:3,1:3,ipc,ip,el) = invFi_new + integrateStress = .true. + crystallite_P (1:3,1:3,ipc,ip,el) = matmul(matmul(Fg_new,invFp_new),matmul(S,transpose(invFp_new))) + crystallite_S (1:3,1:3,ipc,ip,el) = S + crystallite_Lp (1:3,1:3,ipc,ip,el) = Lpguess + crystallite_Li (1:3,1:3,ipc,ip,el) = Liguess + crystallite_Fp (1:3,1:3,ipc,ip,el) = Fp_new + crystallite_Fi (1:3,1:3,ipc,ip,el) = Fi_new + crystallite_Fe (1:3,1:3,ipc,ip,el) = Fe_new + crystallite_invFp(1:3,1:3,ipc,ip,el) = invFp_new + crystallite_invFi(1:3,1:3,ipc,ip,el) = invFi_new #ifdef DEBUG - if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0 & - .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & - .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) then - write(6,'(a,/)') '<< CRYST integrateStress >> successful integration' - write(6,'(a,/,3(12x,3(f12.7,1x)/))') '<< CRYST integrateStress >> P / MPa', & - transpose(crystallite_P(1:3,1:3,ipc,ip,el))*1.0e-6_pReal - write(6,'(a,/,3(12x,3(f12.7,1x)/))') '<< CRYST integrateStress >> Cauchy / MPa', & - matmul(crystallite_P(1:3,1:3,ipc,ip,el), transpose(Fg_new)) * 1.0e-6_pReal / math_det33(Fg_new) - write(6,'(a,/,3(12x,3(f12.7,1x)/))') '<< CRYST integrateStress >> Fe Lp Fe^-1', & - transpose(matmul(Fe_new, matmul(crystallite_Lp(1:3,1:3,ipc,ip,el), math_inv33(Fe_new)))) - write(6,'(a,/,3(12x,3(f12.7,1x)/))') '<< CRYST integrateStress >> Fp',transpose(crystallite_Fp(1:3,1:3,ipc,ip,el)) - write(6,'(a,/,3(12x,3(f12.7,1x)/))') '<< CRYST integrateStress >> Fi',transpose(crystallite_Fi(1:3,1:3,ipc,ip,el)) - endif + if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0 & + .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0)) then + write(6,'(a,/)') '<< CRYST integrateStress >> successful integration' + write(6,'(a,/,3(12x,3(f12.7,1x)/))') '<< CRYST integrateStress >> P / MPa', & + transpose(crystallite_P(1:3,1:3,ipc,ip,el))*1.0e-6_pReal + write(6,'(a,/,3(12x,3(f12.7,1x)/))') '<< CRYST integrateStress >> Cauchy / MPa', & + matmul(crystallite_P(1:3,1:3,ipc,ip,el), transpose(Fg_new)) * 1.0e-6_pReal / math_det33(Fg_new) + write(6,'(a,/,3(12x,3(f12.7,1x)/))') '<< CRYST integrateStress >> Fe Lp Fe^-1', & + transpose(matmul(Fe_new, matmul(crystallite_Lp(1:3,1:3,ipc,ip,el), math_inv33(Fe_new)))) + write(6,'(a,/,3(12x,3(f12.7,1x)/))') '<< CRYST integrateStress >> Fp',transpose(crystallite_Fp(1:3,1:3,ipc,ip,el)) + write(6,'(a,/,3(12x,3(f12.7,1x)/))') '<< CRYST integrateStress >> Fi',transpose(crystallite_Fi(1:3,1:3,ipc,ip,el)) + endif #endif end function integrateStress From 3887d5631a88f6a37e5cabb06bc5cf94e83352f7 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 3 Apr 2019 13:04:03 +0200 Subject: [PATCH 36/47] handling of PGI compiler was to cumbersome --- src/math.f90 | 18 ---------------- src/mesh_grid.f90 | 3 --- src/quaternions.f90 | 12 ----------- src/rotations.f90 | 52 ++++++++++++++++++--------------------------- 4 files changed, 21 insertions(+), 64 deletions(-) diff --git a/src/math.f90 b/src/math.f90 index 5ee50cbfc..5e6f17a87 100644 --- a/src/math.f90 +++ b/src/math.f90 @@ -81,9 +81,6 @@ module math public :: & -#if defined(__PGI) - norm2, & -#endif math_init, & math_qsort, & math_expand, & @@ -2647,19 +2644,4 @@ real(pReal) pure elemental function math_clip(a, left, right) end function math_clip - -#if defined(__PGI) -!-------------------------------------------------------------------------------------------------- -!> @brief substitute for the norm2 intrinsic which is not available in PGI 18.10 -!-------------------------------------------------------------------------------------------------- -real(pReal) pure function norm2(v) - - implicit none - real(pReal), intent(in), dimension(3) :: v - - norm2 = sqrt(sum(v**2)) - -end function norm2 -#endif - end module math diff --git a/src/mesh_grid.f90 b/src/mesh_grid.f90 index 95d8e5b27..7274582a2 100644 --- a/src/mesh_grid.f90 +++ b/src/mesh_grid.f90 @@ -900,9 +900,6 @@ end function mesh_cellCenterCoordinates !-------------------------------------------------------------------------------------------------- subroutine mesh_build_ipAreas use math, only: & -#ifdef __PGI - norm2, & -#endif math_crossproduct implicit none diff --git a/src/quaternions.f90 b/src/quaternions.f90 index 5fc35352c..39dc1d3cd 100644 --- a/src/quaternions.f90 +++ b/src/quaternions.f90 @@ -354,10 +354,6 @@ end function pow_quat__ !> ToDo: Lacks any check for invalid operations !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function exp__(self) -#ifdef __PGI - use math, only: & - norm2 -#endif implicit none class(quaternion), intent(in) :: self @@ -378,10 +374,6 @@ end function exp__ !> ToDo: Lacks any check for invalid operations !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function log__(self) -#ifdef __PGI - use math, only: & - norm2 -#endif implicit none class(quaternion), intent(in) :: self @@ -401,10 +393,6 @@ end function log__ !> norm of a quaternion !--------------------------------------------------------------------------------------------------- real(pReal) elemental function abs__(a) -#ifdef __PGI - use math, only: & - norm2 -#endif implicit none class(quaternion), intent(in) :: a diff --git a/src/rotations.f90 b/src/rotations.f90 index 470d82efa..25add25af 100644 --- a/src/rotations.f90 +++ b/src/rotations.f90 @@ -157,10 +157,6 @@ end subroutine function rotVector(self,v,active) use prec, only: & dEq -#ifdef __PGI - use math, only: & - norm2 -#endif implicit none real(pReal), dimension(3) :: rotVector @@ -168,21 +164,28 @@ function rotVector(self,v,active) real(pReal), intent(in), dimension(3) :: v logical, intent(in), optional :: active - type(quaternion) :: q - + type(quaternion) :: q + logical :: passive + + if (present(active)) then + passive = .not. active + else + passive = .true. + endif + if (dEq(norm2(v),1.0_pReal,tol=1.0e-15_pReal)) then - passive: if (merge(.not. active, .true., present(active))) then ! ToDo: not save (PGI) + if (passive) then q = self%q * (quaternion([0.0_pReal, v(1), v(2), v(3)]) * conjg(self%q) ) - else passive + else q = conjg(self%q) * (quaternion([0.0_pReal, v(1), v(2), v(3)]) * self%q ) - endif passive + endif rotVector = [q%x,q%y,q%z] else - passive2: if (merge(.not. active, .true., present(active))) then ! ToDo: not save (PGI) + if (passive) then rotVector = matmul(self%asRotationMatrix(),v) - else passive2 + else rotVector = matmul(transpose(self%asRotationMatrix()),v) - endif passive2 + endif endif end function rotVector @@ -573,9 +576,6 @@ pure function ro2ax(ro) result(ax) use prec, only: & dEq0 use math, only: & -#ifdef __PGI - norm2, & -#endif PI implicit none @@ -665,9 +665,6 @@ pure function ro2ho(ro) result(ho) use prec, only: & dEq0 use math, only: & -#ifdef __PGI - norm2, & -#endif PI implicit none @@ -724,10 +721,6 @@ end function qu2om function om2qu(om) result(qu) use prec, only: & dEq -#ifdef __PGI - use math, only: & - norm2 -#endif implicit none real(pReal), intent(in), dimension(3,3) :: om @@ -801,9 +794,6 @@ pure function qu2ro(qu) result(ro) use prec, only: & dEq0 use math, only: & -#ifdef __PGI - norm2, & -#endif math_clip type(quaternion), intent(in) :: qu @@ -816,9 +806,12 @@ pure function qu2ro(qu) result(ro) ro = [qu%x, qu%y, qu%z, IEEE_value(ro(4),IEEE_positive_inf)] else s = norm2([qu%x,qu%y,qu%z]) - ro = merge ( [ 0.0_pReal, 0.0_pReal, P, 0.0_pReal], & - [ qu%x/s, qu%y/s, qu%z/s, tan(acos(math_clip(qu%w,-1.0_pReal,1.0_pReal)))], & - s < thr) !ToDo: not save (PGI compiler) + if (s < thr) then + ro = [ 0.0_pReal, 0.0_pReal, P, 0.0_pReal] + else + ro = [ qu%x/s, qu%y/s, qu%z/s, tan(acos(math_clip(qu%w,-1.0_pReal,1.0_pReal)))] + endif + end if end function qu2ro @@ -832,9 +825,6 @@ pure function qu2ho(qu) result(ho) use prec, only: & dEq0 use math, only: & -#ifdef __PGI - norm2, & -#endif math_clip implicit none From 4724e42b7fc8dda38da2b8618f99cd89297afd30 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 3 Apr 2019 13:11:18 +0200 Subject: [PATCH 37/47] fixed indentation --- src/rotations.f90 | 1223 +++++++++++++++++++++++---------------------- 1 file changed, 615 insertions(+), 608 deletions(-) diff --git a/src/rotations.f90 b/src/rotations.f90 index 25add25af..b899adacb 100644 --- a/src/rotations.f90 +++ b/src/rotations.f90 @@ -46,27 +46,27 @@ !--------------------------------------------------------------------------------------------------- module rotations - use prec, only: & - pReal - use quaternions - - implicit none - private - type, public :: rotation - type(quaternion), private :: q - contains - procedure, public :: asQuaternion - procedure, public :: asEulerAngles - procedure, public :: asAxisAnglePair - procedure, public :: asRodriguesFrankVector - procedure, public :: asRotationMatrix - !------------------------------------------ - procedure, public :: fromRotationMatrix - !------------------------------------------ - procedure, public :: rotVector - procedure, public :: rotTensor - procedure, public :: misorientation - end type rotation + use prec, only: & + pReal + use quaternions + + implicit none + private + type, public :: rotation + type(quaternion), private :: q + contains + procedure, public :: asQuaternion + procedure, public :: asEulerAngles + procedure, public :: asAxisAnglePair + procedure, public :: asRodriguesFrankVector + procedure, public :: asRotationMatrix + !------------------------------------------ + procedure, public :: fromRotationMatrix + !------------------------------------------ + procedure, public :: rotVector + procedure, public :: rotTensor + procedure, public :: misorientation + end type rotation contains @@ -77,61 +77,61 @@ contains !--------------------------------------------------------------------------------------------------- function asQuaternion(self) - implicit none - class(rotation), intent(in) :: self - real(pReal), dimension(4) :: asQuaternion - - asQuaternion = [self%q%w, self%q%x, self%q%y, self%q%z] + implicit none + class(rotation), intent(in) :: self + real(pReal), dimension(4) :: asQuaternion + + asQuaternion = [self%q%w, self%q%x, self%q%y, self%q%z] end function asQuaternion !--------------------------------------------------------------------------------------------------- function asEulerAngles(self) - implicit none - class(rotation), intent(in) :: self - real(pReal), dimension(3) :: asEulerAngles - - asEulerAngles = qu2eu(self%q) + implicit none + class(rotation), intent(in) :: self + real(pReal), dimension(3) :: asEulerAngles + + asEulerAngles = qu2eu(self%q) end function asEulerAngles !--------------------------------------------------------------------------------------------------- function asAxisAnglePair(self) - implicit none - class(rotation), intent(in) :: self - real(pReal), dimension(4) :: asAxisAnglePair - - asAxisAnglePair = qu2ax(self%q) + implicit none + class(rotation), intent(in) :: self + real(pReal), dimension(4) :: asAxisAnglePair + + asAxisAnglePair = qu2ax(self%q) end function asAxisAnglePair !--------------------------------------------------------------------------------------------------- function asRotationMatrix(self) - implicit none - class(rotation), intent(in) :: self - real(pReal), dimension(3,3) :: asRotationMatrix - - asRotationMatrix = qu2om(self%q) + implicit none + class(rotation), intent(in) :: self + real(pReal), dimension(3,3) :: asRotationMatrix + + asRotationMatrix = qu2om(self%q) end function asRotationMatrix !--------------------------------------------------------------------------------------------------- function asRodriguesFrankVector(self) - implicit none - class(rotation), intent(in) :: self - real(pReal), dimension(4) :: asRodriguesFrankVector - - asRodriguesFrankVector = qu2ro(self%q) + implicit none + class(rotation), intent(in) :: self + real(pReal), dimension(4) :: asRodriguesFrankVector + + asRodriguesFrankVector = qu2ro(self%q) end function asRodriguesFrankVector !--------------------------------------------------------------------------------------------------- function asHomochoric(self) - implicit none - class(rotation), intent(in) :: self - real(pReal), dimension(3) :: asHomochoric - - asHomochoric = qu2ho(self%q) + implicit none + class(rotation), intent(in) :: self + real(pReal), dimension(3) :: asHomochoric + + asHomochoric = qu2ho(self%q) end function asHomochoric @@ -140,11 +140,11 @@ end function asHomochoric !--------------------------------------------------------------------------------------------------- subroutine fromRotationMatrix(self,om) - implicit none - class(rotation), intent(out) :: self - real(pReal), dimension(3,3), intent(in) :: om - - self%q = om2qu(om) + implicit none + class(rotation), intent(out) :: self + real(pReal), dimension(3,3), intent(in) :: om + + self%q = om2qu(om) end subroutine @@ -155,38 +155,38 @@ end subroutine !> @details: rotation is based on unit quaternion or rotation matrix (fallback) !--------------------------------------------------------------------------------------------------- function rotVector(self,v,active) - use prec, only: & - dEq - - implicit none - real(pReal), dimension(3) :: rotVector - class(rotation), intent(in) :: self - real(pReal), intent(in), dimension(3) :: v - logical, intent(in), optional :: active + use prec, only: & + dEq + + implicit none + real(pReal), dimension(3) :: rotVector + class(rotation), intent(in) :: self + real(pReal), intent(in), dimension(3) :: v + logical, intent(in), optional :: active + + type(quaternion) :: q + logical :: passive - type(quaternion) :: q - logical :: passive - - if (present(active)) then - passive = .not. active - else - passive = .true. - endif - - if (dEq(norm2(v),1.0_pReal,tol=1.0e-15_pReal)) then - if (passive) then - q = self%q * (quaternion([0.0_pReal, v(1), v(2), v(3)]) * conjg(self%q) ) - else - q = conjg(self%q) * (quaternion([0.0_pReal, v(1), v(2), v(3)]) * self%q ) - endif - rotVector = [q%x,q%y,q%z] - else - if (passive) then - rotVector = matmul(self%asRotationMatrix(),v) - else - rotVector = matmul(transpose(self%asRotationMatrix()),v) - endif - endif + if (present(active)) then + passive = .not. active + else + passive = .true. + endif + + if (dEq(norm2(v),1.0_pReal,tol=1.0e-15_pReal)) then + if (passive) then + q = self%q * (quaternion([0.0_pReal, v(1), v(2), v(3)]) * conjg(self%q) ) + else + q = conjg(self%q) * (quaternion([0.0_pReal, v(1), v(2), v(3)]) * self%q ) + endif + rotVector = [q%x,q%y,q%z] + else + if (passive) then + rotVector = matmul(self%asRotationMatrix(),v) + else + rotVector = matmul(transpose(self%asRotationMatrix()),v) + endif + endif end function rotVector @@ -198,18 +198,25 @@ end function rotVector !--------------------------------------------------------------------------------------------------- function rotTensor(self,m,active) - implicit none - real(pReal), dimension(3,3) :: rotTensor - class(rotation), intent(in) :: self - real(pReal), intent(in), dimension(3,3) :: m - logical, intent(in), optional :: active - + implicit none + real(pReal), dimension(3,3) :: rotTensor + class(rotation), intent(in) :: self + real(pReal), intent(in), dimension(3,3) :: m + logical, intent(in), optional :: active + + logical :: passive - passive: if (merge(.not. active, .true., present(active))) then - rotTensor = matmul(matmul(self%asRotationMatrix(),m),transpose(self%asRotationMatrix())) - else passive - rotTensor = matmul(matmul(transpose(self%asRotationMatrix()),m),self%asRotationMatrix()) - endif passive + if (present(active)) then + passive = .not. active + else + passive = .true. + endif + + if (passive) then + rotTensor = matmul(matmul(self%asRotationMatrix(),m),transpose(self%asRotationMatrix())) + else + rotTensor = matmul(matmul(transpose(self%asRotationMatrix()),m),self%asRotationMatrix()) + endif end function rotTensor @@ -219,11 +226,11 @@ end function rotTensor !--------------------------------------------------------------------------------------------------- function misorientation(self,other) - implicit none - type(rotation) :: misorientation - class(rotation), intent(in) :: self, other - - misorientation%q = conjg(self%q) * other%q !ToDo: this is the convention used in math + implicit none + type(rotation) :: misorientation + class(rotation), intent(in) :: self, other + + misorientation%q = conjg(self%q) * other%q !ToDo: this is the convention used in math end function misorientation @@ -238,29 +245,29 @@ end function misorientation !> @brief Euler angles to orientation matrix !--------------------------------------------------------------------------------------------------- pure function eu2om(eu) result(om) - use prec, only: & - dEq0 + use prec, only: & + dEq0 + + implicit none + real(pReal), intent(in), dimension(3) :: eu + real(pReal), dimension(3,3) :: om + + real(pReal), dimension(3) :: c, s - implicit none - real(pReal), intent(in), dimension(3) :: eu - real(pReal), dimension(3,3) :: om + c = cos(eu) + s = sin(eu) - real(pReal), dimension(3) :: c, s - - c = cos(eu) - s = sin(eu) - - om(1,1) = c(1)*c(3)-s(1)*s(3)*c(2) - om(1,2) = s(1)*c(3)+c(1)*s(3)*c(2) - om(1,3) = s(3)*s(2) - om(2,1) = -c(1)*s(3)-s(1)*c(3)*c(2) - om(2,2) = -s(1)*s(3)+c(1)*c(3)*c(2) - om(2,3) = c(3)*s(2) - om(3,1) = s(1)*s(2) - om(3,2) = -c(1)*s(2) - om(3,3) = c(2) - - where(dEq0(om)) om = 0.0_pReal + om(1,1) = c(1)*c(3)-s(1)*s(3)*c(2) + om(1,2) = s(1)*c(3)+c(1)*s(3)*c(2) + om(1,3) = s(3)*s(2) + om(2,1) = -c(1)*s(3)-s(1)*c(3)*c(2) + om(2,2) = -s(1)*s(3)+c(1)*c(3)*c(2) + om(2,3) = c(3)*s(2) + om(3,1) = s(1)*s(2) + om(3,2) = -c(1)*s(2) + om(3,3) = c(2) + + where(dEq0(om)) om = 0.0_pReal end function eu2om @@ -270,32 +277,32 @@ end function eu2om !> @brief convert euler to axis angle !--------------------------------------------------------------------------------------------------- pure function eu2ax(eu) result(ax) - use prec, only: & - dEq0, & - dEq - use math, only: & - PI - - implicit none - real(pReal), intent(in), dimension(3) :: eu - real(pReal), dimension(4) :: ax + use prec, only: & + dEq0, & + dEq + use math, only: & + PI - real(pReal) :: t, delta, tau, alpha, sigma - - t = tan(eu(2)*0.5) - sigma = 0.5*(eu(1)+eu(3)) - delta = 0.5*(eu(1)-eu(3)) - tau = sqrt(t**2+sin(sigma)**2) - - alpha = merge(PI, 2.0*atan(tau/cos(sigma)), dEq(sigma,PI*0.5_pReal,tol=1.0e-15_pReal)) - - if (dEq0(alpha)) then ! return a default identity axis-angle pair - ax = [ 0.0_pReal, 0.0_pReal, 1.0_pReal, 0.0_pReal ] - else - ax(1:3) = -P/tau * [ t*cos(delta), t*sin(delta), sin(sigma) ] ! passive axis-angle pair so a minus sign in front - ax(4) = alpha - if (alpha < 0.0) ax = -ax ! ensure alpha is positive - end if + implicit none + real(pReal), intent(in), dimension(3) :: eu + real(pReal), dimension(4) :: ax + + real(pReal) :: t, delta, tau, alpha, sigma + + t = tan(eu(2)*0.5) + sigma = 0.5*(eu(1)+eu(3)) + delta = 0.5*(eu(1)-eu(3)) + tau = sqrt(t**2+sin(sigma)**2) + + alpha = merge(PI, 2.0*atan(tau/cos(sigma)), dEq(sigma,PI*0.5_pReal,tol=1.0e-15_pReal)) + + if (dEq0(alpha)) then ! return a default identity axis-angle pair + ax = [ 0.0_pReal, 0.0_pReal, 1.0_pReal, 0.0_pReal ] + else + ax(1:3) = -P/tau * [ t*cos(delta), t*sin(delta), sin(sigma) ] ! passive axis-angle pair so a minus sign in front + ax(4) = alpha + if (alpha < 0.0) ax = -ax ! ensure alpha is positive + end if end function eu2ax @@ -305,26 +312,26 @@ end function eu2ax !> @brief Euler angles to Rodrigues vector !--------------------------------------------------------------------------------------------------- pure function eu2ro(eu) result(ro) - use prec, only: & - dEq0 - use, intrinsic :: IEEE_ARITHMETIC, only: & - IEEE_value, & - IEEE_positive_inf - use math, only: & - PI + use prec, only: & + dEq0 + use, intrinsic :: IEEE_ARITHMETIC, only: & + IEEE_value, & + IEEE_positive_inf + use math, only: & + PI - implicit none - real(pReal), intent(in), dimension(3) :: eu - real(pReal), dimension(4) :: ro - - ro = eu2ax(eu) - if (ro(4) >= PI) then - ro(4) = IEEE_value(ro(4),IEEE_positive_inf) - elseif(dEq0(ro(4))) then - ro = [ 0.0_pReal, 0.0_pReal, P, 0.0_pReal ] - else - ro(4) = tan(ro(4)*0.5) - end if + implicit none + real(pReal), intent(in), dimension(3) :: eu + real(pReal), dimension(4) :: ro + + ro = eu2ax(eu) + if (ro(4) >= PI) then + ro(4) = IEEE_value(ro(4),IEEE_positive_inf) + elseif(dEq0(ro(4))) then + ro = [ 0.0_pReal, 0.0_pReal, P, 0.0_pReal ] + else + ro(4) = tan(ro(4)*0.5) + end if end function eu2ro @@ -335,22 +342,22 @@ end function eu2ro !--------------------------------------------------------------------------------------------------- pure function eu2qu(eu) result(qu) - implicit none - real(pReal), intent(in), dimension(3) :: eu - type(quaternion) :: qu - real(pReal), dimension(3) :: ee - real(pReal) :: cPhi, sPhi + implicit none + real(pReal), intent(in), dimension(3) :: eu + type(quaternion) :: qu + real(pReal), dimension(3) :: ee + real(pReal) :: cPhi, sPhi - ee = 0.5_pReal*eu - - cPhi = cos(ee(2)) - sPhi = sin(ee(2)) + ee = 0.5_pReal*eu + + cPhi = cos(ee(2)) + sPhi = sin(ee(2)) - qu = quaternion([ cPhi*cos(ee(1)+ee(3)), & - -P*sPhi*cos(ee(1)-ee(3)), & - -P*sPhi*sin(ee(1)-ee(3)), & - -P*cPhi*sin(ee(1)+ee(3))]) - if(qu%w < 0.0_pReal) qu = qu%homomorphed() + qu = quaternion([ cPhi*cos(ee(1)+ee(3)), & + -P*sPhi*cos(ee(1)-ee(3)), & + -P*sPhi*sin(ee(1)-ee(3)), & + -P*cPhi*sin(ee(1)+ee(3))]) + if(qu%w < 0.0_pReal) qu = qu%homomorphed() end function eu2qu @@ -360,23 +367,23 @@ end function eu2qu !> @brief orientation matrix to Euler angles !--------------------------------------------------------------------------------------------------- pure function om2eu(om) result(eu) - use math, only: & - PI + use math, only: & + PI - implicit none - real(pReal), intent(in), dimension(3,3) :: om - real(pReal), dimension(3) :: eu - real(pReal) :: zeta - - if (abs(om(3,3))>1.0_pReal) then - eu = [ atan2( om(1,2),om(1,1)), 0.5*PI*(1-om(3,3)),0.0_pReal ] - else - zeta = 1.0_pReal/sqrt(1.0_pReal-om(3,3)**2.0_pReal) - eu = [atan2(om(3,1)*zeta,-om(3,2)*zeta), & - acos(om(3,3)), & - atan2(om(1,3)*zeta, om(2,3)*zeta)] - end if - where(eu<0.0_pReal) eu = mod(eu+2.0_pReal*PI,[2.0_pReal*PI,PI,2.0_pReal*PI]) + implicit none + real(pReal), intent(in), dimension(3,3) :: om + real(pReal), dimension(3) :: eu + real(pReal) :: zeta + + if (abs(om(3,3))>1.0_pReal) then + eu = [ atan2( om(1,2),om(1,1)), 0.5*PI*(1-om(3,3)),0.0_pReal ] + else + zeta = 1.0_pReal/sqrt(1.0_pReal-om(3,3)**2.0_pReal) + eu = [atan2(om(3,1)*zeta,-om(3,2)*zeta), & + acos(om(3,3)), & + atan2(om(1,3)*zeta, om(2,3)*zeta)] + end if + where(eu<0.0_pReal) eu = mod(eu+2.0_pReal*PI,[2.0_pReal*PI,PI,2.0_pReal*PI]) end function om2eu @@ -387,32 +394,32 @@ end function om2eu !--------------------------------------------------------------------------------------------------- pure function ax2om(ax) result(om) - implicit none - real(pReal), intent(in), dimension(4) :: ax - real(pReal), dimension(3,3) :: om - - real(pReal) :: q, c, s, omc - integer :: i + implicit none + real(pReal), intent(in), dimension(4) :: ax + real(pReal), dimension(3,3) :: om + + real(pReal) :: q, c, s, omc + integer :: i - c = cos(ax(4)) - s = sin(ax(4)) - omc = 1.0-c + c = cos(ax(4)) + s = sin(ax(4)) + omc = 1.0-c - forall(i=1:3) om(i,i) = ax(i)**2*omc + c + forall(i=1:3) om(i,i) = ax(i)**2*omc + c - q = omc*ax(1)*ax(2) - om(1,2) = q + s*ax(3) - om(2,1) = q - s*ax(3) - - q = omc*ax(2)*ax(3) - om(2,3) = q + s*ax(1) - om(3,2) = q - s*ax(1) - - q = omc*ax(3)*ax(1) - om(3,1) = q + s*ax(2) - om(1,3) = q - s*ax(2) + q = omc*ax(1)*ax(2) + om(1,2) = q + s*ax(3) + om(2,1) = q - s*ax(3) + + q = omc*ax(2)*ax(3) + om(2,3) = q + s*ax(1) + om(3,2) = q - s*ax(1) + + q = omc*ax(3)*ax(1) + om(3,1) = q + s*ax(2) + om(1,3) = q - s*ax(2) - if (P > 0.0) om = transpose(om) + if (P > 0.0) om = transpose(om) end function ax2om @@ -422,32 +429,32 @@ end function ax2om !> @brief convert unit quaternion to Euler angles !--------------------------------------------------------------------------------------------------- pure function qu2eu(qu) result(eu) - use prec, only: & - dEq0 - use math, only: & - PI + use prec, only: & + dEq0 + use math, only: & + PI - implicit none - type(quaternion), intent(in) :: qu - real(pReal), dimension(3) :: eu - - real(pReal) :: q12, q03, chi, chiInv - - q03 = qu%w**2+qu%z**2 - q12 = qu%x**2+qu%y**2 - chi = sqrt(q03*q12) - - degenerated: if (dEq0(chi)) then - eu = merge([atan2(-P*2.0*qu%w*qu%z,qu%w**2-qu%z**2), 0.0_pReal, 0.0_pReal], & - [atan2(2.0*qu%x*qu%y,qu%x**2-qu%y**2), PI, 0.0_pReal], & - dEq0(q12)) - else degenerated - chiInv = 1.0/chi - eu = [atan2((-P*qu%w*qu%y+qu%x*qu%z)*chi, (-P*qu%w*qu%x-qu%y*qu%z)*chi ), & - atan2( 2.0*chi, q03-q12 ), & - atan2(( P*qu%w*qu%y+qu%x*qu%z)*chi, (-P*qu%w*qu%x+qu%y*qu%z)*chi )] - endif degenerated - where(eu<0.0_pReal) eu = mod(eu+2.0_pReal*PI,[2.0_pReal*PI,PI,2.0_pReal*PI]) + implicit none + type(quaternion), intent(in) :: qu + real(pReal), dimension(3) :: eu + + real(pReal) :: q12, q03, chi, chiInv + + q03 = qu%w**2+qu%z**2 + q12 = qu%x**2+qu%y**2 + chi = sqrt(q03*q12) + + degenerated: if (dEq0(chi)) then + eu = merge([atan2(-P*2.0*qu%w*qu%z,qu%w**2-qu%z**2), 0.0_pReal, 0.0_pReal], & + [atan2(2.0*qu%x*qu%y,qu%x**2-qu%y**2), PI, 0.0_pReal], & + dEq0(q12)) + else degenerated + chiInv = 1.0/chi + eu = [atan2((-P*qu%w*qu%y+qu%x*qu%z)*chi, (-P*qu%w*qu%x-qu%y*qu%z)*chi ), & + atan2( 2.0*chi, q03-q12 ), & + atan2(( P*qu%w*qu%y+qu%x*qu%z)*chi, (-P*qu%w*qu%x+qu%y*qu%z)*chi )] + endif degenerated + where(eu<0.0_pReal) eu = mod(eu+2.0_pReal*PI,[2.0_pReal*PI,PI,2.0_pReal*PI]) end function qu2eu @@ -458,15 +465,15 @@ end function qu2eu !--------------------------------------------------------------------------------------------------- pure function ax2ho(ax) result(ho) - implicit none - real(pReal), intent(in), dimension(4) :: ax - real(pReal), dimension(3) :: ho - - real(pReal) :: f - - f = 0.75 * ( ax(4) - sin(ax(4)) ) - f = f**(1.0/3.0) - ho = ax(1:3) * f + implicit none + real(pReal), intent(in), dimension(4) :: ax + real(pReal), dimension(3) :: ho + + real(pReal) :: f + + f = 0.75 * ( ax(4) - sin(ax(4)) ) + f = f**(1.0/3.0) + ho = ax(1:3) * f end function ax2ho @@ -476,39 +483,40 @@ end function ax2ho !> @brief convert homochoric to axis angle pair !--------------------------------------------------------------------------------------------------- pure function ho2ax(ho) result(ax) - use prec, only: & - dEq0 - implicit none - real(pReal), intent(in), dimension(3) :: ho - real(pReal), dimension(4) :: ax - - integer :: i - real(pReal) :: hmag_squared, s, hm - real(pReal), parameter, dimension(16) :: & - tfit = [ 1.0000000000018852_pReal, -0.5000000002194847_pReal, & - -0.024999992127593126_pReal, -0.003928701544781374_pReal, & - -0.0008152701535450438_pReal, -0.0002009500426119712_pReal, & - -0.00002397986776071756_pReal, -0.00008202868926605841_pReal, & - +0.00012448715042090092_pReal, -0.0001749114214822577_pReal, & - +0.0001703481934140054_pReal, -0.00012062065004116828_pReal, & - +0.000059719705868660826_pReal, -0.00001980756723965647_pReal, & - +0.000003953714684212874_pReal, -0.00000036555001439719544_pReal ] - - ! normalize h and store the magnitude - hmag_squared = sum(ho**2.0_pReal) - if (dEq0(hmag_squared)) then - ax = [ 0.0_pReal, 0.0_pReal, 1.0_pReal, 0.0_pReal ] - else - hm = hmag_squared - - ! convert the magnitude to the rotation angle - s = tfit(1) + tfit(2) * hmag_squared - do i=3,16 - hm = hm*hmag_squared - s = s + tfit(i) * hm - end do - ax = [ho/sqrt(hmag_squared), 2.0_pReal*acos(s)] - end if + use prec, only: & + dEq0 + + implicit none + real(pReal), intent(in), dimension(3) :: ho + real(pReal), dimension(4) :: ax + + integer :: i + real(pReal) :: hmag_squared, s, hm + real(pReal), parameter, dimension(16) :: & + tfit = [ 1.0000000000018852_pReal, -0.5000000002194847_pReal, & + -0.024999992127593126_pReal, -0.003928701544781374_pReal, & + -0.0008152701535450438_pReal, -0.0002009500426119712_pReal, & + -0.00002397986776071756_pReal, -0.00008202868926605841_pReal, & + +0.00012448715042090092_pReal, -0.0001749114214822577_pReal, & + +0.0001703481934140054_pReal, -0.00012062065004116828_pReal, & + +0.000059719705868660826_pReal, -0.00001980756723965647_pReal, & + +0.000003953714684212874_pReal, -0.00000036555001439719544_pReal ] + + ! normalize h and store the magnitude + hmag_squared = sum(ho**2.0_pReal) + if (dEq0(hmag_squared)) then + ax = [ 0.0_pReal, 0.0_pReal, 1.0_pReal, 0.0_pReal ] + else + hm = hmag_squared + + ! convert the magnitude to the rotation angle + s = tfit(1) + tfit(2) * hmag_squared + do i=3,16 + hm = hm*hmag_squared + s = s + tfit(i) * hm + end do + ax = [ho/sqrt(hmag_squared), 2.0_pReal*acos(s)] + end if end function ho2ax @@ -518,50 +526,50 @@ end function ho2ax !> @brief convert orientation matrix to axis angle pair !--------------------------------------------------------------------------------------------------- function om2ax(om) result(ax) - use prec, only: & - dEq0, & - cEq, & - dNeq0 - use IO, only: & - IO_error - use math, only: & - math_clip, & - math_trace33 + use prec, only: & + dEq0, & + cEq, & + dNeq0 + use IO, only: & + IO_error + use math, only: & + math_clip, & + math_trace33 - implicit none - real(pReal), intent(in) :: om(3,3) - real(pReal) :: ax(4) - - real(pReal) :: t - real(pReal), dimension(3) :: Wr, Wi - real(pReal), dimension(10) :: WORK - real(pReal), dimension(3,3) :: VR, devNull, o - integer :: INFO, LWORK, i - - external :: dgeev,sgeev - - o = om - - ! first get the rotation angle - t = 0.5_pReal * (math_trace33(om) - 1.0) - ax(4) = acos(math_clip(t,-1.0_pReal,1.0_pReal)) - - if (dEq0(ax(4))) then - ax(1:3) = [ 0.0, 0.0, 1.0 ] - else - ! set some initial LAPACK variables - INFO = 0 - ! first initialize the parameters for the LAPACK DGEEV routines - LWORK = 20 - - ! call the eigenvalue solver - call dgeev('N','V',3,o,3,Wr,Wi,devNull,3,VR,3,WORK,LWORK,INFO) - if (INFO /= 0) call IO_error(0,ext_msg='Error in om2ax DGEEV return not zero') - i = maxloc(merge(1.0_pReal,0.0_pReal,cEq(cmplx(Wr,Wi,pReal),cmplx(1.0_pReal,0.0_pReal,pReal),tol=1.0e-14_pReal)),dim=1) ! poor substitute for findloc - ax(1:3) = VR(1:3,i) - where ( dNeq0([om(2,3)-om(3,2), om(3,1)-om(1,3), om(1,2)-om(2,1)])) & - ax(1:3) = sign(ax(1:3),-P *[om(2,3)-om(3,2), om(3,1)-om(1,3), om(1,2)-om(2,1)]) - endif + implicit none + real(pReal), intent(in) :: om(3,3) + real(pReal) :: ax(4) + + real(pReal) :: t + real(pReal), dimension(3) :: Wr, Wi + real(pReal), dimension(10) :: WORK + real(pReal), dimension(3,3) :: VR, devNull, o + integer :: INFO, LWORK, i + + external :: dgeev,sgeev + + o = om + + ! first get the rotation angle + t = 0.5_pReal * (math_trace33(om) - 1.0) + ax(4) = acos(math_clip(t,-1.0_pReal,1.0_pReal)) + + if (dEq0(ax(4))) then + ax(1:3) = [ 0.0, 0.0, 1.0 ] + else + ! set some initial LAPACK variables + INFO = 0 + ! first initialize the parameters for the LAPACK DGEEV routines + LWORK = 20 + + ! call the eigenvalue solver + call dgeev('N','V',3,o,3,Wr,Wi,devNull,3,VR,3,WORK,LWORK,INFO) + if (INFO /= 0) call IO_error(0,ext_msg='Error in om2ax DGEEV return not zero') + i = maxloc(merge(1.0_pReal,0.0_pReal,cEq(cmplx(Wr,Wi,pReal),cmplx(1.0_pReal,0.0_pReal,pReal),tol=1.0e-14_pReal)),dim=1) ! poor substitute for findloc + ax(1:3) = VR(1:3,i) + where ( dNeq0([om(2,3)-om(3,2), om(3,1)-om(1,3), om(1,2)-om(2,1)])) & + ax(1:3) = sign(ax(1:3),-P *[om(2,3)-om(3,2), om(3,1)-om(1,3), om(1,2)-om(2,1)]) + endif end function om2ax @@ -571,30 +579,30 @@ end function om2ax !> @brief convert Rodrigues vector to axis angle pair !--------------------------------------------------------------------------------------------------- pure function ro2ax(ro) result(ax) - use, intrinsic :: IEEE_ARITHMETIC, only: & - IEEE_is_finite - use prec, only: & - dEq0 - use math, only: & - PI + use, intrinsic :: IEEE_ARITHMETIC, only: & + IEEE_is_finite + use prec, only: & + dEq0 + use math, only: & + PI - implicit none - real(pReal), intent(in), dimension(4) :: ro - real(pReal), dimension(4) :: ax - - real(pReal) :: ta, angle - - ta = ro(4) - - if (dEq0(ta)) then - ax = [ 0.0, 0.0, 1.0, 0.0 ] - elseif (.not. IEEE_is_finite(ta)) then - ax = [ ro(1), ro(2), ro(3), PI ] - else - angle = 2.0*atan(ta) - ta = 1.0/norm2(ro(1:3)) - ax = [ ro(1)/ta, ro(2)/ta, ro(3)/ta, angle ] - end if + implicit none + real(pReal), intent(in), dimension(4) :: ro + real(pReal), dimension(4) :: ax + + real(pReal) :: ta, angle + + ta = ro(4) + + if (dEq0(ta)) then + ax = [ 0.0, 0.0, 1.0, 0.0 ] + elseif (.not. IEEE_is_finite(ta)) then + ax = [ ro(1), ro(2), ro(3), PI ] + else + angle = 2.0*atan(ta) + ta = 1.0/norm2(ro(1:3)) + ax = [ ro(1)/ta, ro(2)/ta, ro(3)/ta, angle ] + end if end function ro2ax @@ -604,27 +612,27 @@ end function ro2ax !> @brief convert axis angle pair to Rodrigues vector !--------------------------------------------------------------------------------------------------- pure function ax2ro(ax) result(ro) - use, intrinsic :: IEEE_ARITHMETIC, only: & - IEEE_value, & - IEEE_positive_inf - use prec, only: & - dEq0 - use math, only: & - PI + use, intrinsic :: IEEE_ARITHMETIC, only: & + IEEE_value, & + IEEE_positive_inf + use prec, only: & + dEq0 + use math, only: & + PI - implicit none - real(pReal), intent(in), dimension(4) :: ax - real(pReal), dimension(4) :: ro - - real(pReal), parameter :: thr = 1.0E-7 - - if (dEq0(ax(4))) then - ro = [ 0.0_pReal, 0.0_pReal, P, 0.0_pReal ] - else - ro(1:3) = ax(1:3) - ! we need to deal with the 180 degree case - ro(4) = merge(IEEE_value(ro(4),IEEE_positive_inf),tan(ax(4)*0.5 ),abs(ax(4)-PI) < thr) - end if + implicit none + real(pReal), intent(in), dimension(4) :: ax + real(pReal), dimension(4) :: ro + + real(pReal), parameter :: thr = 1.0E-7 + + if (dEq0(ax(4))) then + ro = [ 0.0_pReal, 0.0_pReal, P, 0.0_pReal ] + else + ro(1:3) = ax(1:3) + ! we need to deal with the 180 degree case + ro(4) = merge(IEEE_value(ro(4),IEEE_positive_inf),tan(ax(4)*0.5 ),abs(ax(4)-PI) < thr) + end if end function ax2ro @@ -634,23 +642,23 @@ end function ax2ro !> @brief convert axis angle pair to quaternion !--------------------------------------------------------------------------------------------------- pure function ax2qu(ax) result(qu) - use prec, only: & - dEq0 - - implicit none - real(pReal), intent(in), dimension(4) :: ax - type(quaternion) :: qu - - real(pReal) :: c, s + use prec, only: & + dEq0 + + implicit none + real(pReal), intent(in), dimension(4) :: ax + type(quaternion) :: qu + + real(pReal) :: c, s - if (dEq0(ax(4))) then - qu = quaternion([ 1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal ]) - else - c = cos(ax(4)*0.5) - s = sin(ax(4)*0.5) - qu = quaternion([ c, ax(1)*s, ax(2)*s, ax(3)*s ]) - end if + if (dEq0(ax(4))) then + qu = quaternion([ 1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal ]) + else + c = cos(ax(4)*0.5) + s = sin(ax(4)*0.5) + qu = quaternion([ c, ax(1)*s, ax(2)*s, ax(3)*s ]) + end if end function ax2qu @@ -660,25 +668,25 @@ end function ax2qu !> @brief convert Rodrigues vector to homochoric !--------------------------------------------------------------------------------------------------- pure function ro2ho(ro) result(ho) - use, intrinsic :: IEEE_ARITHMETIC, only: & - IEEE_is_finite - use prec, only: & - dEq0 - use math, only: & - PI + use, intrinsic :: IEEE_ARITHMETIC, only: & + IEEE_is_finite + use prec, only: & + dEq0 + use math, only: & + PI - implicit none - real(pReal), intent(in), dimension(4) :: ro - real(pReal), dimension(3) :: ho - - real(pReal) :: f - - if (dEq0(norm2(ro(1:3)))) then - ho = [ 0.0, 0.0, 0.0 ] - else - f = merge(2.0*atan(ro(4)) - sin(2.0*atan(ro(4))),PI, IEEE_is_finite(ro(4))) - ho = ro(1:3) * (0.75_pReal*f)**(1.0/3.0) - end if + implicit none + real(pReal), intent(in), dimension(4) :: ro + real(pReal), dimension(3) :: ho + + real(pReal) :: f + + if (dEq0(norm2(ro(1:3)))) then + ho = [ 0.0, 0.0, 0.0 ] + else + f = merge(2.0*atan(ro(4)) - sin(2.0*atan(ro(4))),PI, IEEE_is_finite(ro(4))) + ho = ro(1:3) * (0.75_pReal*f)**(1.0/3.0) + end if end function ro2ho @@ -689,27 +697,27 @@ end function ro2ho !--------------------------------------------------------------------------------------------------- pure function qu2om(qu) result(om) - implicit none - type(quaternion), intent(in) :: qu - real(pReal), dimension(3,3) :: om - - real(pReal) :: qq + implicit none + type(quaternion), intent(in) :: qu + real(pReal), dimension(3,3) :: om + + real(pReal) :: qq - qq = qu%w**2-(qu%x**2 + qu%y**2 + qu%z**2) + qq = qu%w**2-(qu%x**2 + qu%y**2 + qu%z**2) - om(1,1) = qq+2.0*qu%x*qu%x - om(2,2) = qq+2.0*qu%y*qu%y - om(3,3) = qq+2.0*qu%z*qu%z + om(1,1) = qq+2.0*qu%x*qu%x + om(2,2) = qq+2.0*qu%y*qu%y + om(3,3) = qq+2.0*qu%z*qu%z - om(1,2) = 2.0*(qu%x*qu%y-qu%w*qu%z) - om(2,3) = 2.0*(qu%y*qu%z-qu%w*qu%x) - om(3,1) = 2.0*(qu%z*qu%x-qu%w*qu%y) - om(2,1) = 2.0*(qu%y*qu%x+qu%w*qu%z) - om(3,2) = 2.0*(qu%z*qu%y+qu%w*qu%x) - om(1,3) = 2.0*(qu%x*qu%z+qu%w*qu%y) + om(1,2) = 2.0*(qu%x*qu%y-qu%w*qu%z) + om(2,3) = 2.0*(qu%y*qu%z-qu%w*qu%x) + om(3,1) = 2.0*(qu%z*qu%x-qu%w*qu%y) + om(2,1) = 2.0*(qu%y*qu%x+qu%w*qu%z) + om(3,2) = 2.0*(qu%z*qu%y+qu%w*qu%x) + om(1,3) = 2.0*(qu%x*qu%z+qu%w*qu%y) - if (P < 0.0) om = transpose(om) + if (P < 0.0) om = transpose(om) end function qu2om @@ -719,34 +727,34 @@ end function qu2om !> @brief convert rotation matrix to a unit quaternion !--------------------------------------------------------------------------------------------------- function om2qu(om) result(qu) - use prec, only: & - dEq + use prec, only: & + dEq - implicit none - real(pReal), intent(in), dimension(3,3) :: om - type(quaternion) :: qu - - real(pReal), dimension(4) :: qu_A - real(pReal), dimension(4) :: s + implicit none + real(pReal), intent(in), dimension(3,3) :: om + type(quaternion) :: qu + + real(pReal), dimension(4) :: qu_A + real(pReal), dimension(4) :: s - s = [+om(1,1) +om(2,2) +om(3,3) +1.0_pReal, & - +om(1,1) -om(2,2) -om(3,3) +1.0_pReal, & - -om(1,1) +om(2,2) -om(3,3) +1.0_pReal, & - -om(1,1) -om(2,2) +om(3,3) +1.0_pReal] + s = [+om(1,1) +om(2,2) +om(3,3) +1.0_pReal, & + +om(1,1) -om(2,2) -om(3,3) +1.0_pReal, & + -om(1,1) +om(2,2) -om(3,3) +1.0_pReal, & + -om(1,1) -om(2,2) +om(3,3) +1.0_pReal] - qu_A = sqrt(max(s,0.0_pReal))*0.5_pReal*[1.0_pReal,P,P,P] - qu_A = qu_A/norm2(qu_A) + qu_A = sqrt(max(s,0.0_pReal))*0.5_pReal*[1.0_pReal,P,P,P] + qu_A = qu_A/norm2(qu_A) - if(any(dEq(abs(qu_A),1.0_pReal,1.0e-15_pReal))) & - where (.not.(dEq(abs(qu_A),1.0_pReal,1.0e-15_pReal))) qu_A = 0.0_pReal + if(any(dEq(abs(qu_A),1.0_pReal,1.0e-15_pReal))) & + where (.not.(dEq(abs(qu_A),1.0_pReal,1.0e-15_pReal))) qu_A = 0.0_pReal - if (om(3,2) < om(2,3)) qu_A(2) = -qu_A(2) - if (om(1,3) < om(3,1)) qu_A(3) = -qu_A(3) - if (om(2,1) < om(1,2)) qu_A(4) = -qu_A(4) - - qu = quaternion(qu_A) - !qu_A = om2ax(om) - !if(any(qu_A(1:3) * [qu%x,qu%y,qu%z] < 0.0)) print*, 'sign error' + if (om(3,2) < om(2,3)) qu_A(2) = -qu_A(2) + if (om(1,3) < om(3,1)) qu_A(3) = -qu_A(3) + if (om(2,1) < om(1,2)) qu_A(4) = -qu_A(4) + + qu = quaternion(qu_A) + !qu_A = om2ax(om) + !if(any(qu_A(1:3) * [qu%x,qu%y,qu%z] < 0.0)) print*, 'sign error' end function om2qu @@ -756,29 +764,29 @@ end function om2qu !> @brief convert unit quaternion to axis angle pair !--------------------------------------------------------------------------------------------------- pure function qu2ax(qu) result(ax) - use prec, only: & - dEq0, & - dNeq0 - use math, only: & - PI, & - math_clip + use prec, only: & + dEq0, & + dNeq0 + use math, only: & + PI, & + math_clip - implicit none - type(quaternion), intent(in) :: qu - real(pReal), dimension(4) :: ax - - real(pReal) :: omega, s + implicit none + type(quaternion), intent(in) :: qu + real(pReal), dimension(4) :: ax + + real(pReal) :: omega, s - omega = 2.0 * acos(math_clip(qu%w,-1.0_pReal,1.0_pReal)) - ! if the angle equals zero, then we return the rotation axis as [001] - if (dEq0(omega)) then - ax = [ 0.0, 0.0, 1.0, 0.0 ] - elseif (dNeq0(qu%w)) then - s = sign(1.0_pReal,qu%w)/sqrt(qu%x**2+qu%y**2+qu%z**2) - ax = [ qu%x*s, qu%y*s, qu%z*s, omega ] - else - ax = [ qu%x, qu%y, qu%z, PI ] - end if + omega = 2.0 * acos(math_clip(qu%w,-1.0_pReal,1.0_pReal)) + ! if the angle equals zero, then we return the rotation axis as [001] + if (dEq0(omega)) then + ax = [ 0.0, 0.0, 1.0, 0.0 ] + elseif (dNeq0(qu%w)) then + s = sign(1.0_pReal,qu%w)/sqrt(qu%x**2+qu%y**2+qu%z**2) + ax = [ qu%x*s, qu%y*s, qu%z*s, omega ] + else + ax = [ qu%x, qu%y, qu%z, PI ] + end if end function qu2ax @@ -788,31 +796,31 @@ end function qu2ax !> @brief convert unit quaternion to Rodrigues vector !--------------------------------------------------------------------------------------------------- pure function qu2ro(qu) result(ro) - use, intrinsic :: IEEE_ARITHMETIC, only: & - IEEE_value, & - IEEE_positive_inf - use prec, only: & - dEq0 - use math, only: & - math_clip - - type(quaternion), intent(in) :: qu - real(pReal), dimension(4) :: ro - - real(pReal) :: s - real(pReal), parameter :: thr = 1.0e-8_pReal - - if (qu%w < thr) then - ro = [qu%x, qu%y, qu%z, IEEE_value(ro(4),IEEE_positive_inf)] - else - s = norm2([qu%x,qu%y,qu%z]) - if (s < thr) then - ro = [ 0.0_pReal, 0.0_pReal, P, 0.0_pReal] - else - ro = [ qu%x/s, qu%y/s, qu%z/s, tan(acos(math_clip(qu%w,-1.0_pReal,1.0_pReal)))] - endif - - end if + use, intrinsic :: IEEE_ARITHMETIC, only: & + IEEE_value, & + IEEE_positive_inf + use prec, only: & + dEq0 + use math, only: & + math_clip + + type(quaternion), intent(in) :: qu + real(pReal), dimension(4) :: ro + + real(pReal) :: s + real(pReal), parameter :: thr = 1.0e-8_pReal + + if (qu%w < thr) then + ro = [qu%x, qu%y, qu%z, IEEE_value(ro(4),IEEE_positive_inf)] + else + s = norm2([qu%x,qu%y,qu%z]) + if (s < thr) then + ro = [ 0.0_pReal, 0.0_pReal, P, 0.0_pReal] + else + ro = [ qu%x/s, qu%y/s, qu%z/s, tan(acos(math_clip(qu%w,-1.0_pReal,1.0_pReal)))] + endif + + end if end function qu2ro @@ -822,26 +830,26 @@ end function qu2ro !> @brief convert unit quaternion to homochoric !--------------------------------------------------------------------------------------------------- pure function qu2ho(qu) result(ho) - use prec, only: & - dEq0 - use math, only: & - math_clip + use prec, only: & + dEq0 + use math, only: & + math_clip - implicit none - type(quaternion), intent(in) :: qu - real(pReal), dimension(3) :: ho - - real(pReal) :: omega, f + implicit none + type(quaternion), intent(in) :: qu + real(pReal), dimension(3) :: ho + + real(pReal) :: omega, f - omega = 2.0 * acos(math_clip(qu%w,-1.0_pReal,1.0_pReal)) - - if (dEq0(omega)) then - ho = [ 0.0, 0.0, 0.0 ] - else - ho = [qu%x, qu%y, qu%z] - f = 0.75 * ( omega - sin(omega) ) - ho = ho/norm2(ho)* f**(1.0/3.0) - end if + omega = 2.0 * acos(math_clip(qu%w,-1.0_pReal,1.0_pReal)) + + if (dEq0(omega)) then + ho = [ 0.0, 0.0, 0.0 ] + else + ho = [qu%x, qu%y, qu%z] + f = 0.75 * ( omega - sin(omega) ) + ho = ho/norm2(ho)* f**(1.0/3.0) + end if end function qu2ho @@ -851,14 +859,14 @@ end function qu2ho !> @brief convert homochoric to cubochoric !--------------------------------------------------------------------------------------------------- function ho2cu(ho) result(cu) - use Lambert, only: & - LambertBallToCube + use Lambert, only: & + LambertBallToCube - implicit none - real(pReal), intent(in), dimension(3) :: ho - real(pReal), dimension(3) :: cu + implicit none + real(pReal), intent(in), dimension(3) :: ho + real(pReal), dimension(3) :: cu - cu = LambertBallToCube(ho) + cu = LambertBallToCube(ho) end function ho2cu @@ -868,14 +876,14 @@ end function ho2cu !> @brief convert cubochoric to homochoric !--------------------------------------------------------------------------------------------------- function cu2ho(cu) result(ho) - use Lambert, only: & - LambertCubeToBall + use Lambert, only: & + LambertCubeToBall - implicit none - real(pReal), intent(in), dimension(3) :: cu - real(pReal), dimension(3) :: ho + implicit none + real(pReal), intent(in), dimension(3) :: cu + real(pReal), dimension(3) :: ho - ho = LambertCubeToBall(cu) + ho = LambertCubeToBall(cu) end function cu2ho @@ -886,11 +894,11 @@ end function cu2ho !--------------------------------------------------------------------------------------------------- pure function ro2eu(ro) result(eu) - implicit none - real(pReal), intent(in), dimension(4) :: ro - real(pReal), dimension(3) :: eu - - eu = om2eu(ro2om(ro)) + implicit none + real(pReal), intent(in), dimension(4) :: ro + real(pReal), dimension(3) :: eu + + eu = om2eu(ro2om(ro)) end function ro2eu @@ -901,11 +909,11 @@ end function ro2eu !--------------------------------------------------------------------------------------------------- pure function eu2ho(eu) result(ho) - implicit none - real(pReal), intent(in), dimension(3) :: eu - real(pReal), dimension(3) :: ho + implicit none + real(pReal), intent(in), dimension(3) :: eu + real(pReal), dimension(3) :: ho - ho = ax2ho(eu2ax(eu)) + ho = ax2ho(eu2ax(eu)) end function eu2ho @@ -916,11 +924,11 @@ end function eu2ho !--------------------------------------------------------------------------------------------------- pure function om2ro(om) result(ro) - implicit none - real(pReal), intent(in), dimension(3,3) :: om - real(pReal), dimension(4) :: ro + implicit none + real(pReal), intent(in), dimension(3,3) :: om + real(pReal), dimension(4) :: ro - ro = eu2ro(om2eu(om)) + ro = eu2ro(om2eu(om)) end function om2ro @@ -931,11 +939,11 @@ end function om2ro !--------------------------------------------------------------------------------------------------- function om2ho(om) result(ho) - implicit none - real(pReal), intent(in), dimension(3,3) :: om - real(pReal), dimension(3) :: ho + implicit none + real(pReal), intent(in), dimension(3,3) :: om + real(pReal), dimension(3) :: ho - ho = ax2ho(om2ax(om)) + ho = ax2ho(om2ax(om)) end function om2ho @@ -946,11 +954,11 @@ end function om2ho !--------------------------------------------------------------------------------------------------- pure function ax2eu(ax) result(eu) - implicit none - real(pReal), intent(in), dimension(4) :: ax - real(pReal), dimension(3) :: eu + implicit none + real(pReal), intent(in), dimension(4) :: ax + real(pReal), dimension(3) :: eu - eu = om2eu(ax2om(ax)) + eu = om2eu(ax2om(ax)) end function ax2eu @@ -961,11 +969,11 @@ end function ax2eu !--------------------------------------------------------------------------------------------------- pure function ro2om(ro) result(om) - implicit none - real(pReal), intent(in), dimension(4) :: ro - real(pReal), dimension(3,3) :: om + implicit none + real(pReal), intent(in), dimension(4) :: ro + real(pReal), dimension(3,3) :: om - om = ax2om(ro2ax(ro)) + om = ax2om(ro2ax(ro)) end function ro2om @@ -976,11 +984,11 @@ end function ro2om !--------------------------------------------------------------------------------------------------- pure function ro2qu(ro) result(qu) - implicit none - real(pReal), intent(in), dimension(4) :: ro - type(quaternion) :: qu - - qu = ax2qu(ro2ax(ro)) + implicit none + real(pReal), intent(in), dimension(4) :: ro + type(quaternion) :: qu + + qu = ax2qu(ro2ax(ro)) end function ro2qu @@ -991,11 +999,11 @@ end function ro2qu !--------------------------------------------------------------------------------------------------- pure function ho2eu(ho) result(eu) - implicit none - real(pReal), intent(in), dimension(3) :: ho - real(pReal), dimension(3) :: eu + implicit none + real(pReal), intent(in), dimension(3) :: ho + real(pReal), dimension(3) :: eu - eu = ax2eu(ho2ax(ho)) + eu = ax2eu(ho2ax(ho)) end function ho2eu @@ -1006,11 +1014,11 @@ end function ho2eu !--------------------------------------------------------------------------------------------------- pure function ho2om(ho) result(om) - implicit none - real(pReal), intent(in), dimension(3) :: ho - real(pReal), dimension(3,3) :: om + implicit none + real(pReal), intent(in), dimension(3) :: ho + real(pReal), dimension(3,3) :: om - om = ax2om(ho2ax(ho)) + om = ax2om(ho2ax(ho)) end function ho2om @@ -1021,12 +1029,11 @@ end function ho2om !--------------------------------------------------------------------------------------------------- pure function ho2ro(ho) result(ro) - implicit none - real(pReal), intent(in), dimension(3) :: ho - real(pReal), dimension(4) :: ro + implicit none + real(pReal), intent(in), dimension(3) :: ho + real(pReal), dimension(4) :: ro - - ro = ax2ro(ho2ax(ho)) + ro = ax2ro(ho2ax(ho)) end function ho2ro @@ -1037,11 +1044,11 @@ end function ho2ro !--------------------------------------------------------------------------------------------------- pure function ho2qu(ho) result(qu) - implicit none - real(pReal), intent(in), dimension(3) :: ho - type(quaternion) :: qu + implicit none + real(pReal), intent(in), dimension(3) :: ho + type(quaternion) :: qu - qu = ax2qu(ho2ax(ho)) + qu = ax2qu(ho2ax(ho)) end function ho2qu @@ -1052,11 +1059,11 @@ end function ho2qu !--------------------------------------------------------------------------------------------------- function eu2cu(eu) result(cu) - implicit none - real(pReal), intent(in), dimension(3) :: eu - real(pReal), dimension(3) :: cu + implicit none + real(pReal), intent(in), dimension(3) :: eu + real(pReal), dimension(3) :: cu - cu = ho2cu(eu2ho(eu)) + cu = ho2cu(eu2ho(eu)) end function eu2cu @@ -1067,11 +1074,11 @@ end function eu2cu !--------------------------------------------------------------------------------------------------- function om2cu(om) result(cu) - implicit none - real(pReal), intent(in), dimension(3,3) :: om - real(pReal), dimension(3) :: cu + implicit none + real(pReal), intent(in), dimension(3,3) :: om + real(pReal), dimension(3) :: cu - cu = ho2cu(om2ho(om)) + cu = ho2cu(om2ho(om)) end function om2cu @@ -1082,11 +1089,11 @@ end function om2cu !--------------------------------------------------------------------------------------------------- function ax2cu(ax) result(cu) - implicit none - real(pReal), intent(in), dimension(4) :: ax - real(pReal), dimension(3) :: cu + implicit none + real(pReal), intent(in), dimension(4) :: ax + real(pReal), dimension(3) :: cu - cu = ho2cu(ax2ho(ax)) + cu = ho2cu(ax2ho(ax)) end function ax2cu @@ -1097,11 +1104,11 @@ end function ax2cu !--------------------------------------------------------------------------------------------------- function ro2cu(ro) result(cu) - implicit none - real(pReal), intent(in), dimension(4) :: ro - real(pReal), dimension(3) :: cu + implicit none + real(pReal), intent(in), dimension(4) :: ro + real(pReal), dimension(3) :: cu - cu = ho2cu(ro2ho(ro)) + cu = ho2cu(ro2ho(ro)) end function ro2cu @@ -1112,11 +1119,11 @@ end function ro2cu !--------------------------------------------------------------------------------------------------- function qu2cu(qu) result(cu) - implicit none - type(quaternion), intent(in) :: qu - real(pReal), dimension(3) :: cu + implicit none + type(quaternion), intent(in) :: qu + real(pReal), dimension(3) :: cu - cu = ho2cu(qu2ho(qu)) + cu = ho2cu(qu2ho(qu)) end function qu2cu @@ -1127,11 +1134,11 @@ end function qu2cu !--------------------------------------------------------------------------------------------------- function cu2eu(cu) result(eu) - implicit none - real(pReal), intent(in), dimension(3) :: cu - real(pReal), dimension(3) :: eu + implicit none + real(pReal), intent(in), dimension(3) :: cu + real(pReal), dimension(3) :: eu - eu = ho2eu(cu2ho(cu)) + eu = ho2eu(cu2ho(cu)) end function cu2eu @@ -1142,11 +1149,11 @@ end function cu2eu !--------------------------------------------------------------------------------------------------- function cu2om(cu) result(om) - implicit none - real(pReal), intent(in), dimension(3) :: cu - real(pReal), dimension(3,3) :: om + implicit none + real(pReal), intent(in), dimension(3) :: cu + real(pReal), dimension(3,3) :: om - om = ho2om(cu2ho(cu)) + om = ho2om(cu2ho(cu)) end function cu2om @@ -1157,11 +1164,11 @@ end function cu2om !--------------------------------------------------------------------------------------------------- function cu2ax(cu) result(ax) - implicit none - real(pReal), intent(in), dimension(3) :: cu - real(pReal), dimension(4) :: ax + implicit none + real(pReal), intent(in), dimension(3) :: cu + real(pReal), dimension(4) :: ax - ax = ho2ax(cu2ho(cu)) + ax = ho2ax(cu2ho(cu)) end function cu2ax @@ -1172,11 +1179,11 @@ end function cu2ax !--------------------------------------------------------------------------------------------------- function cu2ro(cu) result(ro) - implicit none - real(pReal), intent(in), dimension(3) :: cu - real(pReal), dimension(4) :: ro + implicit none + real(pReal), intent(in), dimension(3) :: cu + real(pReal), dimension(4) :: ro - ro = ho2ro(cu2ho(cu)) + ro = ho2ro(cu2ho(cu)) end function cu2ro @@ -1187,11 +1194,11 @@ end function cu2ro !--------------------------------------------------------------------------------------------------- function cu2qu(cu) result(qu) - implicit none - real(pReal), intent(in), dimension(3) :: cu - type(quaternion) :: qu + implicit none + real(pReal), intent(in), dimension(3) :: cu + type(quaternion) :: qu - qu = ho2qu(cu2ho(cu)) + qu = ho2qu(cu2ho(cu)) end function cu2qu From 9759d3d0414346a2c38efb08e227b7bd62f414cc Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 3 Apr 2019 13:17:21 +0200 Subject: [PATCH 38/47] forall is deprecated - performance-wise, there should be no difference for the small loops we have - still, the on-liner syntax was much nicer --- src/crystallite.f90 | 42 ++++++++++++++++++++++-------------------- 1 file changed, 22 insertions(+), 20 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 4fa85173d..f45567d1a 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -346,7 +346,7 @@ subroutine crystallite_init !$OMP PARALLEL DO PRIVATE(myNcomponents,i,c) do e = FEsolving_execElem(1),FEsolving_execElem(2) myNcomponents = homogenization_Ngrains(mesh_element(3,e)) - forall (i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), c = 1:myNcomponents) + do i = FEsolving_execIP(1,e), FEsolving_execIP(2,e); do c = 1, myNcomponents crystallite_Fp0(1:3,1:3,c,i,e) = math_EulerToR(material_EulerAngles(1:3,c,i,e)) ! plastic def gradient reflects init orientation crystallite_Fi0(1:3,1:3,c,i,e) = constitutive_initialFi(c,i,e) crystallite_F0(1:3,1:3,c,i,e) = math_I3 @@ -356,7 +356,7 @@ subroutine crystallite_init crystallite_Fp(1:3,1:3,c,i,e) = crystallite_Fp0(1:3,1:3,c,i,e) crystallite_Fi(1:3,1:3,c,i,e) = crystallite_Fi0(1:3,1:3,c,i,e) crystallite_requested(c,i,e) = .true. - endforall + enddo; enddo enddo !$OMP END PARALLEL DO @@ -754,7 +754,7 @@ subroutine crystallite_stressTangent() + crystallite_invFi(1:3,1:3,c,i,e)*crystallite_invFi(p,o,c,i,e) rhs_3333(1:3,1:3,o,p) = rhs_3333(1:3,1:3,o,p) & - crystallite_subdt(c,i,e)*matmul(invSubFi0,dLidS(1:3,1:3,o,p)) - enddo;enddo + enddo; enddo call math_invert2(temp_99,error,math_3333to99(lhs_3333)) if (error) then call IO_warning(warning_ID=600,el=e,ip=i,g=c, & @@ -781,12 +781,12 @@ subroutine crystallite_stressTangent() crystallite_invFp (1:3,1:3,c,i,e)), & math_inv33(crystallite_subFi0(1:3,1:3,c,i,e))) - forall(p=1:3, o=1:3) + do o=1,3; do p=1,3 rhs_3333(p,o,1:3,1:3) = matmul(dSdFe(p,o,1:3,1:3),temp_33_1) temp_3333(1:3,1:3,p,o) = matmul(matmul(temp_33_2,dLpdS(1:3,1:3,p,o)), & crystallite_invFi(1:3,1:3,c,i,e)) & + matmul(temp_33_3,dLidS(1:3,1:3,p,o)) - end forall + enddo; enddo lhs_3333 = crystallite_subdt(c,i,e)*math_mul3333xx3333(dSdFe,temp_3333) & + math_mul3333xx3333(dSdFi,dFidS) @@ -802,12 +802,12 @@ subroutine crystallite_stressTangent() !-------------------------------------------------------------------------------------------------- ! calculate dFpinvdF temp_3333 = math_mul3333xx3333(dLpdS,dSdF) - forall(p=1:3, o=1:3) + do o=1,3; do p=1,3 dFpinvdF(1:3,1:3,p,o) & = -crystallite_subdt(c,i,e) & * matmul(math_inv33(crystallite_subFp0(1:3,1:3,c,i,e)), & matmul(temp_3333(1:3,1:3,p,o),crystallite_invFi(1:3,1:3,c,i,e))) - end forall + enddo; enddo !-------------------------------------------------------------------------------------------------- ! assemble dPdF @@ -823,15 +823,15 @@ subroutine crystallite_stressTangent() crystallite_S(1:3,1:3,c,i,e)) crystallite_dPdF(1:3,1:3,1:3,1:3,c,i,e) = 0.0_pReal - do p=1, 3 + do p=1,3 crystallite_dPdF(p,1:3,p,1:3,c,i,e) = transpose(temp_33_1) enddo - forall(p=1:3, o=1:3) + do o=1,3; do p=1,3 crystallite_dPdF(1:3,1:3,p,o,c,i,e) = crystallite_dPdF(1:3,1:3,p,o,c,i,e) + & matmul(matmul(crystallite_subF(1:3,1:3,c,i,e),dFpinvdF(1:3,1:3,p,o)),temp_33_2) + & matmul(matmul(temp_33_3,dSdF(1:3,1:3,p,o)),transpose(crystallite_invFp(1:3,1:3,c,i,e))) + & matmul(temp_33_4,transpose(dFpinvdF(1:3,1:3,p,o))) - end forall + enddo; enddo enddo; enddo enddo elementLooping @@ -1302,7 +1302,9 @@ logical function integrateStress(ipc,ip,el,timeFraction) !* calculate Jacobian for correction term if (mod(jacoCounterLp, iJacoLpresiduum) == 0) then - forall(o=1:3,p=1:3) dFe_dLp(o,1:3,p,1:3) = A(o,p)*transpose(invFi_new) ! dFe_dLp(i,j,k,l) = -dt * A(i,k) invFi(l,j) + do o=1,3; do p=1,3 + dFe_dLp(o,1:3,p,1:3) = A(o,p)*transpose(invFi_new) ! dFe_dLp(i,j,k,l) = -dt * A(i,k) invFi(l,j) + enddo; enddo dFe_dLp = - dt * dFe_dLp dRLp_dLp = math_identity2nd(9) & - math_3333to99(math_mul3333xx3333(math_mul3333xx3333(dLp_dS,dS_dFe),dFe_dLp)) @@ -1391,13 +1393,13 @@ logical function integrateStress(ipc,ip,el,timeFraction) !* calculate Jacobian for correction term if (mod(jacoCounterLi, iJacoLpresiduum) == 0) then temp_33 = matmul(matmul(A,B),invFi_current) - forall(o=1:3,p=1:3) + do o=1,3; do p=1,3 dFe_dLi(1:3,o,1:3,p) = -dt*math_I3(o,p)*temp_33 ! dFe_dLp(i,j,k,l) = -dt * A(i,k) invFi(l,j) dFi_dLi(1:3,o,1:3,p) = -dt*math_I3(o,p)*invFi_current - end forall - forall(o=1:3,p=1:3) & + enddo; enddo + do o=1,3; do p=1,3 dFi_dLi(1:3,1:3,o,p) = matmul(matmul(Fi_new,dFi_dLi(1:3,1:3,o,p)),Fi_new) - + enddo; enddo dRLi_dLi = math_identity2nd(9) & - math_3333to99(math_mul3333xx3333(dLi_dS, math_mul3333xx3333(dS_dFe, dFe_dLi) + & math_mul3333xx3333(dS_dFi, dFi_dLi))) & @@ -2102,12 +2104,12 @@ subroutine setConvergenceFlag() i, & !< integration point index in ip loop g !< grain index in grain loop - !OMP DO PARALLEL PRIVATE(i,g) + !OMP DO PARALLEL PRIVATE do e = FEsolving_execElem(1),FEsolving_execElem(2) - forall (i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & - g = 1:homogenization_Ngrains(mesh_element(3,e))) - crystallite_converged(g,i,e) = crystallite_todo(g,i,e) .or. crystallite_converged(g,i,e) ! if still "to do" then converged per definition - end forall; enddo + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do g = 1,homogenization_Ngrains(mesh_element(3,e)) + crystallite_converged(g,i,e) = crystallite_todo(g,i,e) .or. crystallite_converged(g,i,e) ! if still "to do" then converged per definition + enddo; enddo; enddo !OMP END DO PARALLEL end subroutine setConvergenceFlag From 43ead134d2da89b127b727f9052fa8d0815c5309 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 3 Apr 2019 14:49:16 +0200 Subject: [PATCH 39/47] using correct comparison -MIN is the minimum version that works -MAX is the maximum version that works --- src/DAMASK_interface.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/DAMASK_interface.f90 b/src/DAMASK_interface.f90 index e3bc9d1fd..87a73af37 100644 --- a/src/DAMASK_interface.f90 +++ b/src/DAMASK_interface.f90 @@ -60,7 +60,7 @@ subroutine DAMASK_interface_init() getCWD #include -#if defined(__GFORTRAN__) && __GNUC__<=GCC_MIN +#if defined(__GFORTRAN__) && __GNUC__PETSC_MINOR_MAX +#if PETSC_VERSION_MAJOR!=3 || PETSC_VERSION_MINORPETSC_MINOR_MAX =================================================================================================== -- WRONG PETSc VERSION --- WRONG PETSc VERSION --- WRONG PETSc VERSION --- WRONG PETSc VERSION -- =================================================================================================== From 453eb538f75d95a7f5b2eb488584a3ecbcae6ef1 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 3 Apr 2019 16:24:15 +0000 Subject: [PATCH 40/47] preparing for PGI compiler --- src/CMakeLists.txt | 4 ++++ src/Lambert.f90 | 1 + src/crystallite.f90 | 7 +++--- src/future.f90 | 46 ++++++++++++++++++++++++++++++++++++++++ src/lattice.f90 | 1 + src/math.f90 | 1 + src/mesh_base.f90 | 13 ++++++------ src/plastic_nonlocal.f90 | 3 ++- src/quaternions.f90 | 1 + 9 files changed, 67 insertions(+), 10 deletions(-) create mode 100644 src/future.f90 diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index ddcf5972b..2b4fa8f31 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -36,6 +36,10 @@ add_library(IO OBJECT "IO.f90") add_dependencies(IO DAMASK_INTERFACE) list(APPEND OBJECTFILES $) +add_library(FUTURE OBJECT "future.f90") +add_dependencies(FUTURE IO) +list(APPEND OBJECTFILES $) + add_library(NUMERICS OBJECT "numerics.f90") add_dependencies(NUMERICS IO) list(APPEND OBJECTFILES $) diff --git a/src/Lambert.f90 b/src/Lambert.f90 index c570a600e..40bd04a01 100644 --- a/src/Lambert.f90 +++ b/src/Lambert.f90 @@ -42,6 +42,7 @@ module Lambert pReal use math, only: & PI + use future implicit none private diff --git a/src/crystallite.f90 b/src/crystallite.f90 index f45567d1a..b234d133d 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -18,6 +18,7 @@ module crystallite FEsolving_execIP use material, only: & homogenization_Ngrains + use future implicit none @@ -352,7 +353,7 @@ subroutine crystallite_init crystallite_F0(1:3,1:3,c,i,e) = math_I3 crystallite_localPlasticity(c,i,e) = phase_localPlasticity(material_phase(c,i,e)) crystallite_Fe(1:3,1:3,c,i,e) = math_inv33(matmul(crystallite_Fi0(1:3,1:3,c,i,e), & - crystallite_Fp0(1:3,1:3,c,i,e))) ! assuming that euler angles are given in internal strain free configuration + crystallite_Fp0(1:3,1:3,c,i,e))) ! assuming that euler angles are given in internal strain free configuration crystallite_Fp(1:3,1:3,c,i,e) = crystallite_Fp0(1:3,1:3,c,i,e) crystallite_Fi(1:3,1:3,c,i,e) = crystallite_Fi0(1:3,1:3,c,i,e) crystallite_requested(c,i,e) = .true. @@ -600,8 +601,8 @@ function crystallite_stress(dummyArgumentToPreventInternalCompilerErrorWithGCC) + crystallite_subStep(c,i,e) * (crystallite_partionedF (1:3,1:3,c,i,e) & - crystallite_partionedF0(1:3,1:3,c,i,e)) crystallite_Fe(1:3,1:3,c,i,e) = matmul(matmul(crystallite_subF (1:3,1:3,c,i,e), & - crystallite_invFp(1:3,1:3,c,i,e)), & - crystallite_invFi(1:3,1:3,c,i,e)) + crystallite_invFp(1:3,1:3,c,i,e)), & + crystallite_invFi(1:3,1:3,c,i,e)) crystallite_subdt(c,i,e) = crystallite_subStep(c,i,e) * crystallite_dt(c,i,e) crystallite_converged(c,i,e) = .false. endif diff --git a/src/future.f90 b/src/future.f90 new file mode 100644 index 000000000..de11a2e94 --- /dev/null +++ b/src/future.f90 @@ -0,0 +1,46 @@ +!-------------------------------------------------------------------------------------------------- +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @brief New fortran functions for compiler versions that do not support them +!-------------------------------------------------------------------------------------------------- +module future + public +contains + +#if defined(__GFORTRAN__) || __INTEL_COMPILER < 1800 +!-------------------------------------------------------------------------------------------------- +!> @brief substitute for the findloc intrinsic (only for integer, dimension(:) at the moment) +!-------------------------------------------------------------------------------------------------- +function findloc(a,v) + integer, intent(in), dimension(:) :: a + integer, intent(in) :: v + integer :: i,j + integer, allocatable, dimension(:) :: findloc + + allocate(findloc(count(a==v))) + j = 1 + do i = 1, size(a) + if (a(i)==v) then + findloc(j) = i + j = j + 1 + endif + enddo +end function findloc +#endif + +#if defined(__PGI) +!-------------------------------------------------------------------------------------------------- +!> @brief substitute for the norm2 intrinsic (only for real,dimension(3) at the moment) +!-------------------------------------------------------------------------------------------------- +real(pReal) pure function norm2(v) + use prec, only: & + pReal + + implicit none + real(pReal), intent(in), dimension(3) :: v + + norm2 = sqrt(sum(v**2)) + +end function norm2 +#endif + +end module future diff --git a/src/lattice.f90 b/src/lattice.f90 index 6c5a709e4..1b844c31f 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -9,6 +9,7 @@ module lattice use prec, only: & pReal + use future implicit none private diff --git a/src/math.f90 b/src/math.f90 index 5e6f17a87..3338b99e3 100644 --- a/src/math.f90 +++ b/src/math.f90 @@ -8,6 +8,7 @@ module math use prec, only: & pReal + use future implicit none private diff --git a/src/mesh_base.f90 b/src/mesh_base.f90 index 5afdbc3ad..fae228bc0 100644 --- a/src/mesh_base.f90 +++ b/src/mesh_base.f90 @@ -8,13 +8,14 @@ !-------------------------------------------------------------------------------------------------- module mesh_base - use, intrinsic :: iso_c_binding - use prec, only: & - pStringLen, & - pReal, & - pInt - use element, only: & + use, intrinsic :: iso_c_binding + use prec, only: & + pStringLen, & + pReal, & + pInt + use element, only: & tElement + use future implicit none diff --git a/src/plastic_nonlocal.f90 b/src/plastic_nonlocal.f90 index 94f0fde04..f5f48ed11 100644 --- a/src/plastic_nonlocal.f90 +++ b/src/plastic_nonlocal.f90 @@ -7,7 +7,8 @@ module plastic_nonlocal use prec, only: & pReal - + use future + implicit none private real(pReal), parameter, private :: & diff --git a/src/quaternions.f90 b/src/quaternions.f90 index 39dc1d3cd..2716817cf 100644 --- a/src/quaternions.f90 +++ b/src/quaternions.f90 @@ -36,6 +36,7 @@ module quaternions use prec, only: & pReal + use future implicit none public From b0f9444175784b310376beac481779caa1aa7461 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 3 Apr 2019 16:24:45 +0000 Subject: [PATCH 41/47] correct types (PGI complained) --- src/commercialFEM_fileList.f90 | 1 + src/grid_mech_FEM.f90 | 16 ++++++++-------- src/spectral_utilities.f90 | 2 +- 3 files changed, 10 insertions(+), 9 deletions(-) diff --git a/src/commercialFEM_fileList.f90 b/src/commercialFEM_fileList.f90 index 77a8f0df4..301274897 100644 --- a/src/commercialFEM_fileList.f90 +++ b/src/commercialFEM_fileList.f90 @@ -7,6 +7,7 @@ #include "numerics.f90" #include "debug.f90" #include "list.f90" +#include "future.f90" #include "config.f90" #ifdef DAMASKHDF5 #include "HDF5_utilities.f90" diff --git a/src/grid_mech_FEM.f90 b/src/grid_mech_FEM.f90 index 82273c8f1..e31d93637 100644 --- a/src/grid_mech_FEM.f90 +++ b/src/grid_mech_FEM.f90 @@ -153,7 +153,7 @@ subroutine grid_mech_FEM_init [grid(1)],[grid(2)],localK, & mech_grid,ierr) CHKERRQ(ierr) - call DMDASetUniformCoordinates(mech_grid,0.0,geomSize(1),0.0,geomSize(2),0.0,geomSize(3),ierr) + call DMDASetUniformCoordinates(mech_grid,0.0_pReal,geomSize(1),0.0_pReal,geomSize(2),0.0_pReal,geomSize(3),ierr) CHKERRQ(ierr) call SNESSetDM(mech_snes,mech_grid,ierr); CHKERRQ(ierr) call DMsetFromOptions(mech_grid,ierr); CHKERRQ(ierr) @@ -172,9 +172,9 @@ subroutine grid_mech_FEM_init !-------------------------------------------------------------------------------------------------- ! init fields - call VecSet(solution_current,0.0,ierr);CHKERRQ(ierr) - call VecSet(solution_lastInc,0.0,ierr);CHKERRQ(ierr) - call VecSet(solution_rate ,0.0,ierr);CHKERRQ(ierr) + call VecSet(solution_current,0.0_pReal,ierr);CHKERRQ(ierr) + call VecSet(solution_lastInc,0.0_pReal,ierr);CHKERRQ(ierr) + call VecSet(solution_rate ,0.0_pReal,ierr);CHKERRQ(ierr) call DMDAVecGetArrayF90(mech_grid,solution_current,u_current,ierr); CHKERRQ(ierr) call DMDAVecGetArrayF90(mech_grid,solution_lastInc,u_lastInc,ierr); CHKERRQ(ierr) @@ -412,11 +412,11 @@ subroutine grid_mech_FEM_forward(guess,timeinc,timeinc_old,loadCaseTime,deformat if (guess) then - call VecWAXPY(solution_rate,-1.0,solution_lastInc,solution_current,ierr) + call VecWAXPY(solution_rate,-1.0_pReal,solution_lastInc,solution_current,ierr) CHKERRQ(ierr) - call VecScale(solution_rate,1.0/timeinc_old,ierr); CHKERRQ(ierr) + call VecScale(solution_rate,1.0_pReal/timeinc_old,ierr); CHKERRQ(ierr) else - call VecSet(solution_rate,0.0,ierr); CHKERRQ(ierr) + call VecSet(solution_rate,0.0_pReal,ierr); CHKERRQ(ierr) endif call VecCopy(solution_current,solution_lastInc,ierr); CHKERRQ(ierr) @@ -590,7 +590,7 @@ subroutine formResidual(da_local,x_local,f_local,dummy,ierr) !-------------------------------------------------------------------------------------------------- ! constructing residual - call VecSet(f_local,0.0,ierr);CHKERRQ(ierr) + call VecSet(f_local,0.0_pReal,ierr);CHKERRQ(ierr) call DMDAVecGetArrayF90(da_local,f_local,f_scal,ierr);CHKERRQ(ierr) call DMDAVecGetArrayF90(da_local,x_local,x_scal,ierr);CHKERRQ(ierr) ele = 0 diff --git a/src/spectral_utilities.f90 b/src/spectral_utilities.f90 index dd79e67e2..4c5dc3169 100644 --- a/src/spectral_utilities.f90 +++ b/src/spectral_utilities.f90 @@ -253,7 +253,7 @@ subroutine utilities_init write(6,'(a,3(es12.5))') ' size x y z: ', geomSize num%memory_efficient = config_numerics%getInt ('memory_efficient', defaultVal=1) > 0 - num%FFTW_timelimit = config_numerics%getFloat ('fftw_timelimit', defaultVal=-1.0) + num%FFTW_timelimit = config_numerics%getFloat ('fftw_timelimit', defaultVal=-1.0_pReal) num%divergence_correction = config_numerics%getInt ('divergence_correction', defaultVal=2) num%spectral_derivative = config_numerics%getString('spectral_derivative', defaultVal='continuous') num%FFTW_plan_mode = config_numerics%getString('fftw_plan_mode', defaultVal='FFTW_MEASURE') From bdaa703d37e25618faceb1e782f1bd073da07ef6 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 3 Apr 2019 16:13:30 +0200 Subject: [PATCH 42/47] forall is deprecated, do concurrent not yet established --- src/constitutive.f90 | 14 +++----------- 1 file changed, 3 insertions(+), 11 deletions(-) diff --git a/src/constitutive.f90 b/src/constitutive.f90 index 4df97b240..23ae3f07b 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -476,19 +476,11 @@ subroutine constitutive_LpAndItsTangents(Lp, dLp_dS, dLp_dFi, & end select plasticityType -#if defined(__INTEL_COMPILER) || defined(__PGI) - forall(i = 1_pInt:3_pInt, j = 1_pInt:3_pInt) -#else - do concurrent(i = 1_pInt:3_pInt, j = 1_pInt:3_pInt) -#endif + do i=1,3; do j=1,3 dLp_dFi(i,j,1:3,1:3) = matmul(matmul(Fi,S),transpose(dLp_dMp(i,j,1:3,1:3))) + & matmul(matmul(Fi,dLp_dMp(i,j,1:3,1:3)),S) - dLp_dS(i,j,1:3,1:3) = matmul(matmul(transpose(Fi),Fi),dLp_dMp(i,j,1:3,1:3)) ! ToDo: @PS: why not: dLp_dMp:(FiT Fi) -#if defined(__INTEL_COMPILER) || defined(__PGI) - end forall -#else - enddo -#endif + dLp_dS(i,j,1:3,1:3) = matmul(matmul(transpose(Fi),Fi),dLp_dMp(i,j,1:3,1:3)) ! ToDo: @PS: why not: dLp_dMp:(FiT Fi) + enddo; enddo end subroutine constitutive_LpAndItsTangents From f4c507942ac57beb3554138b8a0a185792f898c0 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 3 Apr 2019 18:38:46 +0200 Subject: [PATCH 43/47] let cmake do the work --- src/CMakeLists.txt | 222 ++++++--------------------------------------- 1 file changed, 28 insertions(+), 194 deletions(-) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 2b4fa8f31..372540fc3 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -1,212 +1,46 @@ # special flags for some files if (CMAKE_Fortran_COMPILER_ID STREQUAL "GNU") - SET_SOURCE_FILES_PROPERTIES( "lattice.f90" PROPERTIES - COMPILE_FLAGS "-ffree-line-length-240") - SET_SOURCE_FILES_PROPERTIES( "DAMASK_interface.f90" PROPERTIES - COMPILE_FLAGS "-ffree-line-length-164") # long lines for interaction matrix + SET_SOURCE_FILES_PROPERTIES("lattice.f90" PROPERTIES COMPILE_FLAGS "-ffree-line-length-240") endif() -# The dependency detection in CMake is not functioning for Fortran, -# hence we declare the dependencies from top to bottom in the following +file(GLOB_RECURSE sources *.f90 *.c) -add_library(C_ROUTINES OBJECT "C_routines.c") -set(OBJECTFILES $) +# probably we should have subfolders for abaqus and MSC.Marc +list(FILTER sources EXCLUDE REGEX ".*CPFEM\\.f90") +list(FILTER sources EXCLUDE REGEX ".*DAMASK_marc.*\\.f90") +list(FILTER sources EXCLUDE REGEX ".*mesh_marc.*\\.f90") +list(FILTER sources EXCLUDE REGEX ".*mesh_abaqus.*\\.f90") +list(FILTER sources EXCLUDE REGEX ".*commercialFEM_fileList.*\\.f90") -add_library(SYSTEM_ROUTINES OBJECT "system_routines.f90") -add_dependencies(SYSTEM_ROUTINES C_ROUTINES) -list(APPEND OBJECTFILES $) - -add_library(PREC OBJECT "prec.f90") -list(APPEND OBJECTFILES $) - -add_library(ELEMENT OBJECT "element.f90") -add_dependencies(ELEMENT IO) -list(APPEND OBJECTFILES $) - -add_library(QUIT OBJECT "quit.f90") -add_dependencies(QUIT PREC) -list(APPEND OBJECTFILES $) - -add_library(DAMASK_INTERFACE OBJECT "DAMASK_interface.f90") -add_dependencies(DAMASK_INTERFACE QUIT SYSTEM_ROUTINES) -list(APPEND OBJECTFILES $) - -add_library(IO OBJECT "IO.f90") -add_dependencies(IO DAMASK_INTERFACE) -list(APPEND OBJECTFILES $) - -add_library(FUTURE OBJECT "future.f90") -add_dependencies(FUTURE IO) -list(APPEND OBJECTFILES $) - -add_library(NUMERICS OBJECT "numerics.f90") -add_dependencies(NUMERICS IO) -list(APPEND OBJECTFILES $) - -add_library(DEBUG OBJECT "debug.f90") -add_dependencies(DEBUG IO) -list(APPEND OBJECTFILES $) - -add_library(DAMASK_LIST OBJECT "list.f90") # LIST is a keyword in CMake -add_dependencies(DAMASK_LIST IO) -list(APPEND OBJECTFILES $) - -add_library(DAMASK_CONFIG OBJECT "config.f90") # CONFIG is a keyword in CMake -add_dependencies(DAMASK_CONFIG DAMASK_LIST DEBUG) -list(APPEND OBJECTFILES $) - -add_library(HDF5_UTILITIES OBJECT "HDF5_utilities.f90") -add_dependencies(HDF5_UTILITIES DAMASK_CONFIG NUMERICS) -list(APPEND OBJECTFILES $) - -add_library(RESULTS OBJECT "results.f90") -add_dependencies(RESULTS HDF5_UTILITIES) -list(APPEND OBJECTFILES $) - -add_library(FEsolving OBJECT "FEsolving.f90") -add_dependencies(FEsolving DEBUG) -list(APPEND OBJECTFILES $) - -add_library(MATH OBJECT "math.f90") -add_dependencies(MATH NUMERICS) -list(APPEND OBJECTFILES $) - -add_library(QUATERNIONS OBJECT "quaternions.f90") -add_dependencies(QUATERNIONS MATH) -list(APPEND OBJECTFILES $) - -add_library(LAMBERT OBJECT "Lambert.f90") -add_dependencies(LAMBERT MATH) -list(APPEND OBJECTFILES $) - -add_library(ROTATIONS OBJECT "rotations.f90") -add_dependencies(ROTATIONS LAMBERT QUATERNIONS) -list(APPEND OBJECTFILES $) - -add_library(MESH_BASE OBJECT "mesh_base.f90") -add_dependencies(MESH_BASE ELEMENT) -list(APPEND OBJECTFILES $) - -# SPECTRAL solver and FEM solver use different mesh files -if (PROJECT_NAME STREQUAL "DAMASK_spectral") - add_library(MESH OBJECT "mesh_grid.f90") - add_dependencies(MESH MESH_BASE MATH FEsolving) - list(APPEND OBJECTFILES $) -elseif (PROJECT_NAME STREQUAL "DAMASK_FEM") - add_library(FEZoo OBJECT "FEM_zoo.f90") - add_dependencies(FEZoo IO) - list(APPEND OBJECTFILES $) - add_library(MESH OBJECT "mesh_FEM.f90") - add_dependencies(MESH FEZoo MESH_BASE MATH FEsolving) - list(APPEND OBJECTFILES $) -endif() - -add_library(MATERIAL OBJECT "material.f90") -add_dependencies(MATERIAL MESH DAMASK_CONFIG ROTATIONS) -list(APPEND OBJECTFILES $) - -add_library(LATTICE OBJECT "lattice.f90") -add_dependencies(LATTICE MATERIAL) -list(APPEND OBJECTFILES $) - -# For each modular section -add_library (PLASTIC OBJECT - "plastic_dislotwin.f90" - "plastic_disloUCLA.f90" - "plastic_isotropic.f90" - "plastic_phenopowerlaw.f90" - "plastic_kinematichardening.f90" - "plastic_nonlocal.f90" - "plastic_none.f90") -add_dependencies(PLASTIC LATTICE RESULTS) -list(APPEND OBJECTFILES $) - -add_library (KINEMATICS OBJECT - "kinematics_cleavage_opening.f90" - "kinematics_slipplane_opening.f90" - "kinematics_thermal_expansion.f90") -add_dependencies(KINEMATICS LATTICE RESULTS) -list(APPEND OBJECTFILES $) - -add_library (SOURCE OBJECT - "source_thermal_dissipation.f90" - "source_thermal_externalheat.f90" - "source_damage_isoBrittle.f90" - "source_damage_isoDuctile.f90" - "source_damage_anisoBrittle.f90" - "source_damage_anisoDuctile.f90") -add_dependencies(SOURCE LATTICE RESULTS) -list(APPEND OBJECTFILES $) - -add_library(CONSTITUTIVE OBJECT "constitutive.f90") -add_dependencies(CONSTITUTIVE PLASTIC KINEMATICS SOURCE) -list(APPEND OBJECTFILES $) - -add_library(CRYSTALLITE OBJECT "crystallite.f90") -add_dependencies(CRYSTALLITE CONSTITUTIVE) -list(APPEND OBJECTFILES $) - -add_library(HOMOGENIZATION OBJECT - "homogenization_RGC.f90" - "homogenization_isostrain.f90" - "homogenization_none.f90") -add_dependencies(HOMOGENIZATION CRYSTALLITE) -list(APPEND OBJECTFILES $) - -add_library(DAMAGE OBJECT - "damage_none.f90" - "damage_local.f90" - "damage_nonlocal.f90") -add_dependencies(DAMAGE CRYSTALLITE) -list(APPEND OBJECTFILES $) - -add_library(THERMAL OBJECT - "thermal_isothermal.f90" - "thermal_adiabatic.f90" - "thermal_conduction.f90") -add_dependencies(THERMAL CRYSTALLITE) -list(APPEND OBJECTFILES $) - -add_library(DAMASK_ENGINE OBJECT "homogenization.f90") -add_dependencies(DAMASK_ENGINE THERMAL DAMAGE HOMOGENIZATION) -list(APPEND OBJECTFILES $) - -add_library(DAMASK_CPFE OBJECT "CPFEM2.f90") -add_dependencies(DAMASK_CPFE DAMASK_ENGINE) -list(APPEND OBJECTFILES $) if (PROJECT_NAME STREQUAL "DAMASK_spectral") - add_library(SPECTRAL_UTILITIES OBJECT "spectral_utilities.f90") - add_dependencies(SPECTRAL_UTILITIES DAMASK_CPFE) - list(APPEND OBJECTFILES $) - add_library(SPECTRAL_SOLVER OBJECT - "grid_thermal_spectral.f90" - "grid_damage_spectral.f90" - "grid_mech_FEM.f90" - "grid_mech_spectral_basic.f90" - "grid_mech_spectral_polarisation.f90") - add_dependencies(SPECTRAL_SOLVER SPECTRAL_UTILITIES) - list(APPEND OBJECTFILES $) + # probably we should have subfolders for FEM and spectral + list(FILTER sources EXCLUDE REGEX ".*DAMASK_FEM.*\\.f90") + list(FILTER sources EXCLUDE REGEX ".*FEM_utilities.*\\.f90") + list(FILTER sources EXCLUDE REGEX ".*FEM_zoo.*\\.f90") + list(FILTER sources EXCLUDE REGEX ".*mesh_FEM.*\\.f90") + list(FILTER sources EXCLUDE REGEX ".*FEM_mech.*\\.f90") if(NOT CMAKE_BUILD_TYPE STREQUAL "SYNTAXONLY") - add_executable(DAMASK_spectral "DAMASK_grid.f90" ${OBJECTFILES}) + add_executable(DAMASK_spectral ${sources}) else() - add_library(DAMASK_spectral OBJECT "DAMASK_grid.f90") + add_library(DAMASK_spectral OBJECT ${sources}) endif() - add_dependencies(DAMASK_spectral SPECTRAL_SOLVER) elseif (PROJECT_NAME STREQUAL "DAMASK_FEM") - add_library(FEM_UTILITIES OBJECT "FEM_utilities.f90") - add_dependencies(FEM_UTILITIES DAMASK_CPFE) - list(APPEND OBJECTFILES $) + + # probably we should have subfolders for FEM and spectral + list(FILTER sources EXCLUDE REGEX ".*DAMASK_grid.*\\.f90") + list(FILTER sources EXCLUDE REGEX ".*grid_mech_FEM.*\\.f90") + list(FILTER sources EXCLUDE REGEX ".*grid_mech_spectral_basic.*\\.f90") + list(FILTER sources EXCLUDE REGEX ".*grid_mech_spectral_polarisation.*\\.f90") + list(FILTER sources EXCLUDE REGEX ".*grid_damage_spectral.*\\.f90") + list(FILTER sources EXCLUDE REGEX ".*grid_thermal_spectral.*\\.f90") + list(FILTER sources EXCLUDE REGEX ".*spectral_utilities.*\\.f90") + list(FILTER sources EXCLUDE REGEX ".*mesh_grid.*\\.f90") - add_library(FEM_SOLVER OBJECT - "FEM_mech.f90") - add_dependencies(FEM_SOLVER FEM_UTILITIES) - list(APPEND OBJECTFILES $) - - add_executable(DAMASK_FEM "DAMASK_FEM.f90" ${OBJECTFILES}) - add_dependencies(DAMASK_FEM FEM_SOLVER) + add_executable(DAMASK_spectral ${sources}) + endif() From 43bf51da67541a538a69a3b4ab0a842418c7aa1b Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 3 Apr 2019 20:23:46 +0200 Subject: [PATCH 44/47] copy and paste error in installation target of FEM --- CMakeLists.txt | 12 ++++++------ src/CMakeLists.txt | 4 ++-- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index d23245f52..82335ee4b 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -106,9 +106,9 @@ set (CMAKE_C_COMPILER "${PETSC_MPICC}") # DAMASK solver defines project to build if (DAMASK_SOLVER STREQUAL "GRID") - project (DAMASK_spectral Fortran C) + project (DAMASK_grid Fortran C) add_definitions (-DGrid) - message ("Building Spectral Solver\n") + message ("Building Grid Solver\n") elseif (DAMASK_SOLVER STREQUAL "FEM") project (DAMASK_FEM Fortran C) add_definitions (-DFEM) @@ -489,11 +489,11 @@ add_subdirectory (src) # INSTALL BUILT BINARIES if (CMAKE_BUILD_TYPE STREQUAL "SYNTAXONLY") - exec_program (mktemp ARGS -d OUTPUT_VARIABLE BLACK_HOLE) - install (PROGRAMS ${PROJECT_BINARY_DIR}/src/prec.mod - DESTINATION ${BLACK_HOLE}) + exec_program (mktemp OUTPUT_VARIABLE nothing) + exec_program (mktemp ARGS -d OUTPUT_VARIABLE black_hole) + install (PROGRAMS ${nothing} DESTINATION ${black_hole}) else () - if (PROJECT_NAME STREQUAL "DAMASK_spectral") + if (PROJECT_NAME STREQUAL "DAMASK_grid") install (PROGRAMS ${PROJECT_BINARY_DIR}/src/DAMASK_spectral DESTINATION ${CMAKE_INSTALL_PREFIX}) elseif (PROJECT_NAME STREQUAL "DAMASK_FEM") diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 372540fc3..274069226 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -14,7 +14,7 @@ list(FILTER sources EXCLUDE REGEX ".*mesh_abaqus.*\\.f90") list(FILTER sources EXCLUDE REGEX ".*commercialFEM_fileList.*\\.f90") -if (PROJECT_NAME STREQUAL "DAMASK_spectral") +if (PROJECT_NAME STREQUAL "DAMASK_grid") # probably we should have subfolders for FEM and spectral list(FILTER sources EXCLUDE REGEX ".*DAMASK_FEM.*\\.f90") @@ -41,6 +41,6 @@ elseif (PROJECT_NAME STREQUAL "DAMASK_FEM") list(FILTER sources EXCLUDE REGEX ".*spectral_utilities.*\\.f90") list(FILTER sources EXCLUDE REGEX ".*mesh_grid.*\\.f90") - add_executable(DAMASK_spectral ${sources}) + add_executable(DAMASK_FEM ${sources}) endif() From 5f462729c7e4d82e4adbb34e6206e1a8dcf8ab86 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 3 Apr 2019 21:42:30 +0000 Subject: [PATCH 45/47] was .or., i.e. should be max not min --- src/grid_damage_spectral.f90 | 2 +- src/grid_thermal_spectral.f90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/grid_damage_spectral.f90 b/src/grid_damage_spectral.f90 index 2019664e2..c5e9a254b 100644 --- a/src/grid_damage_spectral.f90 +++ b/src/grid_damage_spectral.f90 @@ -199,7 +199,7 @@ function grid_damage_spectral_solution(timeinc,timeinc_old,loadCaseTime) result( call MPI_Allreduce(MPI_IN_PLACE,stagNorm,1,MPI_DOUBLE,MPI_MAX,PETSC_COMM_WORLD,ierr) call MPI_Allreduce(MPI_IN_PLACE,solnNorm,1,MPI_DOUBLE,MPI_MAX,PETSC_COMM_WORLD,ierr) damage_stagInc = damage_current - solution%stagConverged = stagNorm < min(err_damage_tolAbs, err_damage_tolRel*solnNorm) + solution%stagConverged = stagNorm < max(err_damage_tolAbs, err_damage_tolRel*solnNorm) !-------------------------------------------------------------------------------------------------- ! updating damage state diff --git a/src/grid_thermal_spectral.f90 b/src/grid_thermal_spectral.f90 index adaf0d429..31740feb9 100644 --- a/src/grid_thermal_spectral.f90 +++ b/src/grid_thermal_spectral.f90 @@ -202,7 +202,7 @@ function grid_thermal_spectral_solution(timeinc,timeinc_old,loadCaseTime) result call MPI_Allreduce(MPI_IN_PLACE,stagNorm,1,MPI_DOUBLE,MPI_MAX,PETSC_COMM_WORLD,ierr) call MPI_Allreduce(MPI_IN_PLACE,solnNorm,1,MPI_DOUBLE,MPI_MAX,PETSC_COMM_WORLD,ierr) temperature_stagInc = temperature_current - solution%stagConverged = stagNorm < min(err_thermal_tolAbs, err_thermal_tolRel*solnNorm) + solution%stagConverged = stagNorm < max(err_thermal_tolAbs, err_thermal_tolRel*solnNorm) !-------------------------------------------------------------------------------------------------- ! updating thermal state From 19b1bc5e764fc1fd7876e5d21276d8f9b8ad58c9 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 3 Apr 2019 21:43:00 +0000 Subject: [PATCH 46/47] consistent use of keyword --- src/DAMASK_grid.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/DAMASK_grid.f90 b/src/DAMASK_grid.f90 index 663921084..29b505d14 100644 --- a/src/DAMASK_grid.f90 +++ b/src/DAMASK_grid.f90 @@ -167,7 +167,7 @@ program DAMASK_spectral !-------------------------------------------------------------------------------------------------- ! assign mechanics solver depending on selected type - select case (trim(config_numerics%getString('spectralsolver',defaultVal='basic'))) + select case (trim(config_numerics%getString('spectral_solver',defaultVal='basic'))) case ('basic') mech_init => grid_mech_spectral_basic_init mech_forward => grid_mech_spectral_basic_forward From a2f9517cedf5076705b8f413184538375d8b880b Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 3 Apr 2019 22:36:00 +0000 Subject: [PATCH 47/47] fixed tests --- CMakeLists.txt | 2 +- PRIVATE | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 82335ee4b..8be07198a 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -1,6 +1,6 @@ ######################################################################################## # Compiler options for building DAMASK -cmake_minimum_required (VERSION 2.8.8 FATAL_ERROR) +cmake_minimum_required (VERSION 3.6.0 FATAL_ERROR) #--------------------------------------------------------------------------------------- # Find PETSc from system environment diff --git a/PRIVATE b/PRIVATE index 04bc997b6..c7bc54a26 160000 --- a/PRIVATE +++ b/PRIVATE @@ -1 +1 @@ -Subproject commit 04bc997b6660acab972abccaf2ceb7f45b97e9a0 +Subproject commit c7bc54a26c8b6ed404aabec4653227e93fa028e2